(**************************************************************************)
(*                                                                        *)
(*  This file is part of the Frama-C's E-ACSL plug-in.                    *)
(*                                                                        *)
(*  Copyright (C) 2012-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).            *)
(*                                                                        *)
(**************************************************************************)

module E_acsl_label = Label (* [Label] is hidden when opening [Cil_datatype *)
open Cil_types
open Cil_datatype

let dkey = Options.dkey_translation

(* ************************************************************************** *)
(* Expressions *)
(* ************************************************************************** *)

let replace_literal_string_in_exp env kf_opt (* None for globals *) e =
  (* do not touch global initializers because they accept only constants;
     replace literal strings elsewhere *)
  match kf_opt with
  | None -> e, env
  | Some kf -> Literal_observer.subst_all_literals_in_exp env kf e

let rec inject_in_init env kf_opt vi off = function
  | SingleInit e as init ->
    if vi.vglob then Global_observer.add_initializer vi off init;
    let e, env = replace_literal_string_in_exp env kf_opt e in
    SingleInit e, env
  | CompoundInit(typ, l) ->
    (* inject in all single initializers that can be built from the compound
       version *)
    let l, env =
      List.fold_left
        (fun (l, env) (off', i) ->
           let new_off = Cil.addOffset off' off in
           let i, env = inject_in_init env kf_opt vi new_off i in
           (off', i) :: l, env)
        ([], env)
        l
    in
    CompoundInit(typ, List.rev l), env

let inject_in_local_init loc env kf vi = function
  | ConsInit (fvi, sz :: _, _) as init
    when Functions.Libc.is_vla_alloc_name fvi.vname ->
    (* add a store statement when creating a variable length array *)
    let store = Smart_stmt.store_stmt ~str_size:sz vi in
    let env = Env.add_stmt ~post:true env kf store in
    init, env

  | ConsInit (fvi, args, kind)
    when Options.Validate_format_strings.get ()
      && Functions.Libc.is_printf_name fvi.vname
    ->
    (* rewrite libc function names (e.g., [printf]). *)
    let name = Functions.RTL.libc_replacement_name fvi.vname in
    let new_vi = try Builtins.find name with Not_found -> assert false in
    let fmt = Functions.Libc.get_printf_argument_str ~loc fvi.vname args in
    ConsInit(new_vi, fmt :: args, kind), env

  | ConsInit (fvi, _, _) as init
    when Options.Replace_libc_functions.get ()
      && Functions.RTL.has_rtl_replacement fvi.vname
    ->
    (* rewrite names of functions for which we have alternative definitions in
       the RTL. *)
    fvi.vname <- Functions.RTL.libc_replacement_name fvi.vname;
    init, env

  | AssignInit init ->
    let init, env = inject_in_init env (Some kf) vi NoOffset init in
    AssignInit init, env

  | ConsInit(vi, l, ck) ->
    let l, env =
      List.fold_right
        (fun e (l, env) ->
           let e, env = replace_literal_string_in_exp env (Some kf) e in
           e :: l, env)
        l
        ([], env)
    in
    ConsInit(vi, l, ck), env

(* ************************************************************************** *)
(* Instructions and statements *)
(* ************************************************************************** *)

(* rewrite names of functions for which we have alternative definitions in the
   RTL. *)
let rename_caller loc args exp = match exp.enode with
  | Lval(Var vi, _)
    when Options.Replace_libc_functions.get ()
      && Functions.RTL.has_rtl_replacement vi.vname
    ->
    vi.vname <- Functions.RTL.libc_replacement_name vi.vname;
    exp, args

  | Lval(Var vi, _)
    when Options.Validate_format_strings.get ()
      && Functions.Libc.is_printf_name vi.vname
    ->
    (* rewrite names of format functions (such as printf). This case differs
       from the above because argument list of format functions is extended with
       an argument describing actual variadic arguments *)
    (* replacement name, e.g., [printf] -> [__e_acsl_builtin_printf] *)
    let name = Functions.RTL.libc_replacement_name vi.vname in
    (* variadic arguments descriptor *)
    let fmt = Functions.Libc.get_printf_argument_str ~loc vi.vname args in
    (* get the library function we need. Cannot just rewrite the name as AST
       check will then fail *)
    let vi = try Rtl.Symbols.find_vi name with Not_found -> assert false in
    Cil.evar vi, fmt :: args

  | _ ->
    exp, args

(* TODO: should be better documented *)
let add_initializer loc ?vi lv ?(post=false) stmt env kf =
  if Functions.instrument kf then
    let may_safely_ignore = function
      | Var vi, NoOffset -> vi.vglob || vi.vformal
      | _ -> false
    in
    let must_model = Memory_tracking.must_monitor_lval ~stmt ~kf lv in
    if not (may_safely_ignore lv) && must_model then
      let before = Cil.mkStmt ~valid_sid:true stmt.skind in
      let new_stmt =
        (* bitfields are not yet supported ==> no initializer.
           a [not_yet] will be raised in [Translate]. *)
        if Cil.isBitfield lv then Cil.mkEmptyStmt ()
        else Smart_stmt.initialize ~loc lv
      in
      let env = Env.add_stmt ~post ~before env kf new_stmt in
      let env = match vi with
        | None -> env
        | Some vi ->
          let new_stmt = Smart_stmt.store_stmt vi in
          Env.add_stmt ~post ~before env kf new_stmt
      in
      env
    else
      env
  else
    env

let inject_in_instr env kf stmt = function
  | Set(lv, e, loc) ->
    let e, env = replace_literal_string_in_exp env (Some kf) e in
    let env = add_initializer loc lv stmt env kf in
    Set(lv, e, loc), env

  | Call(result, caller, args, loc) ->
    let args, env =
      List.fold_right
        (fun a (args, env) ->
           let a, env = replace_literal_string_in_exp env (Some kf) a in
           a :: args, env)
        args
        ([], env)
    in
    let caller, args = rename_caller loc args caller in
    (* add statement tracking initialization of return values *)
    let env =
      match result with
      | Some lv when not (Functions.RTL.is_generated_kf kf) ->
        add_initializer loc lv ~post:false stmt env kf
      | _ ->
        env
    in
    (* if this is a call to free a vla, add a call to delete_block *)
    let env =
      if Functions.Libc.is_vla_free caller then
        match args with
        | [ { enode = CastE (_, { enode = Lval (Var vi, NoOffset) }) } ] ->
          let delete_block = Smart_stmt.delete_stmt ~is_addr:true vi in
          Env.add_stmt env kf delete_block
        | _ -> Options.fatal "The normalization of __fc_vla_free() has changed"
      else
        env
    in
    Call(result, caller, args, loc), env

  | Local_init(vi, linit, loc) ->
    let lv = Var vi, NoOffset in
    let env = add_initializer loc ~vi lv ~post:true stmt env kf in
    let linit, env = inject_in_local_init loc env kf vi linit in
    Local_init(vi, linit, loc), env

  (* nothing to do: *)
  | Asm _
  | Skip _
  | Code_annot _ as instr ->
    instr, env

let add_new_block_in_stmt env kf stmt =
  (* Add temporal analysis instrumentations *)
  let env = Temporal.handle_stmt stmt env kf in
  let new_stmt, env =
    if Functions.check kf then
      let env =
        (* handle ghost statement *)
        if stmt.ghost then begin
          stmt.ghost <- false;
          (* translate potential RTEs of ghost code *)
          let rtes = Rte.stmt ~warn:false kf stmt in
          Translate.translate_rte_annots Printer.pp_stmt stmt kf env rtes
        end else
          env
      in
      (* handle loop invariants *)
      let new_stmt, env = Loops.preserve_invariant env kf stmt in
      new_stmt, env
    else
      stmt, env
  in
  let mk_post_env env stmt =
    Annotations.fold_code_annot
      (fun _ a env -> Translate_annots.post_code_annotation kf stmt env a)
      stmt
      env
  in
  let new_stmt, env =
    (* Remove local variables which scopes ended via goto/break/continue. *)
    let del_vars = Exit_points.delete_vars stmt in
    let env = Memory_observer.delete_from_set ~before:stmt env kf del_vars in
    if Kernel_function.is_return_stmt kf stmt then
      let env =
        if Functions.check kf then
          (* must generate the post_block before including [stmt] (the
             'return') since no code is executed after it. However, since
             this statement is pure (Cil invariant), that is semantically
             correct. *)
          (* [JS 2019/2/19] TODO: what about the other ways of early exiting
             a block? *)
          let env = mk_post_env env stmt in
          (* also handle the postcondition of the function and clear the
             env *)
          Translate_annots.post_funspec kf Kglobal env
        else
          env
      in
      (* de-allocating memory previously allocating by the kf *)
      (* remove recorded function arguments *)
      let fargs = Kernel_function.get_formals kf in
      let env = Memory_observer.delete_from_list env kf fargs in
      let b, env =
        Env.pop_and_get env new_stmt ~global_clear:true Env.After
      in
      let new_stmt = Smart_stmt.block stmt b in
      if not (Cil_datatype.Stmt.equal stmt new_stmt) then begin
        (* move the labels of the return to the new block in order to
           evaluate the postcondition when jumping to them. *)
        E_acsl_label.move kf stmt new_stmt
      end;
      new_stmt, env
    else (* i.e. not (is_return stmt) *)
      (* must generate [pre_block] which includes [stmt] before generating
         [post_block] *)
      let pre_block, env =
        Env.pop_and_get
          ~split:true
          env
          new_stmt
          ~global_clear:false
          Env.After
      in
      let env =
        (* if [kf] is not monitored, do not translate any postcondition,
           but still push an empty environment consumed by
           [Env.pop_and_get] below. This [Env.pop_and_get] call is always
           required in order to generate the code not directly related to
           the annotations of the current stmt in anycase. *)
        if Functions.check kf then mk_post_env (Env.push env) stmt
        else Env.push env
      in
      let post_block, env =
        Env.pop_and_get
          env
          (Smart_stmt.block new_stmt pre_block)
          ~global_clear:false
          Env.Before
      in
      let post_block =
        if post_block.blocals = [] && new_stmt.labels = []
        then Cil.transient_block post_block
        else post_block
      in
      let res = Smart_stmt.block new_stmt post_block in
      if not (Cil_datatype.Stmt.equal new_stmt res) then
        E_acsl_label.move kf new_stmt res;
      res, env
  in
  Options.debug ~level:4
    "@[new stmt (from sid %d):@ %a@]" stmt.sid Printer.pp_stmt new_stmt;
  new_stmt, env

(** In the block [outer_block] in the function [kf], this function finds the
    innermost last statement and insert the list of statements returned by
    [last_stmts].
    The function [last_stmts] receives an optional argument [?return_stmt] with
    the innermost return statement if it exists. In that case the function needs
    to return this statement as the last statement. *)
let insert_as_last_stmts_in_innermost_block ~last_stmts kf outer_block =
  (* Retrieve the last innermost block *)
  let rec retrieve_innermost_last_return block =
    let l = List.rev block.bstmts in
    match l with
    | [] -> block, [], None
    | { skind = Return _ } as ret :: rest -> block, rest, Some ret
    | { skind = Block b } :: _ -> retrieve_innermost_last_return b
    | _ :: _ -> block, l, None
  in
  let inner_block, rev_content, return_stmt =
    retrieve_innermost_last_return outer_block
  in
  (* Create the statements to insert *)
  let new_stmts = last_stmts ?return_stmt () in
  (* Move the labels from the return stmt to the stmts to insert *)
  let new_stmts =
    match return_stmt with
    | Some return_stmt ->
      let b = Cil.mkBlock new_stmts in
      let new_stmt = Smart_stmt.block return_stmt b in
      E_acsl_label.move kf return_stmt new_stmt;
      [ new_stmt ]
    | None -> new_stmts
  in
  (* Insert the statements as the last statements of the innermost block *)
  inner_block.bstmts <- List.rev_append rev_content new_stmts

(* visit the substmts and build the new skind *)
let rec inject_in_substmt env kf stmt = match stmt.skind with
  | Instr instr ->
    let instr, env = inject_in_instr env kf stmt instr in
    Instr instr, env

  | Return(Some e, loc)  ->
    let e, env = replace_literal_string_in_exp env (Some kf) e in
    Return(Some e, loc), env

  | If(e, blk1, blk2, loc) ->
    let env = inject_in_block env kf blk1 in
    let env = inject_in_block env kf blk2 in
    let e, env = replace_literal_string_in_exp env (Some kf) e in
    If(e, blk1, blk2, loc), env

  | Switch(e, blk, stmts, loc) ->
    (* [blk] and [stmts] are visited at the same time *)
    let env = inject_in_block env kf blk in
    let e, env = replace_literal_string_in_exp env (Some kf) e in
    Switch(e, blk, stmts, loc), env

  | Loop(_ (* ignore AST annotations *), blk, loc, stmt_opt1, stmt_opt2) ->
    let env = inject_in_block env kf blk in
    let do_opt env = function
      | None -> None, env
      | Some stmt ->
        let stmt, env = inject_in_stmt env kf stmt in
        Some stmt, env
    in
    let stmt_opt1, env = do_opt env stmt_opt1 in
    let stmt_opt2, env = do_opt env stmt_opt2 in
    Loop([], blk, loc, stmt_opt1, stmt_opt2), env

  | Block blk as skind ->
    skind, inject_in_block env kf blk

  | UnspecifiedSequence l ->
    let l, env =
      List.fold_left
        (fun (l, env) (stmt, l1, l2, l3, srefs) ->
           let stmt, env = inject_in_stmt env kf stmt in
           (stmt, l1, l2, l3, srefs) :: l, env)
        ([], env)
        l
    in
    UnspecifiedSequence (List.rev l), env

  | Throw(Some(e, ty), loc) ->
    let e, env = replace_literal_string_in_exp env (Some kf) e in
    Throw(Some(e, ty), loc), env

  | TryCatch(blk, l, _loc) as skind ->
    let env = inject_in_block env kf blk in
    let env =
      List.fold_left
        (fun env (cb, blk) ->
           let env = inject_in_catch_binder env kf cb in
           inject_in_block env kf blk)
        env
        l
    in
    skind, env

  | TryFinally(blk1, blk2, _loc) as skind ->
    let env = inject_in_block env kf blk1 in
    let env = inject_in_block env kf blk2 in
    skind, env

  | TryExcept(_blk1, (_instrs, _e), _blk2, _loc) ->
    Error.not_yet "try ... except ..."

  (* nothing to do: *)
  | Throw(None, _)
  | Return(None, _)
  | Goto _ (* do not visit the internal stmt since it has already been handle *)
  | Break _
  | Continue _ as skind ->
    skind, env

and inject_in_stmt env kf stmt =
  Options.debug ~level:4
    "proceeding stmt (sid %d) %a@."
    stmt.sid Stmt.pretty stmt;
  (* pushing a new context *)
  let env = Env.push env in
  let env = match stmt.skind with
    | Loop _ -> Env.push_loop env
    | _ -> env
  in
  (* initial environment *)
  let env =
    if Kernel_function.is_first_stmt kf stmt then
      let env =
        if Kernel_function.is_main kf then
          env
        else
          let env =
            Memory_observer.store env kf (Kernel_function.get_formals kf)
          in
          Temporal.handle_function_parameters kf env
      in
      (* translate the precondition of the function *)
      if Functions.check kf then
        let funspec = Annotations.funspec kf in
        Translate_annots.pre_funspec kf Kglobal env funspec
      else env
    else
      env
  in
  (* translate code annotations *)
  let env =
    if Functions.check kf then
      Annotations.fold_code_annot
        (fun _ a env -> Translate_annots.pre_code_annotation kf stmt env a)
        stmt
        env
    else
      env
  in
  (* add [__e_acsl_store_duplicate] calls for local variables which declarations
     are bypassed by gotos. Note: should be done before visiting instructions
     (which adds initializers), otherwise init calls appear before store
     calls. *)
  let duplicates = Exit_points.store_vars stmt in
  let env = Memory_observer.duplicate_store ~before:stmt env kf duplicates in
  let skind, env = inject_in_substmt env kf stmt in
  stmt.skind <- skind;
  (* building the new block of code *)
  add_new_block_in_stmt env kf stmt

and inject_in_block (env: Env.t) kf blk =
  blk.battrs <- Cil.dropAttribute Cil.frama_c_ghost_else blk.battrs ;
  let stmts, env =
    List.fold_left
      (fun (stmts, env) stmt ->
         let stmt, env = inject_in_stmt env kf stmt in
         stmt :: stmts, env)
      ([], env)
      blk.bstmts
  in
  blk.bstmts <- List.rev stmts;
  (* now inject code that de-allocates the necessary observation variables and
     blocks of the runtime memory that have been previously allocated *)
  (* calls to [free] for de-allocating variables observing \at(_,_) *)
  let free_stmts = At_with_lscope.Free.find_all kf in
  match blk.blocals, free_stmts with
  | [], [] ->
    env
  | [], _ :: _ | _ :: _, [] | _ :: _, _ :: _ ->
    (* [TODO] this piece of code could be improved *)
    (* de-allocate the memory blocks observing locals *)
    let last_stmts ?return_stmt () =
      let stmts =
        match return_stmt with
        | Some return_stmt ->
          (* now that [free] stmts for [kf] have been inserted,
             there is no more need to keep the corresponding entries in the
             table managing them. *)
          At_with_lscope.Free.remove_all kf;
          (* The free statements are passed in the same order than the malloc
             ones. In order to free the variable in the reverse order, the list
             is reversed before appending the return statement. Moreover,
             [List.rev_append] is tail recursive contrary to [List.append] *)
          List.rev_append free_stmts [ return_stmt ]
        | None -> []
      in
      if Functions.instrument kf then
        List.fold_left
          (fun acc vi ->
             if Memory_tracking.must_monitor_vi ~kf vi
             then Smart_stmt.delete_stmt vi :: acc
             else acc)
          stmts
          blk.blocals
      else
        stmts
    in
    (* select the precise location to inject these pieces of code *)
    insert_as_last_stmts_in_innermost_block ~last_stmts kf blk ;
    (* allocate the memory blocks observing locals *)
    if Functions.instrument kf then
      blk.bstmts <-
        List.fold_left
          (fun acc vi ->
             if Memory_tracking.must_monitor_vi vi && not vi.vdefined
             then Smart_stmt.store_stmt vi :: acc
             else acc)
          blk.bstmts
          blk.blocals;
    env

and inject_in_catch_binder env kf = function
  | Catch_exn(_, l) ->
    List.fold_left (fun env (_, blk) -> inject_in_block env kf blk) env l
  | Catch_all ->
    env

(* ************************************************************************** *)
(* Function definition *)
(* ************************************************************************** *)

let add_generated_variables_in_function env fundec =
  let vars = Env.get_generated_variables env in
  let locals, blocks =
    List.fold_left
      (fun (local_vars, block_vars as acc) (v, scope) -> match scope with
         (* TODO: [kf] assumed to be consistent. Should be asserted. *)
         (* TODO: actually, is the kf as constructor parameter useful? *)
         | Env.LFunction _kf -> v :: local_vars, v :: block_vars
         | Env.LLocal_block _kf -> v :: local_vars, block_vars
         | _ -> acc)
      (fundec.slocals, fundec.sbody.blocals)
      vars
  in
  fundec.slocals <- locals;
  fundec.sbody.blocals <- blocks

(* Memory management for \at on purely logic variables: put [malloc] stmts at
   proper locations *)
let add_malloc_and_free_stmts kf fundec =
  let malloc_stmts = At_with_lscope.Malloc.find_all kf in
  let fstmts = malloc_stmts @ fundec.sbody.bstmts in
  fundec.sbody.bstmts <- fstmts;
  (* now that [malloc] stmts for [kf] have been inserted, there is no more need
     to keep the corresponding entries in the table managing them. *)
  At_with_lscope.Malloc.remove_all kf

let inject_in_fundec main fundec =
  let vi = fundec.svar in
  let kf = try Globals.Functions.get vi with Not_found -> assert false in
  (* convert ghost variables *)
  vi.vghost <- false;
  let unghost_local vi =
    Cil.update_var_type vi (Cil.typeRemoveAttributesDeep ["ghost"] vi.vtype);
    vi.vghost <- false
  in
  List.iter unghost_local fundec.slocals;
  let unghost_formal vi =
    unghost_local vi ;
    vi.vattr <- Cil.dropAttribute Cil.frama_c_ghost_formal vi.vattr
  in
  List.iter unghost_formal fundec.sformals;
  (* update environments *)
  (* TODO: do it only for built-ins *)
  Builtins.update vi.vname vi;
  (* track function addresses but the main function that is tracked internally
     via RTL *)
  if not (Kernel_function.is_main kf) then Global_observer.add vi;
  (* exit point computations *)
  if Functions.instrument kf then Exit_points.generate fundec;
  (* recursive visit *)
  Options.feedback ~dkey ~level:2 "entering in function %a."
    Kernel_function.pretty kf;
  let env = inject_in_block Env.empty kf fundec.sbody in
  Exit_points.clear ();
  add_generated_variables_in_function env fundec;
  add_malloc_and_free_stmts kf fundec;
  (* setting main if necessary *)
  let main = if Kernel_function.is_main kf then Some kf else main in
  Options.feedback ~dkey ~level:2 "function %a done."
    Kernel_function.pretty kf;
  env, main

(* ************************************************************************** *)
(* The whole AST *)
(* ************************************************************************** *)

let unghost_vi vi =
  (* do not convert extern ghost variables, because they can't be linked,
     see bts #1392 *)
  if vi.vstorage <> Extern then vi.vghost <- false;
  Cil.update_var_type vi (Cil.typeRemoveAttributesDeep ["ghost"] vi.vtype);
  match Cil.unrollType vi.vtype with
  | TFun(res, Some l, va, attr) ->
    (* unghostify function's parameters *)
    let retype (n, t, a) = n, t, Cil.dropAttribute Cil.frama_c_ghost_formal a in
    Cil.update_var_type vi (TFun(res, Some (List.map retype l), va, attr))
  | _ ->
    ()

let inject_in_global (env, main) = function
  (* library functions and built-ins *)
  | GVarDecl(vi, _) | GVar(vi, _, _)
  | GFunDecl(_, vi, _) | GFun({ svar = vi }, _) when Builtins.mem vi.vname ->
    Builtins.update vi.vname vi;
    env, main

  (* Cil built-ins and other library globals: nothing to do *)
  | GVarDecl(vi, _) | GVar(vi, _, _) | GFun({ svar = vi }, _)
    when Misc.is_fc_or_compiler_builtin vi ->
    env, main
  | g when Rtl.Symbols.mem_global g ->
    env, main
  (* generated function declaration: nothing to do *)
  | GFunDecl(_, vi, _) when Misc.is_fc_stdlib_generated vi ->
    env, main

  (* variable declarations *)
  | GVarDecl(vi, _) | GFunDecl(_, vi, _) ->
    unghost_vi vi;
    Global_observer.add vi;
    env, main

  (* variable definition *)
  | GVar(vi, { init = None }, _) ->
    Global_observer.add vi;
    unghost_vi vi;
    env, main

  | GVar(vi, { init = Some init }, _) ->
    Global_observer.add vi;
    unghost_vi vi;
    let _init, env = inject_in_init env None vi NoOffset init in
    (* ignore the new initializer that handles literal strings since they are
       not substituted in global initializers (see
       [replace_literal_string_in_exp]) *)
    env, main

  (* function definition *)
  | GFun({ svar = vi } as fundec, _) ->
    unghost_vi vi;
    inject_in_fundec main fundec

  (* other globals: nothing to do *)
  | GType _
  | GCompTag _
  | GCompTagDecl _
  | GEnumTag _
  | GEnumTagDecl _
  | GAsm _
  | GPragma _
  | GText _
  | GAnnot _ (* do never read annotation from sources *)
    ->
    env, main

(* Insert [stmt_begin] as the first statement of [fundec] and insert [stmt_end] as
   the last before [return] *)
let surround_function_with kf fundec stmt_begin stmt_end =
  let body = fundec.sbody in
  (* Insert last statement *)
  Extlib.may
    (fun stmt_end ->
       let last_stmts ?return_stmt () =
         match return_stmt with
         | Some return_stmt -> [ stmt_end; return_stmt ]
         | None -> [ stmt_end]
       in
       insert_as_last_stmts_in_innermost_block ~last_stmts kf body)
    stmt_end;
  (* Insert first statement *)
  body.bstmts <- stmt_begin :: body.bstmts

(* TODO: what about using [file.globalinit]? *)
(** Add a call to [__e_acsl_globals_init] and [__e_acsl_globals_delete] if the
    memory model analysis is running.
    These functions track the usage of globals if the program being analyzed. *)
let inject_global_handler file main =
  Options.feedback ~dkey ~level:2 "building global handler.";
  if Memory_tracking.use_monitoring () then
    (* Create [__e_acsl_globals_init] function *)
    let vi_init, fundec_init = Global_observer.mk_init_function () in
    let cil_fct_init = GFun(fundec_init, Location.unknown) in
    (* Create [__e_acsl_globals_delete] function *)
    let vi_clean, fundec_clean = Global_observer.mk_clean_function () in
    let cil_fct_clean = GFun(fundec_clean, Location.unknown) in
    match main with
    | Some main ->
      let mk_fct_call vi =
        let exp = Cil.evar ~loc:Location.unknown vi in
        let stmt =
          Cil.mkStmtOneInstr ~valid_sid:true
            (Call(None, exp, [], Location.unknown))
        in
        vi.vreferenced <- true;
        stmt
      in
      let main_fundec =
        try Kernel_function.get_definition main
        with _ -> assert false (* by construction, the main kf has a fundec *)
      in
      (* Create [__e_acsl_globals_init();] call *)
      let stmt_init = mk_fct_call vi_init in
      (* Create [__e_acsl_globals_delete();] call *)
      let stmt_clean =
        match fundec_clean.sbody.bstmts with
        | [] -> None
        | _ -> Some (mk_fct_call vi_clean)
      in
      (* Surround the content of main with the calls to
         [__e_acsl_globals_init();] and [__e_acsl_globals_delete();] *)
      surround_function_with main main_fundec stmt_init stmt_clean;
      (* Retrieve all globals except main *)
      let main_vi = Globals.Functions.get_vi main in
      let new_globals =
        List.fold_left
          (fun acc g -> match g with
             | GFun({ svar = vi }, _) when Varinfo.equal vi main_vi -> acc
             | _ -> g :: acc)
          []
          file.globals
      in
      (* Add the globals functions and re-add main at the end *)
      let new_globals =
        let rec rev_and_extend acc = function
          | [] -> acc
          | f :: l -> rev_and_extend (f :: acc) l
        in
        (* [main] at the end *)
        let globals_to_add = [ GFun(main_fundec, Location.unknown) ] in
        (* Prepend [__e_acsl_globals_clean] if not empty *)
        let globals_to_add =
          match fundec_clean.sbody.bstmts with
          | [] -> globals_to_add
          | _ -> cil_fct_clean :: globals_to_add
        in
        (* Prepend [__e_acsl_globals_init] *)
        let globals_to_add = cil_fct_init :: globals_to_add in
        (* Add these functions to the globals *)
        rev_and_extend globals_to_add new_globals
      in
      (* add the literal string varinfos as the very first globals *)
      let new_globals =
        Literal_strings.fold
          (fun _ vi l -> GVar(vi, { init = None }, Location.unknown) :: l)
          new_globals
      in
      file.globals <- new_globals
    | None ->
      Kernel.warning "@[no entry point specified:@ \
                      you must call functions `%s', `%s', \
                      `__e_acsl_memory_init' and `__e_acsl_memory_clean' \
                      by yourself.@]"
        Global_observer.function_init_name
        Global_observer.function_clean_name;
      let globals_func =
        match fundec_clean.sbody.bstmts with
        | [] -> [ cil_fct_init ]
        | _ -> [ cil_fct_init; cil_fct_clean ]
      in
      file.globals <- file.globals @ globals_func

(** Add a call to [__e_acsl_memory_init] and [__e_acsl_memory_clean] if the
    memory tracking analysis is running.
    [__e_acsl_memory_init] initializes memory storage and potentially records
    program arguments. Parameters to [__e_acsl_memory_init] are addresses of
    program arguments or NULLs if [main] is declared without arguments.
    [__e_acsl_memory_clean] clean the memory allocated by
    [__e_acsl_memory_init]. *)
let inject_mtracking_handler main =
  (* Only inject memory init and memory clean if the memory model analysis is
     running *)
  if Memory_tracking.use_monitoring () then begin
    let loc = Location.unknown in
    let nulls = [ Cil.zero loc ; Cil.zero loc ] in
    let handle_main main =
      let fundec =
        try Kernel_function.get_definition main
        with _ -> assert false (* by construction, the main kf has a fundec *)
      in
      let args =
        (* record arguments only if the second has a pointer type, so argument
           strings can be recorded. This is sufficient to capture C99 compliant
           arguments and GCC extensions with environ. *)
        match fundec.sformals with
        | [] ->
          (* no arguments to main given *)
          nulls
        | _argc :: argv :: _ when Cil.isPointerType argv.vtype ->
          (* grab addresses of arguments for a call to the main initialization
             function, i.e., [__e_acsl_memory_init] *)
          List.map Cil.mkAddrOfVi fundec.sformals;
        | _ :: _ ->
          (* some non-standard arguments. *)
          nulls
      in
      let ptr_size = Cil.sizeOf loc Cil.voidPtrType in
      let args = args @ [ ptr_size ] in
      let init = Smart_stmt.rtl_call loc "memory_init" args in
      let clean = Smart_stmt.rtl_call loc "memory_clean" [] in
      surround_function_with main fundec init (Some clean)
    in
    Extlib.may handle_main main
  end

let inject_in_file file =
  let _env, main =
    List.fold_left inject_in_global (Env.empty, None) file.globals
  in
  (* post-treatment *)
  (* extend [main] with forward initialization and put it at end *)
  if not (Global_observer.is_empty () && Literal_strings.is_empty ()) then
    inject_global_handler file main;
  file.globals <- Logic_functions.add_generated_functions file.globals;
  inject_mtracking_handler main

let reset_all ast =
  (* by default, do not run E-ACSL on the generated code *)
  Options.Run.off ();
  (* reset all the E-ACSL environments to their original states *)
  Memory_tracking.reset ();
  Logic_functions.reset ();
  Literal_strings.reset ();
  Global_observer.reset ();
  Typing.clear ();
  (* reset some kernel states: *)
  (* reset the CFG that has been heavily modified by the code generation step *)
  Cfg.clearFileCFG ~clear_id:false ast;
  Cfg.computeFileCFG ast;
  (* notify the kernel that new code has been generated (but we have kept the
     old one) *)
  Ast.mark_as_grown ()

let inject () =
  Options.feedback ~level:2
    "injecting annotations as code in project %a"
    Project.pretty (Project.current ());
  Gmp_types.init ();
  let ast = Ast.get () in
  inject_in_file ast;
  reset_all ast;

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