(**************************************************************************)
(*                                                                        *)
(*  This file is part of Frama-C.                                         *)
(*                                                                        *)
(*  Copyright (C) 2007-2020                                               *)
(*    CEA (Commissariat à l'énergie atomique et aux énergies              *)
(*         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).            *)
(*                                                                        *)
(**************************************************************************)

open Cil
open Cil_types
open Cil_datatype

exception Error of Cil_types.location * string
exception Unbound of string

let find_var kf kinstr ?label ~var =
  let vi =
    try
      let vi = Globals.Vars.find_from_astinfo var (VLocal kf) in
      (match kinstr with
        | Kglobal -> vi (* don't refine search: the Kglobal here
                           does not indicate the function contract, but merely
                           the fact that we do not have any information about
                           the targeted program point. Hence, no scope check
                           can be performed or we might reject many legitimate
                           terms and predicates.
                        *)
        | Kstmt stmt ->
          let scope =
            match label with
            | None | Some "Here" | Some "Post" | Some "Old" -> stmt
            | Some "Pre" -> raise Not_found (* no local variable in scope. *)
            | Some "Init" -> raise Not_found (* no local variable in scope. *)
            | Some "LoopEntry" | Some "LoopCurrent" ->
              if not (Kernel_function.stmt_in_loop kf stmt) then
                Kernel.fatal
                  "Use of LoopEntry or LoopCurrent outside of a loop";
              Kernel_function.find_enclosing_loop kf stmt
            | Some l ->
              (try let s = Kernel_function.find_label kf l in !s
               with Not_found ->
                 Kernel.fatal
                  "Use of label %s that does not exist in function %a"
                  l Kernel_function.pretty kf)
          in
         if Kernel_function.var_is_in_scope scope vi then vi
         else raise Not_found)
    with Not_found ->
      try
        Globals.Vars.find_from_astinfo var (VFormal kf)
      with Not_found ->
        Globals.Vars.find_from_astinfo var VGlobal
  in
  cvar_to_lvar vi

(** Create a logic typer, the interpretation being done for the given
    kernel_function and stmt (the stmt is used check that loop invariants
    are allowed). *)
(* It is theoretically possible to use a first-class module instead, but the
   required signatures are not exported in Logic_typing. *)
module DefaultLT (X:
sig
  val kf: Kernel_function.t
  val kinstr: Cil_types.kinstr
end) =
  Logic_typing.Make
    (struct
      let anonCompFieldName = Cabs2cil.anonCompFieldName
      let conditionalConversion = Cabs2cil.logicConditionalConversion

      let is_loop () =
        match X.kinstr with
          | Kglobal -> false
          | Kstmt s -> Kernel_function.stmt_in_loop X.kf s

      let find_macro _ = raise Not_found

      let find_var ?label ~var = find_var X.kf X.kinstr ?label ~var

      let find_enum_tag x =
        try
          Globals.Types.find_enum_tag x
        with Not_found ->
          (* The ACSL typer tries to parse a string, first as a variable,
             then as an enum. We report the "Unbound variable" message
             here, as it is nicer for the user. However, this short-circuits
             the later stages of resolution, for example global logic
             variables. *)
          raise (Unbound ("Unbound variable " ^ x))

      let find_comp_field info s =
        let field = Cil.getCompField info s in
        Field(field,NoOffset)

      let find_type = Globals.Types.find_type

      let find_label s = Kernel_function.find_label X.kf s
      include Logic_env

      let add_logic_function =
        add_logic_function_gen Logic_utils.is_same_logic_profile

      let remove_logic_info =
        remove_logic_info_gen Logic_utils.is_same_logic_profile

      let integral_cast ty t =
        raise
          (Failure
             (Format.asprintf
                "term %a has type %a, but %a is expected."
                Printer.pp_term t
                Printer.pp_logic_type Linteger
                Printer.pp_typ ty))

      let error loc msg =
        Pretty_utils.ksfprintf (fun e -> raise (Error (loc, e))) msg

      let on_error f rollback x =
        try f x with Error _ as exn -> rollback (); raise exn

     end)

(** Set up the parser for the infamous 'C hack' needed to parse typedefs *)
let sync_typedefs () =
  Logic_env.reset_typenames ();
  Globals.Types.iter_types
    (fun name _ ns ->
      if ns = Logic_typing.Typedef then Logic_env.add_typename name)

let wrap f parsetree loc =
  match parsetree with
  | None -> raise (Error (loc, "Syntax error in annotation"))
  | Some annot -> try f annot with Unbound s -> raise (Error (loc, s))

let code_annot kf stmt s =
  sync_typedefs ();
  let module LT = DefaultLT(struct
    let kf = kf
    let kinstr = Kstmt stmt
  end) in
  let loc = Stmt.loc stmt in
  let pa =
    Extlib.opt_bind
      (function (_, Logic_ptree.Acode_annot (_,a)) -> Some a | _ -> None)
      (Logic_lexer.annot (fst loc,s))
  in
  let parse pa =
    LT.code_annot
      (Stmt.loc stmt)
      (Logic_utils.get_behavior_names (Annotations.funspec kf))
      (Ctype (Kernel_function.get_return_type kf)) pa
  in
  wrap parse pa loc

let default_term_env () =
  Logic_typing.append_here_label (Logic_typing.Lenv.empty())

let term kf ?(loc=Location.unknown) ?(env=default_term_env ()) s =
  sync_typedefs ();
  let module LT = DefaultLT(struct
    let kf = kf
    let kinstr = Kglobal
  end) in
  let pa_expr = Extlib.opt_map snd (Logic_lexer.lexpr (fst loc, s)) in
  let parse pa_expr = LT.term env pa_expr in
  wrap parse pa_expr loc

let term_lval kf ?(loc=Location.unknown) ?(env=default_term_env ()) s =
  match (term kf ~loc ~env s).term_node with
  | TLval lv -> lv
  | _ -> raise (Error (loc, "Syntax error (expecting an lvalue)"))

let predicate kf ?(loc=Location.unknown) ?(env=default_term_env ()) s =
  sync_typedefs ();
  let module LT = DefaultLT(struct
    let kf = kf
    let kinstr = Kglobal
  end) in
  let pa_expr = Extlib.opt_map snd (Logic_lexer.lexpr (fst loc, s)) in
  let parse pa_expr = LT.predicate env pa_expr in
  wrap parse pa_expr loc

let error_lval () = raise Db.Properties.Interp.No_conversion

let rec logic_type_to_typ = function
  | Ctype typ -> typ
  | Linteger -> TInt(ILongLong,[]) (*TODO: to have an unlimited integer type
                                    in the logic interpretation*)
  | Lreal -> TFloat(FDouble,[]) (* TODO: handle reals, not floats... *)
  | Ltype({lt_name = name},[]) when name = Utf8_logic.boolean  ->
      TInt(ILongLong,[])
  | Ltype({lt_name = "set"},[t]) -> logic_type_to_typ t
  | Ltype _ | Lvar _ | Larrow _ -> error_lval ()


(* Expect conversion to be possible on all sub-terms, otherwise raise an error. *)

let logic_var_to_var { lv_origin = lv } =
  match lv with
    | None -> error_lval ()
    | Some lv -> lv

let create_const_list loc kind low high =
  let rec aux acc i =
    if Integer.lt i low then acc
    else
      aux (new_exp ~loc (Const (CInt64 (i,kind,None)))::acc) (Integer.pred i)
  in aux [] high

let range low high =
  let loc = fst low.eloc, snd high.eloc in
  match (Cil.constFold true low).enode, (Cil.constFold true high).enode with
      Const(CInt64(low,kind,_)), Const(CInt64(high,_,_)) ->
        create_const_list loc kind low high
    | _ -> error_lval()

let singleton f loc =
  match f loc with
      [ l ] -> l
    | _ -> error_lval()

let rec loc_lval_to_lval ~result (lh, lo) =
  Extlib.product
    (fun x y -> (x,y))
    (loc_lhost_to_lhost ~result lh)
    (loc_offset_to_offset ~result lo)

and loc_lhost_to_lhost ~result = function
  | TVar lvar -> [Var (logic_var_to_var lvar)]
  | TMem lterm -> List.map (fun x -> Mem x) (loc_to_exp ~result lterm)
  | TResult _ ->
      ( match result with
        None -> error_lval()
      | Some v -> [Var v])

and loc_offset_to_offset ~result = function
  | TNoOffset -> [NoOffset]
  | TModel _ -> error_lval ()
  | TField (fi, lo) ->
      List.map (fun x -> Field (fi,x)) (loc_offset_to_offset ~result lo)
  | TIndex (lexp, lo) ->
      Extlib.product
	(fun x y -> Index(x,y))
        (loc_to_exp ~result lexp) 
	(loc_offset_to_offset ~result lo)

and loc_to_exp ~result {term_node = lnode ; term_type = ltype; term_loc = loc} =
  match lnode with
  | TLval lv ->
      List.map (fun x -> new_exp ~loc (Lval x)) (loc_lval_to_lval ~result lv)
  | TAddrOf lv ->
      List.map (fun x -> new_exp ~loc (AddrOf x)) (loc_lval_to_lval ~result lv)
  | TStartOf lv ->
      List.map (fun x -> new_exp ~loc (StartOf x)) (loc_lval_to_lval ~result lv)
  | TSizeOfE lexp ->
      List.map (fun x -> new_exp ~loc (SizeOfE x)) (loc_to_exp ~result lexp)
  | TAlignOfE lexp ->
      List.map (fun x -> new_exp ~loc (AlignOfE x)) (loc_to_exp ~result lexp)
  | TUnOp (unop, lexp) ->
      List.map
        (fun x -> new_exp ~loc (UnOp (unop, x, logic_type_to_typ ltype)))
        (loc_to_exp ~result lexp)
  | TBinOp (binop, lexp1, lexp2) ->
      Extlib.product
        (fun x y -> new_exp ~loc (BinOp (binop, x,y, logic_type_to_typ ltype)))
        (loc_to_exp ~result lexp1) 
	(loc_to_exp ~result lexp2)
  | TSizeOfStr string -> [new_exp ~loc (SizeOfStr string)]
  | TConst constant -> 
    (* TODO: Very likely to fail on large integer and incorrect on reals not
       representable as floats *)
    [new_exp ~loc (Const (Logic_utils.lconstant_to_constant constant))]
  | TCastE (typ, lexp) ->
      List.map
        (fun x -> new_exp ~loc (CastE (typ, x))) (loc_to_exp ~result lexp)
  | TAlignOf typ -> [new_exp ~loc (AlignOf typ)]
  | TSizeOf typ -> [new_exp ~loc (SizeOf typ)]
  | Trange (Some low, Some high) ->
      let low = singleton (loc_to_exp ~result) low in
      let high = singleton (loc_to_exp ~result) high in
      range low high
  | Tunion l -> List.concat (List.map (loc_to_exp ~result) l)
  | Tempty_set -> []
  | Tinter _ | Tcomprehension _ -> error_lval()
  | Tat ({term_node = TAddrOf (TVar _, TNoOffset)} as taddroflval, _) ->
      loc_to_exp ~result taddroflval
  | TLogic_coerce(Linteger, t) when Logic_typing.is_integral_type t.term_type ->
    loc_to_exp ~result t
  | TLogic_coerce(Lreal, t) when Logic_typing.is_integral_type t.term_type ->
    List.map
      (fun x -> new_exp ~loc (CastE (logic_type_to_typ Lreal, x)))
      (loc_to_exp ~result t)
  | TLogic_coerce(Lreal, t) when Logic_typing.is_arithmetic_type t.term_type ->
    loc_to_exp ~result t
  | TLogic_coerce (set, t)
      when
        Logic_const.is_set_type set &&
          Logic_utils.is_same_type
          (Logic_typing.type_of_set_elem set) t.term_type ->
    loc_to_exp ~result t
  | Tnull -> [ Cil.mkCast (Cil.zero ~loc) (TPtr(TVoid [], [])) ]

  (* additional constructs *)
  | Tapp _ | Tlambda _ | Trange _   | Tlet _
  | TDataCons _
  | Tif _
  | Tat _
  | Tbase_addr _
  | Toffset _
  | Tblock_length _
  | TUpdate _ | Ttypeof _ | Ttype _
  | TLogic_coerce _
    -> error_lval ()

let rec loc_to_lval ~result t =
  match t.term_node with
  | TLval lv -> loc_lval_to_lval ~result lv
  | TAddrOf lv -> loc_lval_to_lval ~result lv
  | TStartOf lv -> loc_lval_to_lval ~result lv
  | Tunion l1 -> List.concat (List.map (loc_to_lval ~result) l1)
  | Tempty_set -> []
  (* coercions to arithmetic types cannot be lval. We only have to consider
     a coercion to set here.
   *) 
  | TLogic_coerce(set, t) when
      Logic_typing.is_set_type set &&
        Logic_utils.is_same_type
        (Logic_typing.type_of_set_elem set) t.term_type ->
    loc_to_lval ~result t
  | Tinter _ -> error_lval() (* TODO *)
  | Tcomprehension _ -> error_lval()
  | TSizeOfE _ | TAlignOfE _ | TUnOp _ | TBinOp _ | TSizeOfStr _
  | TConst _ | TCastE _ | TAlignOf _ | TSizeOf _ | Tapp _ | Tif _
  | Tat _ | Toffset _ | Tbase_addr _ | Tblock_length _ | Tnull | Trange _
  | TDataCons _ | TUpdate _ | Tlambda _
  | Ttypeof _ | Ttype _ | Tlet _ | TLogic_coerce _ ->
      error_lval ()

let loc_to_offset ~result loc =
  let rec aux h =
    function
        TLval(h',o) | TStartOf (h',o) ->
          (match h with None -> Some h', loc_offset_to_offset ~result o
             | Some h when Logic_utils.is_same_lhost h h' ->
                 Some h, loc_offset_to_offset ~result o
             | Some _ -> error_lval()
          )
      | Tat ({ term_node = TLval(TResult _,_)} as lv, BuiltinLabel Post) ->
        aux h lv.term_node
      | Tunion locs -> List.fold_left
            (fun (b,l) x ->
               let (b,l') = aux b x.term_node in b, l @ l') (h,[]) locs
      | Tempty_set -> h,[]
      | Trange _ | TAddrOf _ | Tat _
      | TSizeOfE _ | TAlignOfE _ | TUnOp _ | TBinOp _ | TSizeOfStr _
      | TConst _ | TCastE _ | TAlignOf _ | TSizeOf _ | Tapp _ | Tif _
      | Toffset _ | Tbase_addr _ | Tblock_length _ | Tnull
      | TDataCons _ | TUpdate _ | Tlambda _
      | Ttypeof _ | Ttype _ | Tcomprehension _ | Tinter _ | Tlet _
      | TLogic_coerce _ 
          -> error_lval ()
  in snd (aux None loc.term_node)

let term_lval_to_lval ~result = singleton (loc_lval_to_lval ~result)

let term_to_lval ~result = singleton (loc_to_lval ~result)

let term_to_exp ~result = singleton (loc_to_exp ~result)

let term_offset_to_offset ~result = singleton (loc_offset_to_offset ~result)



(** Utilities to identify [Locations.Zone.t] involved into
    [code_annotation]. *)
module To_zone : sig

  type ctx = Db.Properties.Interp.To_zone.t_ctx =
      {state_opt:bool option;
       ki_opt:(stmt * bool) option;
       kf:Kernel_function.t}

  val mk_ctx_func_contrat: kernel_function -> state_opt:bool option -> ctx
  (** [mk_ctx_func_contrat] to define an interpretation context related to
      [kernel_function] contracts. 
      The control point of the interpretation is defined as follows:
      - pre-state if  [state_opt=Some true]
      - post-state if [state_opt=Some false]
      - pre-state with possible reference to the post-state if
      [state_opt=None]. *)

  val mk_ctx_stmt_contrat: 
    kernel_function -> stmt -> state_opt:bool option -> ctx
  (** [mk_ctx_stmt_contrat] to define an interpretation context related to
      [stmt] contracts. 
      The control point of the interpretation is defined as follows:
      - pre-state if  [state_opt=Some true]
      - post-state if [state_opt=Some false]
      - pre-state with possible reference to the post-state if
      [state_opt=None]. *)

  val mk_ctx_stmt_annot: kernel_function -> stmt -> ctx
  (** [mk_ctx_stmt_annot] to define an interpretation context related to an
      annotation attached before the [stmt]. *)

  type zone_info = Db.Properties.Interp.To_zone.t_zone_info
  type decl = Db.Properties.Interp.To_zone.t_decl
  type pragmas = Db.Properties.Interp.To_zone.t_pragmas
  val not_yet_implemented : string ref
  exception NYI of string

  val from_term: term -> ctx -> (zone_info * decl)
    (** Entry point to get zones
        needed to evaluate the [term] relative to the [ctx] of
	interpretation. *) 

  val from_terms: term list -> ctx -> (zone_info * decl)
    (** Entry point to get zones
        needed to evaluate the list of [terms] relative to the [ctx] of
	interpretation. *) 

  val from_pred: predicate -> ctx -> (zone_info * decl)
    (** Entry point to get zones
        needed to evaluate the [predicate] relative to the [ctx] of
	interpretation. *) 

  val from_preds: predicate list -> ctx -> (zone_info * decl)
    (** Entry point to get zones
        needed to evaluate the list of [predicates] relative to the [ctx] of
	interpretation. *) 

  val from_stmt_annot: 
    code_annotation -> (stmt * kernel_function) -> 
    (zone_info * decl) * pragmas
  (** Entry point to get zones needed to evaluate code annotations of this
      [stmt]. *)

  val from_stmt_annots:
    (code_annotation -> bool) option ->
    (stmt * kernel_function) -> (zone_info * decl) * pragmas
  (** Entry point to get zones needed to evaluate code annotations of this
      [stmt]. *) 

  val from_func_annots:
    ((stmt -> unit) -> kernel_function -> unit) ->
    (code_annotation  -> bool) option ->
    kernel_function -> (zone_info * decl) * pragmas
  (** Entry point to get zones needed to evaluate code annotations of this
      [kf]. *) 

  val code_annot_filter:
    code_annotation ->
    threat:bool -> user_assert:bool -> slicing_pragma:bool ->
    loop_inv:bool -> loop_var:bool -> others:bool -> bool
    (** To quickly build a annotation filter *)
  end
  = 
struct

  exception NYI of string
  (* Reimport here the type definitions of Db.Properties.Interp. See
     documentation there. *)
  type ctx = Db.Properties.Interp.To_zone.t_ctx =
          {state_opt:bool option;
           ki_opt:(stmt * bool) option;
           kf:Kernel_function.t}
  
  type pragmas = Db.Properties.Interp.To_zone.t_pragmas =
      {ctrl: Stmt.Set.t ; stmt: Stmt.Set.t} 

  type t = Db.Properties.Interp.To_zone.t 
      = {before:bool ; ki:stmt ; zone:Locations.Zone.t}
  type zone_info = Db.Properties.Interp.To_zone.t_zone_info

  type decl = Db.Properties.Interp.To_zone.t_decl =
      {var: Varinfo.Set.t ; lbl: Logic_label.Set.t}

  let mk_ctx_func_contrat kf ~state_opt =
    { state_opt = state_opt;
      ki_opt = None;
      kf = kf }

  let mk_ctx_stmt_contrat kf ki ~state_opt =
    { state_opt=state_opt;
      ki_opt= Some(ki, false);
      kf = kf }

  let mk_ctx_stmt_annot kf ki =
    { state_opt = Some true;
      ki_opt = Some(ki, true);
      kf = kf }


  let empty_pragmas =
    { ctrl = Stmt.Set.empty;
      stmt = Stmt.Set.empty }

  let other_zones = Stmt.Hashtbl.create 7
  let locals = ref Varinfo.Set.empty
  let labels = ref Logic_label.Set.empty
  let pragmas = ref empty_pragmas

  let zone_result = ref (Some other_zones)
  let not_yet_implemented = ref ""

  let add_top_zone not_yet_implemented_msg = match !zone_result with
    | None -> (* top zone *) ()
    | Some other_zones ->
      Stmt.Hashtbl.clear other_zones;
      not_yet_implemented := not_yet_implemented_msg;
      zone_result := None

  let add_result ~before ki zone = match !zone_result with
    | None -> (* top zone *) ()
    | Some other_zones ->
      let zone_true, zone_false =
        try Stmt.Hashtbl.find other_zones ki
        with Not_found -> Locations.Zone.bottom, Locations.Zone.bottom
      in
      Stmt.Hashtbl.replace other_zones
        ki
        (if before then Locations.Zone.join zone_true zone, zone_false
         else zone_true, Locations.Zone.join zone_false zone)

  let get_result_aux () =
    let result =
      let zones = match !zone_result with
        | None ->
          (* clear references for the next time when giving the result.
             Note that other_zones has been cleared in [add_top_zone]. *)
          zone_result := Some other_zones;
          None
        | Some other_zones ->
          let z =
            Stmt.Hashtbl.fold
              (fun ki (zone_true, zone_false) other_zones ->
                let add before zone others =
                  if Locations.Zone.equal Locations.Zone.bottom zone then
                    others
                  else
                    { before = before; ki = ki; zone = zone} :: others
                in
                add true zone_true (add false zone_false other_zones))
              other_zones
              []
          in
          (* clear table for the next time when giving the result *)
          Stmt.Hashtbl.clear other_zones;
          Some z
      in zones, {var = !locals; lbl = !labels}
    in
      let res_pragmas = !pragmas in
      (* clear references for the next time when giving the result *)
      (* TODO: this is hideous and error-prone as some functions are
         recursive. See VP comment about a more functional setting *)
      locals := Varinfo.Set.empty ;
      labels := Logic_label.Set.empty ;
      pragmas := empty_pragmas;
      result, res_pragmas

  let get_result () = fst (get_result_aux ())

  let get_annot_result () =
    get_result_aux ()

  (** Logic_var utility: *)
  let extract_locals logicvars =
    Logic_var.Set.fold
      (fun lv cvars -> match lv.lv_origin with
      | None -> cvars
      | Some cvar ->
        if cvar.Cil_types.vglob then cvars
        else Varinfo.Set.add cvar cvars)
      logicvars
      Varinfo.Set.empty

  (** Term utility:
      Extract C local variables occurring into a [term]. *)
  let extract_locals_from_term term =
    extract_locals (extract_free_logicvars_from_term term)

  (** Predicate utility:
      Extract C local variables occurring into a [term]. *)
  let extract_locals_from_pred pred =
    extract_locals (extract_free_logicvars_from_predicate pred)

  type abs_label = | AbsLabel_here
                   | AbsLabel_pre
                   | AbsLabel_post
                   | AbsLabel_init
                   | AbsLabel_loop_entry
                   | AbsLabel_loop_current
                   | AbsLabel_stmt of stmt

  let is_same_label absl l =
    match absl, l with
      | AbsLabel_stmt s1, StmtLabel s2 -> Cil_datatype.Stmt.equal s1 !s2
      | AbsLabel_here, BuiltinLabel Here -> true
      | AbsLabel_pre, BuiltinLabel Pre -> true
      | AbsLabel_post, BuiltinLabel Post -> true
      | AbsLabel_init, BuiltinLabel Init -> true
      | AbsLabel_loop_entry, BuiltinLabel LoopEntry -> true
      | AbsLabel_loop_current, BuiltinLabel LoopCurrent -> true
      | _, (StmtLabel _ | FormalLabel _ | BuiltinLabel _) -> false


  class populate_zone before_opt ki_opt kf =
    (* interpretation from the
       - pre-state if  [before_opt=Some true]
       - post-state if [before_opt=Some false]
       - pre-state with possible reference to the post-state if
       [before_opt=None] of a property relative to
       - the contract of function [kf] when [ki_opt=None]
       otherwise [ki_opt=Some(ki, code_annot)],
       - the contract of the statement [ki] when [code_annot=false]
       - the annotation of the statement [ki] when [code_annot=true] *)
    object(self)
      inherit Visitor.frama_c_inplace
      val mutable current_label = AbsLabel_here

      method private get_ctrl_point () =
        let get_fct_entry_point () =
          (* TODO: to replace by true, None *)
          true, 
	  (try Some (Kernel_function.find_first_stmt kf)
           with Kernel_function.No_Statement -> 
	     (* raised when [kf] has no code. *)
	     None)  
        in
        let get_ctrl_point dft =
          let before = Extlib.opt_conv dft before_opt in
          match ki_opt with
          | None -> (* function contract *)

              if before then get_fct_entry_point ()
              else before, None
                (* statement contract *)
          | Some (ki,_) ->  (* statement contract and code annotation *)
              before, Some ki
        in
        let result = match current_label with
          | AbsLabel_stmt stmt -> true, Some stmt
          | AbsLabel_pre -> get_fct_entry_point ()
          | AbsLabel_here -> get_ctrl_point true
          | AbsLabel_post -> get_ctrl_point false
          | AbsLabel_init -> raise (NYI "[logic_interp] Init label")
          | AbsLabel_loop_current ->
            raise (NYI "[logic_interp] LoopCurrent label")
          | AbsLabel_loop_entry ->
            raise (NYI "[logic_interp] LoopEntry label")
        in (* TODO: the method should be able to return result directly *)
        match result with
        | current_before, Some current_stmt -> current_before, current_stmt
        | _ -> raise (NYI
                        "[logic_interp] clause related to a function contract")

      method private change_label: 'a.abs_label -> 'a -> 'a visitAction =
        fun label x ->
          let old_label = current_label in
          current_label <- label;
          ChangeDoChildrenPost
            (x,fun x -> current_label <- old_label; x)

      method private change_label_to_here: 'a.'a -> 'a visitAction =
        fun x ->
          self#change_label AbsLabel_here x

      method private change_label_to_old: 'a.'a -> 'a visitAction =
        fun x ->
          match ki_opt,before_opt with
            (* function contract *)
          | None,Some true -> 
	    failwith "The use of the label Old is forbidden inside clauses \
        related to the pre-state of function contracts." 
          | None,None
          | None,Some false -> 
	    (* refers to the pre-state of the contract. *)
	    self#change_label AbsLabel_pre x 
          (* statement contract *)
          | Some (_ki,false),Some true  -> 
	    failwith "The use of the label Old is forbidden inside clauses \
related to the pre-state of statement contracts."
          | Some (ki,false),None
          | Some (ki,false),Some false  -> 
	    (* refers to the pre-state of the contract. *)
	    self#change_label (AbsLabel_stmt ki) x 
          (* code annotation *)
          | Some (_ki,true),None
          | Some (_ki,true),Some _ -> 
	    (* refers to the pre-state of the function contract. *)
	    self#change_label AbsLabel_pre x 

      method private change_label_to_post: 'a.'a -> 'a visitAction =
        fun x -> 
	  (* allowed when [before_opt=None] for function/statement contracts *)
          match ki_opt,before_opt with
            (* function contract *)
          | None,Some _ -> 
	    failwith "Function contract where the use of the label Post is \
 forbidden."
          | None,None -> 
	    (* refers to the post-state of the contract. *)
	    self#change_label AbsLabel_post x 
          (* statement contract *)
          | Some (_ki,false),Some _  -> 
	    failwith "Statement contract where the use of the label Post is \
forbidden."
          | Some (_ki,false),None -> 
	    (* refers to the pre-state of the contract. *)
	    self#change_label AbsLabel_post x 
          (* code annotation *)
          | Some (_ki,true), _ -> 
	    failwith "The use of the label Post is forbidden inside code \
annotations."

      method private change_label_to_pre: 'a.'a -> 'a visitAction =
        fun x ->
          match ki_opt with
            (* function contract *)
          | None -> 
	    failwith "The use of the label Pre is forbidden inside function \
contracts."
          (* statement contract *)
          (* code annotation *)
          | Some _ -> 
	    (* refers to the pre-state of the function contract. *)
	    self#change_label AbsLabel_pre x 

      method private change_label_aux: 'a. _ -> 'a -> 'a visitAction =
        fun lbl x -> self#change_label lbl x

      method private change_label_to_stmt: 'a.stmt -> 'a -> 'a visitAction =
        fun stmt x ->
          match ki_opt with
            (* function contract *)
          | None -> 
	    failwith "the use of C labels is forbidden inside clauses related \
to function contracts."
          (* statement contract *)
          (* code annotation *)
          | Some _ -> 
	    (* refers to the state at the C label of the statement [stmt]. *)
	    self#change_label (AbsLabel_stmt stmt) x


      method! vpredicate_node p =
      let fail () =
        raise (NYI (Pretty_utils.sfprintf
                      "[logic_interp] %a" Printer.pp_predicate_node p))
      in
      match p with
      | Pat (_, BuiltinLabel Old) -> self#change_label_to_old p
      | Pat (_, BuiltinLabel Here) -> self#change_label_to_here p
      | Pat (_, BuiltinLabel Pre) -> self#change_label_to_pre p
      | Pat (_, BuiltinLabel Post) -> self#change_label_to_post p
      | Pat (_, BuiltinLabel Init) ->
        self#change_label_aux AbsLabel_init p
      | Pat (_, BuiltinLabel LoopCurrent) ->
        self#change_label_aux AbsLabel_loop_current p
      | Pat (_, BuiltinLabel LoopEntry) ->
        self#change_label_aux AbsLabel_loop_entry p
      | Pat (_, FormalLabel s) ->
        failwith ("unknown logic label" ^ s)
      | Pat (_, StmtLabel st) -> self#change_label_to_stmt !st p
      | Pfalse | Ptrue | Prel _ | Pand _ | Por _ | Pxor _ | Pimplies _
      | Piff _ | Pnot _ | Pif _ | Plet _ | Pforall _ | Pexists _
      | Papp (_, [], _) (* No label, thus cannot access memory *)
      | Pseparated _ (* need only to preserve the values of each pointer *)
        -> DoChildren

      | Pinitialized (lbl, t) | Pdangling (lbl, t) ->
          (* Dependencies of [\initialized(p)] or [\dangling(p)] are the
             dependencies of [*p]. *)
          if is_same_label current_label lbl then (
            let typ = Logic_typing.type_of_pointed t.term_type in
            let tlv = Cil.mkTermMem t TNoOffset in
            let tlv' = Logic_const.term (TLval tlv) typ in
            self#do_term_lval tlv';
            DoChildren
          )
          else fail ()

      | Pvalid_read (_lbl, _) | Pvalid (_lbl, _) ->
          (* Does not take dynamic allocation into account, but then
             Value does not either. [lbl] can be ignored because they are
             taken into account by the functions [from_...] below *)
          DoChildren

      | Pobject_pointer _ | Pvalid_function _ ->
          DoChildren

      | Papp _ | Pallocable _ | Pfreeable _ | Pfresh _
        -> fail ()

      method private do_term_lval t =
        let current_before, current_stmt = self#get_ctrl_point () in
        let state = Db.Value.get_stmt_state current_stmt in
        try
          let deps = !Db.From.find_deps_term_no_transitivity_state state t in
          (* TODO: what we should we do with other program points? *)
          let z = Logic_label.Map.find (BuiltinLabel Here) deps in
          let z =
            Locations.Zone.filter_base
              (function Base.CLogic_Var _ -> false | _ -> true)
              z
          in
          add_result current_before current_stmt z
        with Db.From.Not_lval ->
          raise (NYI "[logic_interp] dependencies of a term lval")

      method! vterm t =
        match t.term_node with
          | TAddrOf _ | TLval (TMem _,_)
          | TLval(TVar {lv_origin = Some _},_) | TStartOf _  ->
              self#do_term_lval t;
              SkipChildren
          | Tat (_, BuiltinLabel Old) -> self#change_label_to_old t
          | Tat (_, BuiltinLabel Here) -> self#change_label_to_here t
          | Tat (_, BuiltinLabel Pre) -> self#change_label_to_pre t
          | Tat (_, BuiltinLabel Post) -> self#change_label_to_post t
          | Tat (_, BuiltinLabel Init) ->
            self#change_label_aux AbsLabel_init t
          | Tat (_, BuiltinLabel LoopCurrent) ->
            self#change_label_aux AbsLabel_loop_current t
          | Tat (_, BuiltinLabel LoopEntry) ->
            self#change_label_aux AbsLabel_loop_entry t
          | Tat (_, StmtLabel st) -> self#change_label_to_stmt !st t
          | Tat (_, FormalLabel s) ->
            failwith ("unknown logic label" ^ s)
          | TSizeOf _ | TSizeOfE _ | TSizeOfStr _ | TAlignOf _ | TAlignOfE _ ->
            (* These are static constructors, there are no dependencies here *)
            SkipChildren
          | _ -> DoChildren
    end

    (** Entry point to get the list of [ki] * [Locations.Zone.t]
        needed to evaluate the [term]
        relative to the [ctx] of interpretation. *)
    let from_term term ctx =
      (* [VP 2011-01-28] TODO: factorize from_terms and from_term, and use
	 a more functional setting. *)
      (try
         ignore(Visitor.visitFramacTerm
		  (new populate_zone ctx.state_opt ctx.ki_opt ctx.kf) term)
       with NYI msg -> 
	 add_top_zone msg) ;
      locals := Varinfo.Set.union (extract_locals_from_term term) !locals;
      labels := Logic_label.Set.union (extract_labels_from_term term) !labels;
      get_result ()

    (** Entry point to get the list of [ki] * [Locations.Zone.t]
        needed to evaluate the list of [terms]
        relative to the [ctx] of interpretation. *)
    let from_terms terms ctx =
      let f x =
        (try
           ignore(Visitor.visitFramacTerm
		    (new populate_zone ctx.state_opt ctx.ki_opt ctx.kf) x)
         with NYI msg -> 
	   add_top_zone msg) ;
        locals := Varinfo.Set.union (extract_locals_from_term x) !locals;
	labels := Logic_label.Set.union (extract_labels_from_term x) !labels
      in
        List.iter f terms;
        get_result ()

    (** Entry point to get the list of [ki] * [Locations.Zone.t]
        needed to evaluate the [pred]
        relative to the [ctx] of interpretation. *)
    let from_pred pred ctx =
        (try
           ignore(Visitor.visitFramacPredicate
                    (new populate_zone ctx.state_opt ctx.ki_opt ctx.kf) pred)
         with NYI msg -> 
	   add_top_zone msg) ;
      locals := Varinfo.Set.union (extract_locals_from_pred pred) !locals;
      labels := Logic_label.Set.union (extract_labels_from_pred pred) !labels;
      get_result ()

    (** Entry point to get the list of [ki] * [Locations.Zone.t]
        needed to evaluate the list of [preds]
        relative to the [ctx] of interpretation. *)
    let from_preds preds ctx =
      let f pred =
        (try
           ignore(Visitor.visitFramacPredicate
                    (new populate_zone ctx.state_opt ctx.ki_opt ctx.kf) pred)
         with NYI msg -> 
	   add_top_zone msg) ;
        locals := Varinfo.Set.union (extract_locals_from_pred pred) !locals;
	labels := Logic_label.Set.union (extract_labels_from_pred pred) !labels
      in
        List.iter f preds;
        get_result ()

   (** Used by annotations entry points. *)
    let get_zone_from_annot a (ki,kf) loop_body_opt =
      let get_zone_from_term k x =
        (try
           ignore
             (Visitor.visitFramacTerm
                (new populate_zone (Some true) (Some (k, true)) kf) x)
         with NYI msg -> 
	   add_top_zone msg) ;
        (* to select the declaration of the variables *)
        locals := Varinfo.Set.union (extract_locals_from_term x) !locals;
        (* to select the labels of the annotation *)
	labels := Logic_label.Set.union (extract_labels_from_term x) !labels
      and get_zone_from_pred k x =
        (try
           ignore
             (Visitor.visitFramacPredicate
                (new populate_zone (Some true) (Some (k,true)) kf) x)
         with NYI msg -> 
	   add_top_zone msg) ;
        (* to select the declaration of the variables *)
        locals := Varinfo.Set.union (extract_locals_from_pred x) !locals;
        (* to select the labels of the annotation *)
	labels := Logic_label.Set.union (extract_labels_from_pred x) !labels
      in
      match a.annot_content with
      | APragma (Slice_pragma (SPexpr term) | Impact_pragma (IPexpr term)) ->
        (* to preserve the interpretation of the pragma *)
        get_zone_from_term ki term;
        (* to select the reachability of the pragma *)
        pragmas :=
          { !pragmas with ctrl = Stmt.Set.add ki !pragmas.ctrl }
      | APragma (Slice_pragma SPctrl) ->
        (* to select the reachability of the pragma *)
        pragmas :=
          { !pragmas with ctrl = Stmt.Set.add ki !pragmas.ctrl }
      | APragma (Slice_pragma SPstmt | Impact_pragma IPstmt) ->
        (* to preserve the effect of the statement *)
        pragmas :=
          { !pragmas with stmt = Stmt.Set.add ki !pragmas.stmt}
      | AAssert (_behav,pred) ->
        (* to preserve the interpretation of the assertion *)
        get_zone_from_pred ki pred.tp_statement;
      | AInvariant (_behav,true,pred) -> (* loop invariant *)
        (* WARNING this is obsolete *)
        (* [JS 2010/09/02] TODO: so what is the right way to do? *)
        (* to preserve the interpretation of the loop invariant *)
        get_zone_from_pred (Extlib.the loop_body_opt) pred.tp_statement;
      | AInvariant (_behav,false,pred) -> (* code invariant *)
        (* to preserve the interpretation of the code invariant *)
        get_zone_from_pred ki pred.tp_statement;
      | AVariant (term,_) ->
        (* to preserve the interpretation of the variant *)
        get_zone_from_term (Extlib.the loop_body_opt) term;
      | APragma (Loop_pragma (Unroll_specs terms))
      | APragma (Loop_pragma (Widen_hints terms))
      | APragma (Loop_pragma (Widen_variables terms)) ->
        (* to select the declaration of the variables *)
        List.iter
          (fun term ->
             locals := Varinfo.Set.union (extract_locals_from_term term) !locals;
 	     labels := Logic_label.Set.union (extract_labels_from_term term) !labels)
         terms
      | AAllocation (_,FreeAllocAny) -> ();
      | AAllocation (_,FreeAlloc(f,a)) -> 
        let get_zone x =
          get_zone_from_term (Extlib.the loop_body_opt) x.it_content
        in
          List.iter get_zone f ;
          List.iter get_zone a 
      | AAssigns (_, WritesAny) -> ()
      | AAssigns (_, Writes l) -> (* loop assigns *)
        let get_zone x =
          get_zone_from_term (Extlib.the loop_body_opt) x.it_content
        in
        List.iter
          (fun (zone,deps) ->
            get_zone zone;
            match deps with
                FromAny -> ()
              | From l -> List.iter get_zone l)
          l
      | AStmtSpec _ -> (* TODO *)
        raise (NYI "[logic_interp] statement contract")
      | AExtended _ -> raise (NYI "[logic_interp] extension")
    (** Used by annotations entry points. *)
    let get_from_stmt_annots code_annot_filter ((ki, _kf) as stmt) =
      Extlib.may
        (fun caf ->
           let loop_body_opt = match ki.skind with
             | Loop(_, { bstmts = body :: _ }, _, _, _) -> Some body
             | _ -> None
           in
           Annotations.iter_code_annot
             (fun _ a ->
                if caf a then get_zone_from_annot a stmt loop_body_opt)
             ki)
        code_annot_filter

    (** Used by annotations entry points. *)
    let from_ki_annot annot ((ki, _kf) as stmt) =
      let real_ki = match ki.skind with
          Loop(_,{bstmts = loop_entry::_},_,_,_) -> Some loop_entry
        | _ -> None
      in
      get_zone_from_annot annot stmt real_ki

    (** Entry point to get the list of [ki] * [Locations.Zone.t]
        needed to evaluate the code annotations related to this [stmt]. *)
    let from_stmt_annot annot stmt =
      from_ki_annot annot stmt;
      get_annot_result ()

    (** Entry point to get the list of [ki] * [Locations.Zone.t]
        needed to evaluate the code annotations related to this [stmt]. *)
    let from_stmt_annots code_annot_filter stmt =
      get_from_stmt_annots code_annot_filter stmt ;
      get_annot_result ()

    (** Entry point to get the list of [ki] * [Locations.Zone.t]
        needed to evaluate the code annotations related to this [kf]. *)
    let from_func_annots iter_on_kf_stmt code_annot_filter kf =
      let from_stmt_annots ki =
        get_from_stmt_annots code_annot_filter (ki, kf)
      in iter_on_kf_stmt from_stmt_annots kf;
        get_annot_result ()

    (** To quickly build a annotation filter *)
    let code_annot_filter annot ~threat ~user_assert ~slicing_pragma ~loop_inv ~loop_var ~others =
      match annot.annot_content with
        | APragma (Slice_pragma _) -> slicing_pragma
        | AAssert _ ->
            (match Alarms.find annot with
               | None -> user_assert 
               | Some _a -> threat)
        | AVariant _ -> loop_var
        | AInvariant(_behav,true,_pred) -> loop_inv
        | AInvariant(_,false,_) -> others
        | AAllocation _ -> others
        | AAssigns _ -> others
        | APragma (Loop_pragma _)| APragma (Impact_pragma _) -> others
        | AStmtSpec _  | AExtended _ (* TODO *) -> false
  end

exception Prune

let to_result_from_pred p =
  let visitor = object (_self)
    inherit Visitor.frama_c_inplace

      method! vterm_lhost t =
        match t with
          | TResult _ -> raise Prune
          | _ -> DoChildren

  end
  in
  (try
     ignore(Visitor.visitFramacPredicate visitor p);
     false
   with Prune -> 
     true)


let () =
  Db.Properties.Interp.code_annot := code_annot;
  Db.Properties.Interp.term_lval := term_lval;
  Db.Properties.Interp.term := term;
  Db.Properties.Interp.predicate := predicate;

  Db.Properties.Interp.term_lval_to_lval := term_lval_to_lval;
  Db.Properties.Interp.term_to_exp := term_to_exp;

  Db.Properties.Interp.term_to_lval := term_to_lval;
  Db.Properties.Interp.term_offset_to_offset := term_offset_to_offset;

  Db.Properties.Interp.loc_to_lval := loc_to_lval;
  Db.Properties.Interp.loc_to_offset := loc_to_offset;
  Db.Properties.Interp.loc_to_exp := loc_to_exp;

  Db.Properties.Interp.To_zone.code_annot_filter := To_zone.code_annot_filter;
  Db.Properties.Interp.To_zone.mk_ctx_func_contrat := 
    To_zone.mk_ctx_func_contrat;
  Db.Properties.Interp.To_zone.mk_ctx_stmt_contrat := 
    To_zone.mk_ctx_stmt_contrat;
  Db.Properties.Interp.To_zone.mk_ctx_stmt_annot := To_zone.mk_ctx_stmt_annot;

  Db.Properties.Interp.To_zone.from_term := To_zone.from_term;
  Db.Properties.Interp.To_zone.from_terms := To_zone.from_terms;
  Db.Properties.Interp.To_zone.from_pred := To_zone.from_pred;
  Db.Properties.Interp.To_zone.from_preds := To_zone.from_preds;
  Db.Properties.Interp.To_zone.from_stmt_annot := To_zone.from_stmt_annot;
  Db.Properties.Interp.To_zone.from_stmt_annots := To_zone.from_stmt_annots;
  Db.Properties.Interp.To_zone.from_func_annots := To_zone.from_func_annots;

  Db.Properties.Interp.to_result_from_pred := to_result_from_pred;

(*
Local Variables:
compile-command: "make -C ../../.."
End:
*)
