(****************************************************************************)
(*                                                                          *)
(*  Copyright (C) 2001-2003                                                 *)
(*   George C. Necula    <necula@cs.berkeley.edu>                           *)
(*   Scott McPeak        <smcpeak@cs.berkeley.edu>                          *)
(*   Wes Weimer          <weimer@cs.berkeley.edu>                           *)
(*   Ben Liblit          <liblit@cs.berkeley.edu>                           *)
(*  All rights reserved.                                                    *)
(*                                                                          *)
(*  Redistribution and use in source and binary forms, with or without      *)
(*  modification, are permitted provided that the following conditions      *)
(*  are met:                                                                *)
(*                                                                          *)
(*  1. Redistributions of source code must retain the above copyright       *)
(*  notice, this list of conditions and the following disclaimer.           *)
(*                                                                          *)
(*  2. Redistributions in binary form must reproduce the above copyright    *)
(*  notice, this list of conditions and the following disclaimer in the     *)
(*  documentation and/or other materials provided with the distribution.    *)
(*                                                                          *)
(*  3. The names of the contributors may not be used to endorse or          *)
(*  promote products derived from this software without specific prior      *)
(*  written permission.                                                     *)
(*                                                                          *)
(*  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS     *)
(*  "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT       *)
(*  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS       *)
(*  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE          *)
(*  COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,     *)
(*  INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,    *)
(*  BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;        *)
(*  LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER        *)
(*  CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT      *)
(*  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN       *)
(*  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE         *)
(*  POSSIBILITY OF SUCH DAMAGE.                                             *)
(*                                                                          *)
(*  File modified by CEA (Commissariat à l'énergie atomique et aux          *)
(*                        énergies alternatives)                            *)
(*               and INRIA (Institut National de Recherche en Informatique  *)
(*                          et Automatique).                                *)
(****************************************************************************)

(* Modified by TrustInSoft *)

(* Type check and elaborate ABS to CIL *)

(* The references to ISO means ANSI/ISO 9899-1999 *)
module H = Hashtbl
module IH = Datatype.Int.Hashtbl

open Pretty_utils
open Cabs
open Cabshelper
open Cil
let valid_sid = false
(* All statements generated here must have an invalid sid. Use this variable
   for the valid_sid label of Cil.mkStmt*. *)
open Cil_types
open Cil_datatype

(* Maps the start and end positions of a function declaration or definition
   (including its possible contract) to its name. *)
module FuncLocs = struct
  include
    State_builder.List_ref
      (Datatype.Triple
         (Cil_datatype.Position)(Cil_datatype.Position)(Datatype.String)
      )
      (struct
        let name = "FuncLocs"
        let dependencies = [ Kernel.Files.self ]
      end)

  let add_loc ?spec loc1 loc2 funcname =
    let startpos =
      match spec with
      | None -> fst loc1
      | Some (_, spec_loc) -> fst spec_loc
    in
    let endpos = snd loc2 in
    add (startpos, endpos, funcname)
end

let func_locs () = FuncLocs.get ()

(* Attributes which are entirely unsupported by Frama-C and must cause a
   parsing error, since their behavior requires non-standard parsing *)
let unsupported_attributes = ["vector_size"]

let stripUnderscore ?(checkUnsupported=true) s =
  if String.length s = 1 then begin
    if s = "_" then
      Kernel.error ~once:true ~current:true "Invalid attribute name %s" s;
    s
  end else begin
    let res = Extlib.strip_underscore s in
    if res = "" then
      Kernel.error ~once:true ~current:true "Invalid attribute name %s" s;
    if checkUnsupported && List.mem res unsupported_attributes then
      Kernel.error ~current:true "unsupported attribute: %s" s;
    res
  end

let frama_c_keep_block = "FRAMA_C_KEEP_BLOCK"
let () = Cil_printer.register_shallow_attribute frama_c_keep_block

let fc_stdlib = "fc_stdlib"
let fc_stdlib_generated = "fc_stdlib_generated"
let () = Cil_printer.register_shallow_attribute fc_stdlib
let () = Cil_printer.register_shallow_attribute fc_stdlib_generated

let fc_local_static = "fc_local_static"
let () = Cil_printer.register_shallow_attribute fc_local_static

let frama_c_destructor = "__fc_destructor"
let () = Cil_printer.register_shallow_attribute frama_c_destructor

(** A hook into the code that creates temporary local vars.  By default this
    is the identity function, but you can overwrite it if you need to change the
    types of cabs2cil-introduced temp variables. *)
let typeForInsertedVar: (Cil_types.typ -> Cil_types.typ) ref = ref (fun t -> t)

(** Like [typeForInsertedVar], but for casts.
  * Casts in the source code are exempt from this hook. *)
let typeForInsertedCast:
  (Cil_types.exp -> Cil_types.typ -> Cil_types.typ -> Cil_types.typ) ref =
  ref (fun _ _ t -> t)


let cabs_exp loc node = { expr_loc = loc; expr_node = node }

let bigger_length_args l1 l2 =
  match l1, l2 with
  | None, _ | _, None -> false
  | Some l1, Some l2 -> List.length l1 > List.length l2

let abort_context msg =
  let pos = fst (Cil.CurrentLoc.get ()) in
  let append fmt =
    Format.pp_print_newline fmt ();
    Errorloc.pp_context_from_file fmt pos
  in
  Kernel.abort ~current:true ~append msg

module IgnorePureExpHook =
  Hook.Build (struct type t = string * Cil_types.exp end)

let register_ignore_pure_exp_hook f =
  IgnorePureExpHook.extend (fun (x,z) -> f x z)

module ImplicitPrototypeHook =
  Hook.Build (struct type t = varinfo end)

let register_implicit_prototype_hook f = ImplicitPrototypeHook.extend f

module IncompatibleDeclHook =
  Hook.Build(struct type t = varinfo * varinfo * string end)

let register_incompatible_decl_hook f =
  IncompatibleDeclHook.extend (fun (x,y,z) -> f x y z)

module DifferentDeclHook =
  Hook.Build(struct type t = varinfo * varinfo end)

let register_different_decl_hook f =
  DifferentDeclHook.extend (fun (x,y) -> f x y)

module NewGlobalHook = Hook.Build(struct type t = varinfo * bool end)
let register_new_global_hook f = NewGlobalHook.extend (fun (x, y) -> f x y)

module LocalFuncHook = Hook.Build(struct type t = varinfo end)

let register_local_func_hook = LocalFuncHook.extend

module IgnoreSideEffectHook =
  Hook.Build(struct type t = Cabs.expression * Cil_types.exp end)

let register_ignore_side_effect_hook f =
  IgnoreSideEffectHook.extend (fun (y,z) -> f y z)

module ConditionalSideEffectHook =
  Hook.Build(struct type t = Cabs.expression * Cabs.expression end)

module ForLoopHook =
  Hook.Build(struct
    type t =
      Cabs.for_clause * Cabs.expression * Cabs.expression * Cabs.statement
  end)

let register_for_loop_all_hook f =
  ForLoopHook.extend (fun (x,y,z,t) -> f x y z t)

let register_for_loop_init_hook f =
  ForLoopHook.extend (fun (x,_,_,_) -> f x)

let register_for_loop_test_hook f =
  ForLoopHook.extend (fun (_,x,_,_) -> f x)

let register_for_loop_incr_hook f =
  ForLoopHook.extend (fun (_,_,x,_) -> f x)

let register_for_loop_body_hook f =
  ForLoopHook.extend (fun (_,_,_,x) -> f x)

let register_conditional_side_effect_hook f =
  ConditionalSideEffectHook.extend (fun (y,z) -> f y z)

(* These symbols are supposed to be macros. It is not possible to
   take their address or to redeclare them outside of the proper header
   in stdlib. See CERT MSC38-C rule.
*)
let no_suppress_function_macro =
  [ "assert"; "setjmp"; "va_arg"; "va_copy"; "va_end"; "va_start" ]

let no_redefine_macro =
  "errno" :: "math_errhandling" :: no_suppress_function_macro

let is_stdlib_function_macro n = List.mem n no_suppress_function_macro

let is_stdlib_macro n = List.mem n no_redefine_macro

let is_bitwise_bop = function
  | Cabs.BAND | Cabs.BOR | Cabs.XOR -> true
  | _ -> false

let is_relational_bop = function
  | EQ | NE | LT | GT | LE | GE -> true
  | _ -> false

let rec stripParen = function { expr_node = Cabs.PAREN e } -> stripParen e | e -> e

let rec is_dangerous_offset = function
    NoOffset -> false
  | Field (fi, o) ->
    Cil.typeHasAttribute "volatile" (Cil.unrollType fi.ftype) ||
    is_dangerous_offset o
  | Index _ -> true

let rec is_dangerous e = match e.enode with
  | Lval lv | AddrOf lv | StartOf lv -> is_dangerous_lval lv
  | UnOp (_,e,_) | CastE(_,e) -> is_dangerous e
  | BinOp(_,e1,e2,_) -> is_dangerous e1 || is_dangerous e2
  | Const _ | SizeOf _ | SizeOfE _ | SizeOfStr _ | AlignOf _ | AlignOfE _ ->
    false
and is_dangerous_lval = function
  | Var v,_ when
      (not v.vglob && not v.vformal && not v.vtemp)
      || Cil.hasAttribute "volatile" v.vattr
      || Cil.typeHasAttribute "volatile" (Cil.unrollType v.vtype)
    -> true
  (* Local might be uninitialized, which will trigger UB,
     but we assume that the variables we generate are correctly initialized.
  *)
  | Var _, o -> is_dangerous_offset o
  | Mem _,_ -> true

class check_no_locals = object
  inherit nopCilVisitor
  method! vlval (h,_) =
    (match h with
     | Var v ->
       if not v.vglob then
         Kernel.error ~once:true ~current:true
           "Forbidden access to local variable %a in static initializer"
           Cil_printer.pp_varinfo v
     | _ -> ());
    DoChildren
end

let rec check_no_locals_in_initializer i =
  match i with
  | SingleInit e ->
    ignore (visitCilExpr (new check_no_locals) e)
  | CompoundInit (ct, initl) ->
    foldLeftCompound ~implicit:false
      ~doinit:(fun _off' i' _ () ->
          check_no_locals_in_initializer i')
      ~ct:ct
      ~initl:initl
      ~acc:()


(* ---------- source error message handling ------------- *)
let cabslu s =
  {Cil_datatype.Position.unknown with
   Filepath.pos_path = Datatype.Filepath.of_string ("Cabs2cil_start" ^ s)},
  {Cil_datatype.Position.unknown with
   Filepath.pos_path = Datatype.Filepath.of_string ("Cabs2cil_end" ^ s)}


(** Keep a list of the variable ID for the variables that were created to
 * hold the result of function calls *)
let callTempVars: unit IH.t = IH.create 13

(* Check that s starts with the prefix p *)
let prefix p s =
  let lp = String.length p in
  let ls = String.length s in
  lp <= ls && String.sub s 0 lp = p


(***** PROCESS PRAGMAS **********)

(* fc_stdlib pragma. Delimits blocks of globals that are declared in
   a given std lib header. By default, they will not be pretty-printed by
   frama-c -print, which will emit #include "header.h" instead
*)
let current_stdheader = ref []

let pop_stdheader () =
  match !current_stdheader with
  | s::l ->
    Kernel.debug ~dkey:Kernel.dkey_typing_pragma "Popping %s %s" fc_stdlib s;
    current_stdheader := l
  | [] ->
    Kernel.warning ~current:true
      "#pragma %s pop does not match a push" fc_stdlib

let push_stdheader s =
  Kernel.debug ~dkey:Kernel.dkey_typing_pragma "Pushing %s %s@." fc_stdlib s;
  current_stdheader := s::!current_stdheader

(* Returns the topmost (latest) header that is not internal to Frama-C,
   unless it is the only one.
   This prevents the pretty-printing function from including Frama-C
   internal files, unless they were directly specified by the user. *)
let get_current_stdheader () =
  let rec aux = function
    | [] -> ""
    | [ s ] -> s
    | s :: l when Extlib.string_prefix ~strict:true "__fc_" s -> aux l
    | s :: _ -> s
  in
  aux !current_stdheader

(* there are several pragmas that we process directly here and remove
   from the globals list, by returning None. We bind their respective
   processing functions with the operator below.
*)
let (>>?) opt f =
  match opt with
  | Some (Attr(name, args)) -> f name args
  | _ -> opt

let process_stdlib_pragma name args =
  if name = fc_stdlib then begin
    match args with
    | [ ACons ("pop",_) ] -> pop_stdheader (); None
    | [ ACons ("push",_); AStr s ] ->
      let base_name = (Fc_config.framac_libc:>string) in
      let relative_name = Filepath.relativize ~base_name s in
      push_stdheader relative_name;
      None
    | _ -> Some (Attr(name, args))
  end else Some (Attr(name, args))

let fc_stdlib_attribute attrs =
  let s = get_current_stdheader () in
  if s = "" then attrs
  else begin
    let payload, attrs =
      if Cil.hasAttribute fc_stdlib attrs then begin
        AStr s :: Cil.findAttribute fc_stdlib attrs,
        Cil.dropAttribute fc_stdlib attrs
      end else [AStr s], attrs
    in
    Cil.addAttribute (Attr (fc_stdlib, payload)) attrs
  end
(* ICC align/noalign pragmas (not supported by GCC/MSVC with this syntax).
   Implemented by translating them to 'aligned' attributes. Currently,
   only default and noalign are supported, not explicit alignment values.
   Cf. www.slac.stanford.edu/grp/cd/soft/rmx/manuals/IC_386.PDF *)
let current_pragma_align = ref (None : bool option)
let pragma_align_by_struct = H.create 17

let process_align_pragma name args =
  let aux pname v =
    (if Cil.msvcMode () || Cil.gccMode ()
     then Kernel.warning ?wkey:None else Kernel.debug ~level:1 ?dkey:None)
      ~current:true "Parsing ICC '%s' pragma." pname;
    match args with
    | [] -> current_pragma_align := Some v
    | l ->
      List.iter
        (function
          | AStr s | ACons (s, _) -> H.replace pragma_align_by_struct s v
          | _ -> Kernel.warning ~current:true
                   "Unsupported '%s' pragma not honored by Frama-C." pname
        ) l
  in
  match name with
  | "align" -> aux "align" true
  | "noalign" -> aux "noalign" false
  | _ -> ()

let align_pragma_for_struct sname =
  try Some (H.find pragma_align_by_struct sname)
  with Not_found -> !current_pragma_align

(* The syntax and semantics for the pack pragmas are GCC's, which emulates most
   of MSVC's behaviors. Some of it has been tested using MSVC 2010.
   Note that #pragma pack directives are emulated by translating them into
   GCC-style attributes, which in turn are not supported by MSVC.
   Therefore some combinations of attributes may be impossible to produce in
   MSVC, which means that Frama-C on an MSVC machdep may accept more programs
   that MSVC would. *)

(* The pack pragma stack *)
let packing_pragma_stack = Stack.create ()

(* The current pack pragma *)
let current_packing_pragma = ref None
let pretty_current_packing_pragma fmt =
  let align =
    Option.value ~default:(Integer.of_int theMachine.theMachine.alignof_aligned)
      !current_packing_pragma
  in
  Integer.pretty fmt align

(* Checks if [n] is a valid alignment for #pragma pack, and emits a warning
   if it is not the case. Returns the value to be set as current packing pragma.
   From the MSDN reference
   (msdn.microsoft.com/en-us/library/2e70t5y1(v=vs.100).aspx):
   Valid values are 1, 2, 4, 8, and 16.

   NOTE: GCC seems to consider '#pragma pack(0)' as equivalent to '#pragma pack()',
   but this is not specified in their documentation. To avoid rejecting programs
   with such pragmas, we emulate GCC's current behavior but emit a warning.
   This is the only case when this function returns [None]. *)
let get_valid_pragma_pack_alignment n =
  if Integer.is_zero n && Cil.gccMode () then begin
    Kernel.warning ~current:true "GCC accepts pack(0) but does not specify its \
                                  behavior; considering it equivalent to pack()";
    true, None
  end
  else begin
    let valid = Integer.(equal n one || equal n two || equal n four ||
                         equal n eight || equal n sixteen)
    in
    if not valid then
      Kernel.warning ~current:true "ignoring invalid packing alignment (%a)"
        Integer.pretty n;
    valid, Some n
  end

let process_pack_pragma name args =
  begin match name with
    | "pack" -> begin
        match args with
        | [ACons ("",[])] (*  #pragma pack() *) ->
          Kernel.feedback ~dkey:Kernel.dkey_typing_pragma ~current:true
            "packing pragma: restoring alignment to default (%d)"
            theMachine.theMachine.alignof_aligned;
          current_packing_pragma := None; None
        | [AInt n] (* #pragma pack(n) *) ->
          let is_valid, new_pragma = get_valid_pragma_pack_alignment n in
          if is_valid then begin
            Kernel.feedback ~dkey:Kernel.dkey_typing_pragma ~current:true
              "packing pragma: setting alignment to %a" Integer.pretty n;
            current_packing_pragma := new_pragma; None
          end else
            Some (Attr (name, args))
        | [ACons ("push",[])] (* #pragma pack(push) *) ->
          Kernel.feedback ~dkey:Kernel.dkey_typing_pragma ~current:true
            "packing pragma: pushing alignment %t" pretty_current_packing_pragma;
          Stack.push !current_packing_pragma packing_pragma_stack; None
        | [ACons ("push",[]); AInt n] (* #pragma pack(push,n) *) ->
          let is_valid, new_pragma = get_valid_pragma_pack_alignment n in
          if is_valid then begin
            Kernel.feedback ~dkey:Kernel.dkey_typing_pragma ~current:true
              "packing pragma: pushing alignment %t, setting alignment to %a"
              pretty_current_packing_pragma Integer.pretty n;
            Stack.push !current_packing_pragma packing_pragma_stack;
            current_packing_pragma:= new_pragma; None
          end else
            Some (Attr (name, args))
        | ACons ("push",[]) :: args (* unknown push directive *) ->
          Kernel.warning ~current:true
            "Unsupported argument for pragma pack push directive: `%a'."
            Format.(
              pp_print_list
                ~pp_sep:(fun fmt ()->pp_print_string fmt ", ")
                Cil_printer.pp_attrparam)
            args;
          (* We don't change the current packing directive, but
             nevertheless push it on the stack, to avoid a mismatched
             pop somewhere later. *)
          Stack.push !current_packing_pragma packing_pragma_stack;
          None
        | [ACons ("pop",[])] (* #pragma pack(pop) *) ->
          begin try
              current_packing_pragma := Stack.pop packing_pragma_stack;
              Kernel.feedback ~dkey:Kernel.dkey_typing_pragma ~current:true
                "packing pragma: popped alignment %t" pretty_current_packing_pragma;
              None
            with Stack.Empty ->
              (* GCC/Clang/MSVC seem to ignore the directive when a pop() is
                 called with an empty stack, so we emulate their behavior. *)
              Kernel.warning ~current:true
                "ignoring #pragma pack(pop) with empty stack";
              None
          end
        | [ACons ("show",[])] (* #pragma pack(show) *) ->
          Some (Attr (name, args))
        | _ ->
          Kernel.warning ~current:true
            "Unsupported packing pragma not honored by Frama-C: #pragma pack(%a)"
            (Pretty_utils.pp_list ~sep:", " ~empty:"<empty>"
               Cil_printer.pp_attrparam) args;
          Some (Attr (name, args))
      end
    | _ -> Some (Attr (name, args))
  end

let force_packed_attribute a =
  if hasAttribute "packed" a then a
  else addAttribute (Attr("packed",[])) a

let is_power_of_two i = i > 0 && i land (i-1) = 0

(* Computes the numeric value corresponding to an 'aligned' attribute:
   – if 'aligned' (without integer), then use the maximum machine alignment;
   – else, try to const-fold the expression to an integer value.
   Returns [Some n] in case of success, [None] otherwise.
   Note that numeric values that are not powers of two are invalid and
   also return [None]. *)
let eval_aligned_attrparams aps =
  match aps with
  | [] -> Some (Integer.of_int theMachine.theMachine.alignof_aligned)
  | [ap] ->
    begin
      match Cil.intOfAttrparam ap with
      | None -> None
      | Some n -> if is_power_of_two n then Some (Integer.of_int n) else None
    end
  | _ -> (* 'aligned(m,n,...)' is not a valid syntax *) None

let warn_invalid_align_attribute aps =
  Kernel.warning ~current:true ~once:true
    "ignoring invalid aligned attribute: %a"
    Cil_printer.pp_attribute (Attr("aligned", aps))

(* If there is more than one 'aligned' attribute, GCC's behavior is to
   consider the maximum among them. This function computes this value
   and also emits warnings for invalid attributes. *)
let combine_aligned_attributes attrs =
  match filterAttributes "aligned" attrs with
  | [] -> None
  | aligned_attrs ->
    List.fold_left (fun acc attr ->
        match attr with
        | Attr("aligned", aps) ->
          begin
            let align = eval_aligned_attrparams aps in
            if align = None then begin
              warn_invalid_align_attribute aps;
              acc
            end else
              match acc, align with
              | None, a | a, None -> a
              | Some old_n, Some new_n -> Some (Integer.max old_n new_n)
          end
        | _ -> assert false (* attributes were previously filtered by name *)
      ) None aligned_attrs

let warn_incompatible_pragmas_attributes apragma has_attrs =
  if apragma <> None then
    Kernel.warning ~current:true ~once:true
      "ignoring 'align' pragma due to presence of 'pack' pragma.@ \
       No compiler was supposed to accept both syntaxes.";
  if Cil.msvcMode () && has_attrs then
    (* MSVC does not allow attributes *)
    Kernel.warning ~current:true ~once:true
      "field attributes should not be present in MSVC-compatible sources"

(* checks [attrs] for invalid aligned() attributes *)
let check_aligned attrs =
  List.fold_right (fun attr acc ->
      match attr with
      | Attr("aligned", aps) ->
        if eval_aligned_attrparams aps = None then
          (warn_invalid_align_attribute aps; acc)
        else attr :: acc
      | _ -> attr :: acc
    ) attrs []

(* Takes into account the possible effect of '#pragma pack' directives on
   component [ci], and checks the alignment of aligned() attributes.
   This function is complemented by
   [process_pragmas_pack_align_field_attributes]. *)
let process_pragmas_pack_align_comp_attributes ci cattrs =
  match !current_packing_pragma, align_pragma_for_struct ci.corig_name with
  | None, None -> check_aligned cattrs
  | Some n, apragma ->
    warn_incompatible_pragmas_attributes apragma (cattrs <> []);
    let with_aligned_attributes =
      match combine_aligned_attributes cattrs with
      | None ->
        (* No valid aligned attributes in this field.
           – if the composite type has a packed attribute, then add the
             alignment given by the pack pragma;
           – otherwise, no alignment attribute is necessary.
           Drop existing "aligned" attributes, if there are invalid ones. *)
        if Cil.hasAttribute "packed" cattrs then (dropAttribute "aligned" cattrs)
        else begin
          Kernel.feedback ~dkey:Kernel.dkey_typing_pragma ~current:true
            "adding aligned(%a) attribute to comp '%s' due to packing pragma"
            Integer.pretty n ci.cname;
          addAttribute (Attr("aligned",[AInt n])) (dropAttribute "aligned" cattrs)
        end
      | Some local ->
        (* The largest aligned wins with GCC. Don't know
           with other compilers. *)
        let align = Integer.max n local in
        Kernel.feedback ~dkey:Kernel.dkey_typing_pragma ~current:true
          "setting aligned(%a) attribute to comp '%s' due to packing pragma"
          Integer.pretty align ci.cname;
        addAttribute (Attr("aligned",[AInt align]))
          (dropAttribute "aligned" cattrs)
    in
    force_packed_attribute with_aligned_attributes
  | None, Some true ->
    dropAttribute "aligned" cattrs
  | None, Some false ->
    force_packed_attribute
      (addAttribute
         (Attr("aligned",[AInt Integer.one]))
         (dropAttribute "aligned" cattrs))

(* Takes into account the possible effect of '#pragma pack' directives on
   field [fi], and checks the alignment of aligned() attributes.
   Because we emulate them using GCC attributes, this transformation
   is complex and depends on several factors:
   - if the struct inside the pragma is packed, then ignore alignment constraints
     given by the pragma;
   - otherwise, each struct field should have the alignment given by the pack
     directive, unless that field already has an align attribute, in which case
     the minimum of both is taken into account (note that, in GCC, if a field
     has 2 alignment directives, it is the maximum of those that is taken). *)
let process_pragmas_pack_align_field_attributes fi fattrs cattr =
  match !current_packing_pragma, align_pragma_for_struct fi.forig_name with
  | None, None -> check_aligned fattrs
  | Some n, apragma ->
    begin
      warn_incompatible_pragmas_attributes apragma (fattrs <> []);
      match combine_aligned_attributes fattrs with
      | None ->
        (* No valid aligned attributes in this field.
           – if the composite type has a packed attribute, nothing needs to be
             done (the composite will have the "packed" attribute anyway);
           – otherwise, align on min(n,sizeof(fi.ftyp)).
           Drop existing "aligned" attributes, if there are invalid ones. *)
        if Cil.hasAttribute "packed" cattr then (dropAttribute "aligned" fattrs)
        else begin
          let sizeof_type =
            match Cil.unrollType fi.ftype with
            | TArray (_, None, _) ->
              (* flexible array member: use size of pointer *)
              Cil.bitsSizeOf theMachine.upointType
            | _ ->
              Cil.bytesSizeOf fi.ftype
          in
          let align = Integer.(min n (of_int sizeof_type)) in
          Kernel.feedback ~dkey:Kernel.dkey_typing_pragma ~current:true
            "adding aligned(%a) attribute to field '%s.%s' due to packing pragma"
            Integer.pretty align fi.fcomp.cname fi.fname;
          addAttribute (Attr("aligned",[AInt align])) (dropAttribute "aligned" fattrs)
        end
      | Some local ->
        (* There is an alignment attribute in this field. This may be smaller
           than the field type alignment, so we get the maximum of both.
           Then, we apply the pragma pack: the final alignment will be the
           minimum between what we had and [n]. *)
        let align = Integer.min n (Integer.max (Integer.of_int (Cil.bytesSizeOf fi.ftype)) local) in
        Kernel.feedback ~dkey:Kernel.dkey_typing_pragma ~current:true
          "setting aligned(%a) attribute to field '%s.%s' due to packing pragma"
          Integer.pretty align fi.fcomp.cname fi.fname;
        addAttribute (Attr("aligned",[AInt align]))
          (dropAttribute "aligned" fattrs)
    end
  | None, Some true ->
    dropAttribute "aligned" fattrs
  | None, Some false ->
    (addAttribute
       (Attr("aligned",[AInt Integer.one]))
       (dropAttribute "aligned" fattrs))


(***** COMPUTED GOTO ************)

(* The address of labels are small integers (starting from 0). A computed
 * goto is replaced with a switch on the address of the label. We generate
 * only one such switch and we'll jump to it from all computed gotos. To
 * accomplish this we'll add a local variable to store the target of the
 * goto. *)

(* The local variable in which to put the detonation of the goto and the
 * statement where to jump *)
let gotoTargetData: (varinfo * stmt) option ref = ref None

(* The "addresses" of labels *)
let gotoTargetHash: (string, int) H.t = H.create 13
let gotoTargetNextAddr: int ref = ref 0


(********** TRANSPARENT UNION ******)
(* Check if a type is a transparent union, and return the first field if it
 * is *)
let isTransparentUnion (t: typ) : fieldinfo option =
  match unrollType t with
  | TComp (comp, _) when not comp.cstruct ->
    (* Turn transparent unions into the type of their first field *)
    if typeHasAttribute "transparent_union" t then begin
      match comp.cfields with
      | Some [] | None ->
        abort_context
          "Empty transparent union: %s" (compFullName comp)
      | Some (f :: _) -> Some f
    end else
      None
  | _ -> None

(* When we process an argument list, remember the argument index which has a
 * transparent union type, along with the original type. We need this to
 * process function definitions *)
let transparentUnionArgs : (int * typ) list ref = ref []

let debugLoc = false
let convLoc (l : cabsloc) =
  if debugLoc then
    Kernel.debug "convLoc at %a: line %d, btye %d\n"
      Datatype.Filepath.pretty (fst l).Filepath.pos_path
      (fst l).Filepath.pos_lnum (fst l).Filepath.pos_bol;
  l

let isOldStyleVarArgName n =
  if Cil.msvcMode () then n = "va_alist"
  else n = "__builtin_va_alist"

let isOldStyleVarArgTypeName n =
  if Cil.msvcMode () then n = "va_list"  || n = "__ccured_va_list"
  else n = "__builtin_va_alist_t"

(* CERT EXP 46 rule: operands of bitwise operators should not be of type _Bool
   or the result of a comparison.
*)
let check_logical_operand e t =
  let (source,_) = e.expr_loc in
  match Cil.unrollType t with
  | TInt(IBool, _) ->
    Kernel.warning ~wkey:Kernel.wkey_cert_exp_46 ~source
      "operand of bitwise operator has boolean type"
  | _ ->
    let rec aux = function
      | { expr_node = Cabs.PAREN e} -> aux e
      | { expr_node = Cabs.BINARY (bop,_,_); expr_loc = (source, _) }
        when is_relational_bop bop ->
        Kernel.warning ~wkey:Kernel.wkey_cert_exp_46 ~source
          "operand of bitwise operator is a logical relation"
      | _ -> (* EXP 46 does not forbid something like
                (x && y) & z, even though the logical and returns 0 or 1 as
                a relational operator. Maybe this should be clarified. *)
        ()
    in
    aux e

(*** EXPRESSIONS *************)

(* We collect here the program *)
let theFile : global list ref = ref []
let theFileTypes : global list ref = ref []
(* This hashtbl contains the varinfo-indexed globals of theFile.
   They are duplicated here for faster lookup *)
let theFileVars : global Cil_datatype.Varinfo.Hashtbl.t =
  Cil_datatype.Varinfo.Hashtbl.create 13

let findVarInTheFile vi =
  try  List.rev (Cil_datatype.Varinfo.Hashtbl.find_all theFileVars vi)
  with Not_found -> []

let update_fundec_in_theFile vi (f:global -> unit) =
  let rec aux = function
    | [] -> assert false
    | (GFunDecl _ as g) :: _ -> f g
    | _ :: tl -> aux tl
  in
  aux (findVarInTheFile vi)

let update_funspec_in_theFile vi spec =
  let rec aux = function
    | [] -> assert false
    | GFun (f,oldloc) :: _ ->
      Logic_utils.merge_funspec ~oldloc f.sspec spec
    | _ :: tl -> aux tl
  in
  aux (findVarInTheFile vi)

let find_existing_behaviors vi =
  let behaviors spec = List.map (fun x -> x.b_name) spec.spec_behavior in
  let aux acc = function
    | GFun(f,_) -> (behaviors f.sspec) @ acc
    | GFunDecl (spec,_,_)  -> behaviors spec @ acc
    | _ -> acc
  in List.fold_left aux [] (findVarInTheFile vi)

let get_formals vi =
  let rec aux = function
    | [] -> assert false
    | GFun(f,_)::_ -> f.sformals
    | _ :: tl -> aux tl
  in aux (findVarInTheFile vi)

let initGlobals () =
  theFile := [];
  theFileTypes := [];
  Cil_datatype.Varinfo.Hashtbl.clear theFileVars;
;;

let cabsPushGlobal (g: global) =
  pushGlobal g ~types:theFileTypes ~variables:theFile;
  (match g with
   | GVar (vi, _, _) | GVarDecl (vi, _)
   | GFun ({svar = vi}, _) | GFunDecl (_, vi, _) ->
     (* Do 'add' and not 'replace' here, as we may store both
        declarations and definitions for the same varinfo *)
     Cil_datatype.Varinfo.Hashtbl.add theFileVars vi g
   | _ -> ()
  );
;;


(* Keep track of some variable ids that must be turned into definitions. We
 * do this when we encounter what appears a definition of a global but
 * without initializer. We leave it a declaration because maybe down the road
 * we see another definition with an initializer. But if we don't see any
 * then we turn the last such declaration into a definition without
 * initializer *)
let mustTurnIntoDef: bool IH.t = IH.create 117

(* Globals that have already been defined. Indexed by the variable name. *)
let alreadyDefined: (string, location) H.t = H.create 117

(* Globals that were created due to static local variables. We chose their
 * names to be distinct from any global encountered at the time. But we might
 * see a global with conflicting name later in the file. *)
let staticLocals: (string, varinfo) H.t = H.create 13


(* Typedefs. We chose their names to be distinct from any global encountered
 * at the time. But we might see a global with conflicting name later in the
 * file *)
let typedefs: (string, typeinfo) H.t = H.create 13

let fileGlobals () =
  let rec revonto (tail: global list) = function
      [] -> tail

    | GVarDecl (vi, _) :: rest when IH.mem mustTurnIntoDef vi.vid ->
      IH.remove mustTurnIntoDef vi.vid;
      (* Use the location of vi instead of the one carried by GVarDecl.
         Maybe we found in the same file a declaration and then a tentative
         definition. In this case, both are GVarDecl, but the location carried
         by [vi] is the location of the tentative definition, which is more
         useful. *)
      if vi.vstorage = Extern then vi.vstorage <- NoStorage;
      vi.vdefined <- true;
      revonto (GVar (vi, {init = None}, vi.vdecl) :: tail) rest

    | x :: rest -> revonto (x :: tail) rest
  in
  revonto (revonto [] !theFile) !theFileTypes


(********* ENVIRONMENTS ***************)

(* The environment is kept in two distinct data structures. A hash table maps
 * each original variable name into a varinfo (for variables, or an
 * enumeration tag, or a type). (Note that the varinfo might contain an
 * alpha-converted name different from that of the lookup name.) The Ocaml
 * hash tables can keep multiple mappings for a single key. Each time the
 * last mapping is returned and upon deletion the old mapping is restored. To
 * keep track of local scopes we also maintain a list of scopes (represented
 * as lists).  *)
type envdata =
    EnvVar of varinfo                   (* The name refers to a variable
                                         * (which could also be a function) *)
  | EnvEnum of enumitem                 (* the name refers to an enum item *)
  | EnvTyp of typ                       (* The name is of the form  "struct
                                         * foo", or "union foo" or "enum foo"
                                         * and refers to a type. Note that
                                         * the name of the actual type might
                                         * be different from foo due to alpha
                                         * conversion *)
  | EnvLabel of string                  (* The name refers to a label. This
                                         * is useful for GCC's locally
                                         * declared labels. The lookup name
                                         * for this category is "label foo" *)

let env  = Datatype.String.Hashtbl.create 307
(* ghost environment: keep track of all symbols, in the order
   in which they have been introduced. Superset of env *)
let ghost_env = Datatype.String.Hashtbl.create 307
(* We also keep a global environment. This is always a subset of the env *)
let global_env = Datatype.String.Hashtbl.create 307
(* ghost global environment: superset of global and subset of ghost *)
let ghost_global_env = Datatype.String.Hashtbl.create 307

(* maps a C label to the ghost environment of variables in scope
   at this program point. Used for typing \at() terms and predicates. *)
let label_env = Datatype.String.Hashtbl.create 307

let add_label_env lab =
  let add_if_absent v (d,_) map =
    match d with
    | EnvVar vi when not (Datatype.String.Map.mem v map) ->
      Datatype.String.Map.add v vi map
    | _ -> map
  in
  let open Datatype.String.Hashtbl in
  let lab_env = fold add_if_absent ghost_env Datatype.String.Map.empty in
  add label_env lab lab_env

let remove_label_env lab =
  Datatype.String.Hashtbl.remove label_env lab

(* In the scope we keep the original name, so we can remove them from the
 * hash table easily *)
type undoScope =
    UndoRemoveFromEnv of bool * string (* boolean indicates whether we should
                                          remove from ghost env only, or both.*)
  | UndoAlphaEnv of location Alpha.undoAlphaElement list

let scopes :  undoScope list ref list ref = ref []

(* tries to estimate if the name 's' was declared in the current scope;
   note that this may not work in all cases *)
let declared_in_current_scope ~ghost s =
  match !scopes with
  | [] -> (* global scope *)
    let env = if ghost then ghost_global_env else global_env in
    Datatype.String.Hashtbl.mem env s
  | cur_scope :: _ ->
    let names_declared_in_current_scope =
      Extlib.filter_map
        (function
          | UndoRemoveFromEnv (ghost',_)  -> ghost || not ghost'
          | UndoAlphaEnv _ -> false)
        (function
          | UndoRemoveFromEnv (_, s) -> s
          | UndoAlphaEnv _ -> assert false (* already filtered *)
        ) !cur_scope
    in
    List.mem s names_declared_in_current_scope

(* When you add to env, you also add it to the current scope *)
let addLocalToEnv ghost name data =
  let v = data, CurrentLoc.get() in
  Datatype.String.Hashtbl.add ghost_env name v;
  if not ghost then Datatype.String.Hashtbl.add env name v;
  (* If we are in a scope, then it means we are not at top level. Add the
   * name to the scope *)
  match !scopes with
  | [] -> begin
      match data with
      | EnvVar _ ->
        Kernel.fatal ~current:true
          "addLocalToEnv: not in a scope when adding %s!" name
      | _ ->
        (* Adding a type with local scope *)
        Datatype.String.Hashtbl.add ghost_global_env name v;
        if not ghost then Datatype.String.Hashtbl.add global_env name v
    end
  | s :: _ -> s := UndoRemoveFromEnv (ghost, name) :: !s

let addGlobalToEnv ghost name data =
  let open Datatype.String.Hashtbl in
  let v = data, CurrentLoc.get () in
  add ghost_env name v;
  if not ghost then add env name v;
  add ghost_global_env name v;
  if not ghost then add global_env name v

(* Create a new name based on a given name. The new name is formed from a
 * prefix (obtained from the given name as the longest prefix that ends with
 * a non-digit), followed by a '_' and then by a positive integer suffix. The
 * first argument is a table mapping name prefixes with the largest suffix
 * used so far for that prefix. The largest suffix is one when only the
 * version without suffix has been used. *)
let alphaTable : location Alpha.alphaTable = H.create 307
(* vars and enum tags. For composite types we have names like "struct
 * foo" or "union bar" *)

let fresh_global lookupname =
  fst (Alpha.newAlphaName ~alphaTable ~undolist:None ~lookupname
         ~data:(CurrentLoc.get ()))

(* To keep different name scopes different, we add prefixes to names
 * specifying the kind of name: the kind can be one of "" for variables or
 * enum tags, "struct" for structures and unions (they share the name space),
 * "enum" for enumerations, or "type" for types *)
let kindPlusName (kind: string)
    (origname: string) : string =
  (* typedefs live in the same namespace as normal identifiers. *)
  if kind = "" || kind = "type" then origname
  else kind ^ " " ^ origname

let stripKind (kind: string) (kindplusname: string) : string =
  let kind = if kind = "type" then "" else kind in
  let l = 1 + String.length kind in
  if l > 1 then
    String.sub kindplusname l (String.length kindplusname - l)
  else
    kindplusname

let is_same_kind kind info =
  match kind, info with
  | "", EnvEnum _
  | "enum", EnvTyp _
  | "type", EnvTyp _
  | "struct", EnvTyp _
  | "union", EnvTyp _
  | "label", EnvLabel _
  | "", EnvVar _ -> true
  | _, _ -> false

let find_identifier_decl ghost name info =
  match info with
  | UndoRemoveFromEnv (ghost', name') ->
    (ghost || not ghost') && name = name'
  | _ -> false

let newAlphaName
    ghost
    (globalscope: bool) (* The name should have global scope *)
    (kind: string)
    (origname: string) : string * location =
  let lookupname = kindPlusName kind origname in
  (* If we are in a scope then it means that we are alpha-converting a local
   * name. Go and add stuff to reset the state of the alpha table but only to
   * the top-most scope (that of the enclosing function) *)
  let rec findEnclosingFun = function
      [] -> (* At global scope *) None
    | [s] -> Some s
    | _ :: rest -> findEnclosingFun rest
  in
  let undo_scope =
    if not globalscope then findEnclosingFun !scopes else None
  in
  let undolist =
    match undo_scope with None -> None | Some _ -> Some (ref [])
  in
  let data = CurrentLoc.get () in
  let newname, oldloc =
    Alpha.newAlphaName ~alphaTable ~undolist ~lookupname ~data
  in
  (match undo_scope, undolist with
   | None, None -> ()
   | Some s, Some l -> s := (UndoAlphaEnv !l) :: !s
   | _ -> assert false (* by construction, both options have the same status*));
  if newname <> lookupname then begin
    try
      let info =
        if !scopes = [] then begin
          let env = if ghost then ghost_global_env else global_env in
          fst (Datatype.String.Hashtbl.find env lookupname)
        end else
        if List.exists
            (find_identifier_decl ghost lookupname) !(List.hd !scopes)
        then begin
          let env = if ghost then ghost_env else env in
          fst (Datatype.String.Hashtbl.find env lookupname)
        end
        else raise Not_found
      in
      if not (Kernel.C11.get () && kind = "type") then
        (* in C11, typedefs can be redefined under some conditions (which are
           checked in doTypedef); this test catches other kinds of errors, such
           as redefined enumeration constants *)
        Kernel.error ~current:true
          "redefinition of '%s'%s in the same scope.@ \
           Previous declaration was at %a"
          origname (if is_same_kind kind info then "" else " with different kind")
          Cil_datatype.Location.pretty oldloc
    with
    | Not_found -> () (* no clash of identifiers *)
    | Failure _ ->
      Kernel.fatal ~current:true
        "finding a fresh identifier in local scope with empty scopes stack"
  end;
  stripKind kind newname, oldloc

(*** In order to process GNU_BODY expressions we must record that a given
 *** COMPUTATION is interesting *)
let gnu_body_result : (Cabs.statement * ((exp * typ) option ref)) ref
  = ref ({stmt_ghost = false; stmt_node = Cabs.NOP (cabslu "_NOP")}, ref None)

(*** When we do statements we need to know the current return type *)
let dummy_function = emptyFunction "@dummy@"
let currentReturnType : typ ref = ref (TVoid([]))
let currentFunctionFDEC: fundec ref = ref dummy_function

let lastStructId = ref 0
let anonStructName (k: string) (suggested: string) =
  incr lastStructId;
  "__anon" ^ k ^ (if suggested <> "" then "_"  ^ suggested else "")
  ^ "_" ^ (string_of_int (!lastStructId))


let constrExprId = ref 0


let startFile () =
  let open Datatype.String.Hashtbl in
  clear label_env;
  clear env;
  clear ghost_env;
  H.clear alphaTable;
  lastStructId := 0

(* Lookup a variable name. Return also the location of the definition. Might
 * raise Not_found  *)
let lookupVar ghost name =
  let env = if ghost then ghost_env else env in
  match Datatype.String.Hashtbl.find env name with
  | (EnvVar vi), loc -> vi, loc
  | _ -> raise Not_found

let only_ghost_symbol name =
  try ignore (lookupVar false name); false
  with Not_found ->
  try ignore (lookupVar true name); true
  with Not_found -> false

let lookupGlobalVar ghost name =
  let env = if ghost then ghost_global_env else global_env in
  match Datatype.String.Hashtbl.find env name with
  | (EnvVar vi), loc -> vi, loc
  | _ -> raise Not_found

(* Add a new variable. Do alpha-conversion if necessary *)
let alphaConvertVarAndAddToEnv addtoenv vi =
  (* Announce the name to the alpha conversion table *)
  let newname, oldloc =
    newAlphaName vi.vghost (addtoenv && vi.vglob) "" vi.vname
  in
  (* Make a copy of the vi if the name has changed. Never change the name for
   * global variables *)
  let newvi =
    if vi.vname = newname then
      vi
    else begin
      if vi.vglob then begin
        (* if a purely local variable stole our name, force it to be renamed.*)
        let local =
          List.find_opt
            (fun x -> x.vname = vi.vname) !currentFunctionFDEC.slocals
        in
        match local with
        | Some local -> local.vname <- newname; vi
        | None ->
          (* Perhaps this is because we have seen a static local which happened
           * to get the name that we later want to use for a global. *)
          try
            let static_local_vi = H.find staticLocals vi.vname in
            H.remove staticLocals vi.vname;
            (* Use the new name for the static local *)
            static_local_vi.vname <- newname;
            (* And continue using the last one *)
            vi
          with Not_found -> begin
              (* Or perhaps we have seen a typedef which stole our name. This is
                 possible because typedefs use the same name space *)
              try
                let typedef_ti = H.find typedefs vi.vname in
                H.remove typedefs vi.vname;
                (* Use the new name for the typedef instead *)
                typedef_ti.tname <- newname;
                (* And continue using the last name *)
                vi
              with Not_found ->
                abort_context
                  "It seems that we would need to rename global %s (to %s) \
                   because of previous occurrence at %a"
                  vi.vname newname Cil_printer.pp_location oldloc;
            end
      end else copyVarinfo vi newname
    end
  in
  (* Store all locals in the slocals (in reversed order). *)
  if not vi.vglob && not vi.vformal then
    !currentFunctionFDEC.slocals <- newvi :: !currentFunctionFDEC.slocals;

  (if addtoenv then
     if vi.vglob then
       addGlobalToEnv vi.vghost vi.vname (EnvVar newvi)
     else
       addLocalToEnv vi.vghost vi.vname (EnvVar newvi));
(*
  ignore (E.log "  new=%s\n" newvi.vname);
*)
  (*  ignore (E.log "After adding %s alpha table is: %a\n"
              newvi.vname docAlphaTable alphaTable); *)
  newvi

let constFoldTypeVisitor = object
  inherit nopCilVisitor
  method! vtype t: typ visitAction =
    match t with
    | TArray(bt, Some len, a) ->
      let len' = constFold true len in
      ChangeDoChildrenPost (
        TArray(bt, Some len', a),
        (fun x -> x)
      )
    | _ -> DoChildren
end

(* Const-fold any expressions that appear as array lengths in this type *)
let constFoldType (t:typ) : typ =
  visitCilType constFoldTypeVisitor t

let to_integer i =
  match Integer.to_int_opt i with
  | Some i -> i
  | None ->
    Kernel.error ~current:true "integer too large: %a"
      Integer.pretty_hex i;
    -1

let constFoldToInteger e =
  try Option.map Integer.to_int_exn (Cil.constFoldToInt e)
  with Z.Overflow ->
    Kernel.error ~current:true
      "integer constant too large in expression %a"
      Cil_printer.pp_exp e;
    None

let get_temp_name ghost () =
  let undolist = ref [] in
  let data = CurrentLoc.get() in
  let name = if ghost then "g_tmp" else "tmp" in
  let name, _ =
    Alpha.newAlphaName ~alphaTable ~undolist:(Some undolist) ~lookupname:name ~data
  in
  let undolist = !undolist in
  Alpha.undoAlphaChanges ~alphaTable ~undolist;
  name

(* Create a new temporary variable *)
let newTempVar ~ghost loc descr (descrpure:bool) typ =
  let t' = (!typeForInsertedVar) typ in
  let t' = Cil.typeRemoveAttributes ["const"] t' in
  let name = get_temp_name ghost () in
  let vi = makeVarinfo ~ghost ~temp:true ~loc false false name t' in
  vi.vdescr <- Some descr;
  vi.vdescrpure <- descrpure;
  alphaConvertVarAndAddToEnv false vi

let mkAddrOfAndMark loc ((b, off) as lval) : exp =
  (* Mark the vaddrof flag if b is a variable *)
  begin match lastOffset off with
    | NoOffset ->
      (match b with
       | Var vi -> vi.vaddrof <- true
       | _ -> ())
    | Index _ -> ()
    | Field(fi,_) -> fi.faddrof <- true
  end;
  mkAddrOf ~loc lval

(* Call only on arrays *)
let mkStartOfAndMark loc ((b, _off) as lval) : exp =
  (* Mark the vaddrof flag if b is a variable *)
  (match b with
   | Var vi -> vi.vaddrof <- true
   | _ -> ());
  new_exp ~loc (StartOf lval)

(* Keep a set of self compinfo for composite types *)
let compInfoNameEnv : (string, compinfo) H.t = H.create 113
let enumInfoNameEnv : (string, enuminfo) H.t = H.create 113


let lookupTypeNoError ghost kind name =
  let kn = kindPlusName kind name in
  let env = if ghost then ghost_env else env in
  match Datatype.String.Hashtbl.find env kn with
  | EnvTyp t, l -> t, l
  | _ -> raise Not_found

let lookupType ghost kind name =
  try
    lookupTypeNoError ghost kind name
  with Not_found ->
    Kernel.fatal ~current:true "Cannot find type %s (kind:%s)" name kind

(* Create the self ref cell and add it to the map. Return also an indication
 * if this is a new one. *)
let createCompInfo (iss: bool) (n: string) ~(norig: string) : compinfo * bool =
  (* Add to the self cell set *)
  let key = (if iss then "struct " else "union ") ^ n in
  try
    H.find compInfoNameEnv key, false (* Only if not already in *)
  with Not_found -> begin
      (* Create a compinfo. This will have "cdefined" false. *)
      let res =
        Cil_const.mkCompInfo
          iss n ~norig (fun _ -> None) (fc_stdlib_attribute [])
      in
      H.add compInfoNameEnv key res;
      res, true
    end

(* Create the self ref cell and add it to the map. Return an indication
 * whether this is a new one. *)
let createEnumInfo (n: string) ~(norig:string) : enuminfo * bool =
  (* Add to the self cell set *)
  try
    H.find enumInfoNameEnv n, false (* Only if not already in *)
  with Not_found -> begin
      (* Create a enuminfo *)
      let enum =
        { eorig_name = norig; ename = n; eitems = [];
          eattr = fc_stdlib_attribute []; ereferenced = false; ekind = IInt ; }
      in
      H.add enumInfoNameEnv n enum;
      enum, true
    end


(* kind is either "struct" or "union" or "enum" and n is a name *)
let findCompType ghost kind name attr =
  let makeForward () =
    (* This is a forward reference, either because we have not seen this
     * struct already or because we want to create a version with different
     * attributes  *)
    if kind = "enum" then
      let enum, isnew = createEnumInfo name ~norig:name in
      if isnew then
        cabsPushGlobal (GEnumTagDecl (enum, CurrentLoc.get ()));
      TEnum (enum, attr)
    else
      let iss = if kind = "struct" then true else false in
      let self, isnew = createCompInfo iss name ~norig:name in
      if isnew then
        cabsPushGlobal (GCompTagDecl (self, CurrentLoc.get ()));
      TComp (self, attr)
  in
  try
    let old, _ = lookupTypeNoError ghost kind name in (* already defined  *)
    let olda = typeAttrs old in
    let equal =
      try List.for_all2 Cil_datatype.Attribute.equal olda attr
      with Invalid_argument _ -> false
    in
    if equal then old else makeForward ()
  with Not_found -> makeForward ()


(* A simple visitor that searches a statement for labels *)
class canDropStmtClass pRes = object
  inherit nopCilVisitor

  method! vstmt s =
    if s.labels != [] then
      (pRes := false; SkipChildren)
    else
    if !pRes then DoChildren else SkipChildren

  method! vinst _ = Cil.SkipChildren
  method! vexpr _ = Cil.SkipChildren

end
let canDropStatement (s: stmt) : bool =
  let pRes = ref true in
  let vis = new canDropStmtClass pRes in
  ignore (visitCilStmt vis s);
  !pRes

let fail_if_incompatible_sizeof ~ensure_complete op typ =
  if Cil.isFunctionType typ && Cil.theMachine.theMachine.sizeof_fun < 0 then
    Kernel.error ~current:true "%s called on function %s" op
      (Cil.allowed_machdep "GCC");
  let is_void = Cil.isVoidType typ in
  if is_void && Cil.theMachine.theMachine.sizeof_void < 0 then
    Kernel.error ~current:true "%s on void type %s" op
      (Cil.allowed_machdep "GCC/MSVC");
  if ensure_complete && not (Cil.isCompleteType typ) && not is_void then
    Kernel.error ~current:true
      "%s on incomplete type '%a'" op Cil_datatype.Typ.pretty typ

(******** CASTS *********)

let arithmeticConversion = Cil.arithmeticConversion

let integralPromotion = Cil.integralPromotion

(* C99 6.3.2.1:2: l-values used as r-values lose their qualifier. By default,
   we drop qualifiers, and recover them for the few operators that are
   exceptions, also listed in 6.3.2.1:2 *)
let dropQualifiers = Cil.type_remove_qualifier_attributes

(* true if the expression is known to be a boolean result, i.e. 0 or 1. *)
let rec is_boolean_result e =
  match e.enode with
  | Const _ ->
    (match Cil.isInteger e with
     | Some i ->
       Integer.equal i Integer.zero || Integer.equal i Integer.one
     | None -> false)
  | CastE (_,e) -> is_boolean_result e
  | BinOp((Lt | Gt | Le | Ge | Eq | Ne | LAnd | LOr),_,_,_) -> true
  | BinOp((PlusA | PlusPI | MinusA | MinusPI | MinusPP | Mult
          | Div | Mod | Shiftlt | Shiftrt | BAnd | BXor | BOr),_,_,_) -> false
  | UnOp(LNot,_,_) -> true
  | UnOp ((Neg | BNot),_,_) -> false
  | Lval _ | SizeOf _ | SizeOfE _ | SizeOfStr _ | AlignOf _
  | AlignOfE _ | AddrOf _ | StartOf _ -> false

(* Like Cil.mkCastT, but it calls typeForInsertedCast *)
let makeCastT ~(e: exp) ~(oldt: typ) ~(newt: typ) =
  if need_cast oldt newt then
    Cil.mkCastT ~oldt ~newt:(!typeForInsertedCast e oldt newt) e
  else e

let makeCast ~(e: exp) ~(newt: typ) =
  makeCastT ~e ~oldt:(typeOf e) ~newt

let is_scalar_type t =
  match unrollType t with
  | TInt _
  | TPtr _
  | TEnum _
  | TFloat _ -> true
  | _ -> false

(* A cast that is used for conditional expressions. Pointers are Ok.
   Abort if invalid *)
let checkBool (ot : typ) (_ : exp) =
  if not (is_scalar_type ot) then
    Kernel.fatal ~current:true "castToBool %a" Cil_datatype.Typ.pretty ot

(* Evaluate constants to CTrue (non-zero) or CFalse (zero) *)
let rec isConstTrueFalse c: [ `CTrue | `CFalse ] =
  match c with
  | CInt64 (n,_,_) ->
    if Integer.equal n Integer.zero then `CFalse else `CTrue
  | CChr c ->
    if Char.code c = 0 then `CFalse else `CTrue
  | CStr _ | CWStr _ -> `CTrue
  | CReal(f, _, _) ->
    if f = 0.0 then `CFalse else `CTrue
  | CEnum {eival = e} ->
    match isExpTrueFalse e with
    | `CTrue | `CFalse as r -> r
    | `CUnknown -> Kernel.fatal ~current:true "Non-constant enum"
(* Evaluate expressions to `CTrue, `CFalse or `CUnknown *)
and isExpTrueFalse e: [ `CTrue | `CFalse | `CUnknown ] =
  match e.enode with
  | Const c -> (isConstTrueFalse c :> [ `CTrue | `CFalse | `CUnknown ])
  | CastE _ -> begin (* Do not ignore the cast, because of possible overflows.
                        However, calling constFoldToInt might make some UB disappear... *)
      match Cil.constFoldToInt e with
      | None -> `CUnknown
      | Some i ->
        if Integer.(equal zero i) then `CFalse else `CTrue
    end
  | _ -> `CUnknown

let rec isCabsZeroExp e = match e.expr_node with
  | CAST (_, ie) ->
    (match ie with
     | SINGLE_INIT e -> isCabsZeroExp e
     | NO_INIT | COMPOUND_INIT _ -> false)
  | CONSTANT (CONST_INT i) ->
    Result.fold ~error:(fun _ -> false) ~ok:Integer.is_zero (Cil.parseIntRes i)
  | _ -> false

module BlockChunk =
struct
  type chunk = {
    stmts: (stmt * lval list * lval list * lval list * stmt ref list) list;
    (* statements of the chunk.

       This list is built on reverse order.

       Each statements comes with the list of
       pending modified, written and read values.
       The first category represents values which are to be modified during
       the execution of the chunk and whose new value depends on the
       statement (hence, it is legal to read them). They are removed
       syntactically from the list of reads, but we keep them to avoid
       spurious warnings in presence of aliases.
       The order of the write is supposed to be
       fixed at this level.
       We also maintain a list of function calls inside the chunk.
       E.g. for G[i] = j, the written lval is G[i], and the read lval are
       G, i, and j.
    *)

    unspecified_order:bool; (* order of evaluation of statements in the
                               chunk is unspecified.
                            *)
    locals: varinfo list; (* variables that are local to the chunk. *)
    statics: varinfo list; (* static variables whose syntactic scope is the
                              current chunk. *)
    cases: stmt list;                 (* A list of case statements
                                       * (statements with Case labels)
                                       * visible at the outer level *)
  }

  let d_stmt_chunk fmt (s,modified,write,reads,calls) =
    Format.fprintf fmt "@[<v 0>/*@[(%a) %a@ <-@ %a@]@;Calls:@;%a@;*/@;%a@]"
      (Pretty_utils.pp_list ~sep:",@ " Cil_printer.pp_lval) modified
      (Pretty_utils.pp_list ~sep:",@ " Cil_printer.pp_lval) write
      (Pretty_utils.pp_list ~sep:",@ " Cil_printer.pp_lval) reads
      (Pretty_utils.pp_list ~sep:",@ "
         (fun fmt x -> Cil_printer.pp_stmt fmt !x)) calls
      Cil_printer.pp_stmt s

  let d_chunk fmt (c: chunk) =
    Format.fprintf fmt "@[<v 0>@[%a%a@\n%a@]@;@[<v 2>{%a@]}@]"
      (fun fmt b -> if b then Format.fprintf fmt "/* UNDEFINED ORDER */@\n")
      c.unspecified_order
      (Pretty_utils.pp_list ~sep:";" Cil_printer.pp_varinfo) c.locals
      (Pretty_utils.pp_list ~sep:";" Cil_printer.pp_varinfo) c.statics
      (Pretty_utils.pp_list ~sep:";@\n" d_stmt_chunk)
      (List.rev c.stmts)

  let empty =
    { stmts = []; cases = []; locals = []; statics = [];
      unspecified_order = false; }

  let empty_stmts l =
    let rec is_empty_stmt s =
      match s.skind with
      | Instr (Skip _) -> s.labels = [] && s.sattr = []
      | Block b -> b.battrs = [] && List.for_all is_empty_stmt b.bstmts
      | UnspecifiedSequence seq ->
        List.for_all is_empty_stmt (List.map (fun (x,_,_,_,_) -> x) seq)
      | _ -> false
    in
    List.for_all is_empty_stmt (List.map (fun (x,_,_,_,_) -> x) l)

  let isEmpty c = empty_stmts c.stmts

  let isNotEmpty c = not (isEmpty c)

  let i2c (i,m,w,r) =
    let c = match i.skind with
      | Instr(Call _ | Local_init(_, ConsInit _, _)) -> [ref i]
      | _ -> []
    in
    { empty with stmts = [i,m,w,r,c]; }

  (* Keep track of the gotos *)
  let backPatchGotos : (string, stmt ref list ref) H.t = H.create 17
  let addGoto (lname: string) (bref: stmt ref) : unit =
    let gotos =
      try
        H.find backPatchGotos lname
      with Not_found -> begin
          let gotos = ref [] in
          H.add backPatchGotos lname gotos;
          gotos
        end
    in
    gotos := bref :: !gotos

  (* Keep track of the labels *)
  let labelStmt : (string, stmt) H.t = H.create 17
  let initLabels () =
    H.clear backPatchGotos;
    H.clear labelStmt

  let resolveGotos () =
    H.iter
      (fun lname gotos ->
         try
           let dest = H.find labelStmt lname in
           List.iter (fun gref -> gref := dest) !gotos;
           (* Format.eprintf "Label %s associated to %a@." lname d_stmt dest*)
         with Not_found -> begin
             Kernel.error ~once:true ~current:true "Label %s not found" lname
           end)
      backPatchGotos

  module Logic_labels = struct
    (* On the contrary to C, use of labels in the logic
       obeys block scope rules. We keep track of these scopes here.
    *)
    let labels: (string, stmt) H.t = H.create 7
    (* label held by the current statement. *)
    let label_current = ref []
    let add_current_label s = label_current := s::!label_current
    (* Don't remove all current label at once, as there might be some
       labels on nested statements. See bts 1536. *)
    let reset_current_label () =
      label_current:= List.tl !label_current

    let scope = Stack.create ()
    let enter_scope () = Stack.push (ref []) scope
    let exit_scope () =
      let scope_labels = Stack.pop scope in
      List.iter (H.remove labels) !scope_labels

    let add_label l stmt =
      let scope = Stack.top scope in
      scope := l::!scope;
      H.add labels l stmt

    let find_label s =
      try
        ref (H.find labels s)
      with Not_found when List.mem s !label_current ->
        (* just a placeholder that will never be used. no need to
           check for ghost status here. *)
        let my_stmt =
          mkEmptyStmt ~ghost:false ~valid_sid ~loc:(cabslu "_find_label") ()
        in
        my_stmt.labels <- [Label(s,cabslu "_find_label",true)];
        let my_ref = ref my_stmt in
        addGoto s my_ref; my_ref
  end

  let add_label l labstmt =
    Logic_labels.add_label l labstmt;
    H.add labelStmt l labstmt

  (* transforms a chunk into a block. Note that if the chunk has its
     unspecified_order flag set, the resulting block contains a single
     UnspecifiedSequence statement.
     If the chunk consists in a single block, this block will get returned
     directly, unless collapse_block is set to false.
     By default, the block is scoping. If force_non_scoping is true
     (and the block does not not declare anything by itself), it is made
     non-scoping.
  *)
  let c2block ~ghost ?(collapse_block=true) ?(force_non_scoping=false) c =
    let declares_var = c.locals <> [] || c.statics <> [] in
    let vars = ref [] in
    let cleanup_types =
      object
        val replacements = Cil_datatype.Varinfo.Hashtbl.create 3
        inherit Cil.nopCilVisitor
        method! vvrbl vi =
          if List.memq vi c.locals && vi.vdefined then begin
            (* This can happen in particular in a SizeOfE used in the size
               of a declared array. As the actual definition of the referenced
               variable is deported to the Local_init node, we use an undefined
               temp variable instead as placeholder.
            *)
            let vi' =
              match Cil_datatype.Varinfo.Hashtbl.find_opt replacements vi with
              | None ->
                let vi' =
                  newTempVar
                    ~ghost vi.vdecl (vi.vname ^ " initialization") true vi.vtype
                in
                Cil_datatype.Varinfo.Hashtbl.add replacements vi vi';
                vars := vi' :: !vars;
                vi'
              | Some vi' -> vi'
            in
            ChangeTo vi'
          end else SkipChildren
      end
    in
    let cleanup_var vi =
      Cil.update_var_type vi (Cil.visitCilType cleanup_types vi.vtype)
    in
    List.iter cleanup_var c.locals;
    !currentFunctionFDEC.slocals <- !currentFunctionFDEC.slocals @ !vars;
    let vars = !vars @ c.locals in
    if c.unspecified_order then begin
      if List.length c.stmts >= 2 then begin
        let first_stmt =
          (fun (s,_,_,_,_) -> s) (Extlib.last c.stmts) in
        Kernel.warning ~wkey:Kernel.wkey_cert_exp_10
          ~source:(fst (Stmt.loc first_stmt))
          "Potential unsequenced side-effects"
      end;
      let b =
        Cil.mkBlock
          [mkStmt ~ghost ~valid_sid (UnspecifiedSequence (List.rev c.stmts))]
      in
      b.blocals <- vars;
      b.bstatics <- c.statics;
      b.bscoping <- declares_var || not force_non_scoping;
      b
    end else
      match c.stmts with
      | [{ skind = Block b } as s,_,_,_,_] when
          collapse_block && s.labels = []
          && (ghost = s.ghost || Cil.is_ghost_else b) ->
        b.blocals <- vars @ b.blocals;
        b.bstatics <- c.statics @ b.bstatics;
        b.bscoping <- b.bscoping || declares_var || not force_non_scoping;
        b
      | stmts ->
        let stmts = List.rev_map (fun (s,_,_,_,_) -> s) stmts in
        let b = Cil.mkBlock stmts in
        b.blocals <- vars;
        b.bstatics <- c.statics;
        b.bscoping <- declares_var || not force_non_scoping;
        b

  (* converts a chunk into a statement. *)
  let c2stmt ~ghost ?force_non_scoping c =
    let kind =
      if c.unspecified_order then begin
        if List.length c.stmts >= 2 then begin
          let first_stmt =
            (fun (s,_,_,_,_) -> s) (Extlib.last c.stmts) in
          Kernel.warning ~wkey:Kernel.wkey_cert_exp_10
            ~source:(fst (Stmt.loc first_stmt))
            "Potential unsequenced side-effects" end;
        let kind = UnspecifiedSequence (List.rev c.stmts) in
        if c.locals <> [] || c.statics <> [] then begin
          let b = Cil.mkBlock [mkStmt ~ghost ~valid_sid kind] in
          b.blocals <- c.locals;
          b.bstatics <- c.statics;
          Block b
        end else kind
      end else
        let block = c2block ~ghost ?force_non_scoping c in Block block
    in
    mkStmt ~ghost ~valid_sid kind

  let merge_effects (m1,w1,r1,c1) (m2,w2,r2,c2) =
    let add_uniq l x =
      if List.exists (Lval.equal x) l then l else x::l
    in
    List.fold_left add_uniq m1 m2,
    List.fold_left add_uniq w1 w2,
    List.fold_left add_uniq r1 r2,
    c1 @ c2

  let get_chunk_effects c =
    List.fold_left
      (fun c (_,x,y,z,t) -> merge_effects c (x,y,z,t)) ([],[],[],[]) c.stmts

  (* make a chunk element from a chunk.  *)
  let c2stmt_effect ~ghost c =
    let modified, writes, reads, calls = get_chunk_effects c in
    let stmt = c2stmt ~ghost ~force_non_scoping:true c in
    (stmt, modified, writes, reads, calls)

  let unspecified_chunk c = (* c *)
    (* to restore previous behavior (where unspecified evaluation order
       was not explicitly marked), comment out the line below and make
       unspecified_chunk the identity function.
    *)
    { c with unspecified_order = true }

  let local_var_chunk c v = { c with locals = v::c.locals }

  let static_var_chunk c v = { c with statics = v :: c.statics }

  let visit_chunk vis c =
    List.iter
      (fun (stmt, _, _, _, _) -> ignore (Cil.visitCilStmt vis stmt))
      c.stmts

  let remove_locals l =
    !currentFunctionFDEC.slocals <-
      List.filter
        (fun x -> not (List.exists (Cil_datatype.Varinfo.equal x) l))
        !currentFunctionFDEC.slocals

  let clean_up_block_locals (s, _, _, _, _) =
    let vis =
      object
        inherit Cil.nopCilVisitor
        method! vblock b = remove_locals b.blocals; DoChildren
      end
    in
    ignore (Cil.visitCilStmt vis s)

  (* if we're about to drop a chunk, clean up locals of current func. *)
  let clean_up_chunk_locals c =
    remove_locals c.locals;
    List.iter clean_up_block_locals c.stmts

  (* Gathers locals of blocks. *)
  class locals_visitor () = object
    inherit Cil.nopCilVisitor

    val mutable locals = []
    method get_locals () = locals

    method !vblock block =
      locals <- block.blocals @ locals;
      Cil.DoChildren
  end

  (* Returns the list of all locals in the chunk [c], including the locals
     of blocks in the list of statements of [c].  *)
  let locals_in_chunk c =
    let locals = c.locals in
    let visitor = new locals_visitor () in
    visit_chunk (visitor :> Cil.cilVisitor) c;
    visitor#get_locals () @ locals

  (* Removes the locals of the chunk [c] (including locals of blocks inside
     the chunk) from the locals of the current function. *)
  let full_clean_up_chunk_locals c =
    let locals = locals_in_chunk c in
    !currentFunctionFDEC.slocals <-
      List.filter
        (fun x -> not (List.exists (Cil_datatype.Varinfo.equal x) locals))
        !currentFunctionFDEC.slocals

  (* removes all labels found in the given chunk from the labels table.
     Use this function when you're about to drop a chunk _and_ you are sure
     that there are no references to such labels outside of the chunk (if there
     are, you should not drop it in the first place). Primarily used for
     dropping side-effects from sizeof of related C expressions, in which
     the only labels that might occur are generated by cabs2cil itself and
     are completely internal.
  *)
  let full_clean_up_chunk_labels c =
    let vis = object
      inherit Cil.nopCilVisitor
      method! vstmt s =
        List.iter
          (function
            | Label (s,_,_) ->
              H.remove labelStmt s;
              H.remove backPatchGotos s
            | Case _ | Default _ -> ())
          s.labels;
        Cil.DoChildren
    end
    in
    visit_chunk vis c

  (* drop the side effects coming from the given expression and takes care
     of cleaning the global environment (labels tables and locals list of
     the current function). First argument is used in the warning to indicate
     which construction is dropping side effects
  *)
  let drop_chunk ctxt c e e' =
    if isNotEmpty c then begin
      Kernel.feedback
        ~once:true ~current:true "Dropping side-effect in %s." ctxt;
      IgnoreSideEffectHook.apply (e, e');
      full_clean_up_chunk_labels c;
      let kept_vars, thrown_vars =
        List.partition (fun x -> Cil.appears_in_expr x e') c.locals
      in
      full_clean_up_chunk_locals {c with locals = thrown_vars};
      { empty with locals = kept_vars }
    end else empty

  (* Add a statement at the end. Never refer to this statement again
   * after you call this *)
  let (+++) (c: chunk) (i,m,w,r) =
    let call = match i.skind with
      | Instr (Call _ | Local_init (_, ConsInit _, _)) -> [ref i]
      | _ -> []
    in
    {c with stmts = (i,m,w,r,call) :: c.stmts; }

  (* Append two chunks. Never refer to the original chunks after you call
   * this. And especially never share c2 with somebody else *)
  let (@@) (c1: chunk) (c2, ghost) =
    let r =
      if (c1.unspecified_order && c2.unspecified_order) ||
         (not c1.unspecified_order && not c2.unspecified_order)
      then
        { stmts = c2.stmts @ c1.stmts;
          cases = c1.cases @ c2.cases;
          locals = c1.locals @ c2.locals;
          statics = c1.statics @ c2.statics;
          unspecified_order = c1.unspecified_order;
        }
      else
        match c2.stmts with
        | [] ->
          (match c2.locals, c2.statics with
           | [],[] -> c1
           | ll, ls ->
             { c1 with
               locals = c1.locals @ ll ;
               statics = c1.statics @ ls })
        | [{skind = UnspecifiedSequence l} as s,_,_,_,_]
          when c1.unspecified_order ->
          let stmts =
            match l, s.labels with
            | [],[] -> []
            | [], _ ->
              let s' = mkStmtOneInstr (Skip (Cil_datatype.Stmt.loc s)) in
              s'.labels <- s.labels;
              [s,[],[],[],[]]
            | (h,_,_,_,_)::_, _ ->
              h.labels <- h.labels @ s.labels; l
          in
          { stmts = List.rev_append stmts c1.stmts;
            cases = c1.cases @ c2.cases;
            locals = c1.locals @ c2.locals;
            statics = c1.statics @ c2.statics;
            unspecified_order = c1.unspecified_order; }
        | [s] ->
          { stmts = s :: c1.stmts;
            cases = c1.cases @ c2.cases;
            locals = c1.locals @ c2.locals;
            statics = c1.statics @ c2.statics;
            unspecified_order = c1.unspecified_order;
          }
        | _ ->
          let locals = c1.locals @ c2.locals in
          let statics = c1.statics @ c2.statics in
          (* the lifespan of the locals is the whole chunk,
             not just c2, which may be transformed artificially
             in a block at this point. Likewise, the syntactic scope of
             static local variables is the whole chunk.
          *)
          let c2 = { c2 with locals = []; statics = [] } in
          { stmts = c2stmt_effect ~ghost c2 :: c1.stmts;
            cases = c1.cases @ c2.cases;
            locals; statics;
            unspecified_order = c1.unspecified_order;
          }
    in
    Kernel.debug ~dkey:Kernel.dkey_typing_chunk
      "Concat:@\n%a@\nWITH@\n%a@\nLEADS TO@\n%a@."
      d_chunk c1 d_chunk c2 d_chunk r;
    r

  let remove_reads lv c =
    Kernel.debug ~dkey:Kernel.dkey_typing_chunk
      "Removing %a from chunk@\n%a@."
      Cil_printer.pp_lval lv d_chunk c;
    let remove_list =
      List.filter (fun x -> not (LvalStructEq.equal lv x))
    in
    let remove_from_reads =
      List.map (fun (s,m,w,r,c) -> (s,lv::m,w,remove_list r,c)) in
    let res =
      { c with stmts = remove_from_reads c.stmts; }
    in
    (* Format.eprintf "Result is@\n%a@." d_chunk res; *)
    res

  let remove_effects_stmt (s,_,_,_,_) = (s,[],[],[],[])

  let remove_effects c =
    { c with stmts = List.map remove_effects_stmt c.stmts }

  (* the chunks below are used in statements translation. Hence,
     their order of evaluation is always specified, and we can forget their
     effects.
  *)

  let skipChunk = empty

  (* return can be ghost but only in ghost functions *)
  let returnChunk ~ghost e (l: location) : chunk =
    { stmts = [ mkStmt ~ghost ~valid_sid (Return(e, l)),[],[],[],[] ];
      cases = [];
      locals = [];
      statics = [];
      unspecified_order = false;
    }

  let ifChunk ~ghost be (l: location) (t: chunk) (e: chunk) : chunk =
    let effects_t = get_chunk_effects t in
    let effects_e = get_chunk_effects e in
    let (m,r,w,c) = merge_effects effects_t effects_e in
    let stmt =
      mkStmt ~ghost ~valid_sid (If(be, c2block ~ghost t, c2block ~ghost e, l))
    in
    { stmts = [ stmt ,m,r,w,c ];
      cases = t.cases @ e.cases;
      locals = [];
      statics = [];
      unspecified_order = false;
    }

  let keepPureExpr ~ghost e loc =
    let fundec = !currentFunctionFDEC in
    let s = Cil.mkPureExpr ~ghost ~fundec ~loc e in
    match s.skind with
    | Block b ->
      { empty with
        stmts = List.map (fun s -> (s,[],[],[],[])) b.bstmts;
        locals = b.blocals }
    | _ ->i2c (s,[],[],[])

  (* We can duplicate a chunk if it has a few simple statements, and if
   * it does not have cases, locals or statics *)
  let duplicateChunk (c: chunk) = (* raises Failure if you should not
                                   * duplicate this chunk *)
    if not (Kernel.AllowDuplication.get ()) then
      raise (Failure "cannot duplicate: disallowed by user");
    if c.locals !=[] then
      raise (Failure "cannot duplicate: has locals");
    if c.statics != [] then
      raise (Failure "cannot duplicate: has static locals");
    if c.cases != [] then raise (Failure "cannot duplicate: has cases") else
      let pCount = ref 0 in
      let duplicate_stmt (s,m,w,r,c) =
        if s.labels != [] then
          raise (Failure "cannot duplicate: has labels");
        (match s.skind with
         | If _ | Switch _ | Loop _ | Block _ | UnspecifiedSequence _
         | TryCatch _ | Throw _ | TryFinally _ | TryExcept _
           ->
           raise (Failure "cannot duplicate: complex stmt")
         | Instr _ | Goto _ | Return _ | Break _ | Continue _ ->
           incr pCount);
        if !pCount > 5 then raise
            (Failure ("cannot duplicate: too many instr"));
        (* We can just copy it because there is nothing to share here.
         * Except maybe for the ref cell in Goto but it is Ok to share
         * that, I think *)
        let s' = { s with sid = s.sid} in
        let c = match s.skind with
          | Instr (Call _ | Local_init (_, ConsInit _, _)) -> [ref s']
          | Instr _ | TryExcept _ | TryFinally _ | TryCatch _ | Throw _
          | UnspecifiedSequence _| Block _| Loop (_, _, _, _, _)
          | Switch (_, _, _, _)| If (_, _, _, _)| Continue _| Break _
          | Goto (_, _)| Return (_, _) -> assert (c = []); []
        in
        (s',m,w,r,c)
      in
      { stmts = List.map duplicate_stmt c.stmts;
        cases = []; unspecified_order = c.unspecified_order;
        locals = []; statics = [];
      }

  (* We can drop a chunk if it does not have labels inside *)
  let canDrop (c: chunk) =
    List.for_all (fun (s,_,_,_,_) -> canDropStatement s) c.stmts

  let loopChunk ~ghost ~sattr a (body: chunk) : chunk =
    (* Make the statement *)
    let loop =
      mkStmt ~ghost ~valid_sid ~sattr
        (Loop (a,c2block ~ghost body, CurrentLoc.get (), None, None))
    in
    { stmts = [ loop,[],[],[],[] ];
      cases = body.cases;
      unspecified_order = false;
      locals = [];
      statics = [];
    }

  (* can be ghost inside a ghost loop *)
  let breakChunk ~ghost (l: location) : chunk =
    { stmts = [ mkStmt ~ghost ~valid_sid (Break l),[],[],[],[] ];
      cases = [];
      unspecified_order = false;
      locals = [];
      statics = [];
    }

  (* can be ghost inside a ghost loop *)
  let continueChunk ~ghost (l: location) : chunk =
    { stmts = [ mkStmt ~ghost ~valid_sid (Continue l),[],[],[],[] ];
      cases = [];
      unspecified_order = false;
      locals = [];
      statics = [];
    }

  (* Get the first statement in a chunk. Might need to change the
   * statements in the chunk *)
  let getFirstInChunk ~ghost ~loc c =
    (* Get the first statement and add the label to it *)
    match c.stmts with
    | [] -> (* Add a statement *)
      let n = mkEmptyStmt ~ghost ~valid_sid ~loc () in
      n, [n,[],[],[],[]]
    | s ->
      let (st,_,_,_,_) = Extlib.last s in
      if not ghost && st.ghost then
        (* non-ghost label in front of a ghost statement. Keep the
           non-ghost status with a Skip.
           Note that the reverse case is not possible:
           /*@ ghost L1: */ stmt; will be directly translated
           by the parser as /*@ ghost L1: ; */ stmt;
        *)
        begin
          let n = mkEmptyStmt ~ghost ~valid_sid ~loc () in
          n, s @ [n,[],[],[],[]]
        end else st,s

  (* s2c must not be used during expression translation, as it does not
     take care of the effects of the statement. Use i2c instead.
  *)
  let s2c (s:stmt) : chunk =
    { stmts = [ s,[],[],[],[] ];
      cases = [];
      unspecified_order = false;
      locals = [];
      statics = [];
    }

  let gotoChunk ~ghost (ln: string) (l: location) : chunk =
    let gref = ref dummyStmt in
    addGoto ln gref;
    { stmts = [ mkStmt ~ghost ~valid_sid (Goto (gref, l)),[],[],[],[] ];
      cases = [];
      locals = [];
      statics = [];
      unspecified_order = false;
    }

  let caseRangeChunk ~ghost el loc (next: chunk) =
    let fst, stmts' = getFirstInChunk ~ghost ~loc next in
    let labels = List.map (fun e -> Case (e, loc)) el in
    fst.labels <- labels @ fst.labels;
    { next with stmts = stmts'; cases = fst :: next.cases;
                unspecified_order = false
    }

  let defaultChunk ~ghost loc (next: chunk) =
    let fst, stmts' = getFirstInChunk ~ghost ~loc next in
    let lb = Default loc in
    fst.labels <- lb :: fst.labels;
    { next with stmts = stmts'; cases = fst :: next.cases;
                unspecified_order = false
    }

  let switchChunk ~ghost (e: exp) (body: chunk) (l: location) =
    (* Make the statement *)
    let defaultSeen = ref false in
    let t = typeOf e in
    let checkForDefaultAndCast lb =
      match lb with
      | Default _ as d ->
        if !defaultSeen then
          Kernel.error ~once:true ~current:true
            "Switch statement at %a has duplicate default entries."
            Cil_printer.pp_location l;
        defaultSeen := true;
        d
      | Label _ as l -> l
      | Case (e, loc) ->
        (* If needed, convert e to type t, and check in case the label
           was too big *)
        let e' = makeCast ~e ~newt:t in
        let constFold = constFold true in
        let e'' = if theMachine.lowerConstants then constFold e' else e' in
        (match constFoldToInt e, constFoldToInt e'' with
         | Some i1, Some i2 when not (Integer.equal i1 i2) ->
           Kernel.feedback ~once:true ~source:(fst e.eloc)
             "Case label %a exceeds range of %a for switch expression. \
              Nothing to worry."
             Cil_printer.pp_exp e Cil_datatype.Typ.pretty t;
         | _ -> ()
        );
        Case (e'', loc)
    in
    let block = c2block ~ghost body in
    let cases = (* eliminate duplicate entries from body.cases. A statement
                   is added to body.cases for each case label it has. *)
      List.fold_right
        (fun s acc ->
           if List.memq s acc then acc
           else begin
             s.labels <- List.map checkForDefaultAndCast s.labels;
             s::acc
           end)
        body.cases
        []
    in
    let switch = mkStmt ~ghost ~valid_sid (Switch (e, block, cases, l)) in
    { stmts = [ switch,[],[],[],[] ];
      cases = [];
      locals = [];
      statics = [];
      unspecified_order = false;
    }

  exception Found

  let find_stmt b l s =
    let find = object
      inherit Cil.nopCilVisitor
      method! vstmt s' =
        if s == s' then begin
          (*Format.eprintf "Label %s is in the AST@." l;*)
          raise Found
        end else DoChildren
    end in
    try
      ignore (visitCilBlock find b);
      Kernel.warning ~current:true
        "Inconsistent AST: Statement %a,@ with label %s is not in the AST"
        Cil_printer.pp_stmt s l;
    with Found -> ()

  class cleanUnspecified =
    let is_annot_next_stmt = function
      | [] -> false
      | { skind = Instr (Code_annot (c,_)) } :: _ ->
        Logic_utils.is_annot_next_stmt c
      | _ -> false
    in
    object(self)
      inherit nopCilVisitor
      val unspecified_stack = Stack.create ()

      val mutable replace_table = []

      (* we start in a deterministic block. *)
      initializer Stack.push false unspecified_stack

      method private push: 'a.bool->'a->'a visitAction =
        fun flag x ->
        Stack.push flag unspecified_stack;
        ChangeDoChildrenPost
          (x,fun x -> ignore(Stack.pop unspecified_stack); x)


      method! vblock b =
        b.bstmts <-
          List.rev
            (List.fold_left(
                fun res s ->
                  match s.skind with
                  | Block b when
                      (not (Stack.top unspecified_stack)) &&
                      b.battrs = [] && b.blocals = [] &&
                      s.labels = [] && not (is_annot_next_stmt res)
                    -> List.rev_append b.bstmts res
                  | _ -> s ::res)
                [] b.bstmts);
        DoChildren

      method! vstmt s =
        let ghost = s.ghost in
        let change_label_stmt s s' =
          List.iter
            (function
              | Label (x,_,_) -> H.replace labelStmt x s'
              | Case _ | Default _ -> replace_table <- (s, s') :: replace_table
            ) s.labels;
          s'.labels <- s.labels @ s'.labels
        in
        match s.skind with
        | UnspecifiedSequence [s',_,_,_,_] ->
          change_label_stmt s s';
          ChangeDoChildrenPost(s', fun x -> x)
        | UnspecifiedSequence [] ->
          let s' = mkEmptyStmt ~ghost ~valid_sid ~loc:(cabslu "_useq") () in
          change_label_stmt s s';
          ChangeTo s';
        | UnspecifiedSequence _ -> self#push true s
        | Block { battrs = []; blocals = []; bstmts = [s']} ->
          change_label_stmt s s';
          ChangeDoChildrenPost (s', fun x -> x)
        | Block _ | If _ | Loop _
        | TryFinally _ | TryExcept _ | Throw _ | TryCatch _ ->
          self#push false s
        | Switch _ ->
          let change_cases stmt =
            match stmt.skind with
            | Switch(e,body,cases,loc) ->
              let newcases =
                List.map
                  (fun s ->
                     try List.assq s replace_table
                     with Not_found -> s)
                  cases
              in
              stmt.skind <- Switch(e,body,newcases,loc);
              ignore (Stack.pop unspecified_stack);
              stmt
            | _ -> assert false
          in Stack.push false unspecified_stack;
          ChangeDoChildrenPost(s,change_cases)
        | Instr _ | Return _ | Goto _ | Break _
        | Continue _ -> DoChildren
    end

  let mkFunctionBody ~ghost (c: chunk) : block =
    if c.cases <> [] then
      Kernel.error ~once:true ~current:true
        "Switch cases not inside a switch statement\n";
    (* cleanup empty blocks and unspecified sequences.
       This can change some labels (the one attached to removed blocks),
       so it has to be done before resolveGotos. *)
    let res = visitCilBlock (new cleanUnspecified) (c2block ~ghost c) in
    H.iter (find_stmt res) labelStmt; resolveGotos (); initLabels (); res

  let add_reads ~ghost loc r c = match r with
    | [] -> c
    | _ :: _ -> c +++ (mkEmptyStmt ~ghost ~valid_sid ~loc (), [],[], r)

end

open BlockChunk

(* To avoid generating backward gotos, we treat while loops as non-while ones,
 * adding a marker for continue. (useful for Jessie) *)
let doTransformWhile = ref false

let setDoTransformWhile () = doTransformWhile := true

(* To avoid generating forward ingoing gotos, we translate conditionals in
 * an alternate way. (useful for Jessie) *)
let doAlternateConditional = ref false

let setDoAlternateConditional () = doAlternateConditional := true

(************ Labels ***********)
(* Since we turn dowhile and for loops into while we need to take care in
 * processing the continue statement. For each loop that we enter we place a
 * marker in a list saying what kinds of loop it is. When we see a continue
 * for a Non-while loop we must generate a label for the continue *)

type loopstate =
    While of string ref
  | NotWhile of string ref

let continues : loopstate list ref = ref []

(* Sometimes we need to create new label names *)
let newLabelName ghost base = fst (newAlphaName ghost false "label" base)

let continueOrLabelChunk ~ghost (l: location) : chunk =
  match !continues with
  | [] -> abort_context "continue not in a loop"
  | While lr :: _ ->
    if !doTransformWhile then
      begin
        if !lr = "" then begin
          lr := newLabelName ghost "__Cont"
        end;
        gotoChunk ~ghost !lr l
      end
    else continueChunk ~ghost l
  | NotWhile lr :: _ ->
    if !lr = "" then begin
      lr := newLabelName ghost "__Cont"
    end;
    gotoChunk ~ghost !lr l

(* stack of statements inside which break instruction can be found. *)
let break_env = Stack.create ()

let enter_break_env () = Stack.push () break_env

let breakChunk ~ghost l =
  if Stack.is_empty break_env then
    abort_context "break outside of a loop or switch";
  breakChunk ~ghost l

let exit_break_env () =
  if Stack.is_empty break_env then
    Kernel.fatal ~current:true
      "trying to exit a breakable env without having entered it";
  ignore (Stack.pop break_env)

(* In GCC we can have locally declared labels. *)
let genNewLocalLabel ghost l =
  (* Call the newLabelName to register the label name in the alpha conversion
   * table. *)
  let l' = newLabelName ghost l in
  (* Add it to the environment *)
  addLocalToEnv ghost (kindPlusName "label" l) (EnvLabel l');
  l'

let lookupLabel ghost l =
  try
    let env = if ghost then ghost_env else env in
    match Datatype.String.Hashtbl.find env (kindPlusName "label" l) with
    | EnvLabel l', _ -> l'
    | _ -> raise Not_found
  with Not_found -> l

class gatherLabelsClass : Cabsvisit.cabsVisitor = object (self)
  inherit Cabsvisit.nopCabsVisitor

  (* We have to know if a label is local to know if it is an error if
   * another label with the same name exists. But a local label can be
   * declared multiple times at different nesting depths. Since a
   * Hashtbl can maintain multiple mappings, we add and remove local
   * labels as we visit their blocks. We map each local label to a
   * location option indicating where it was defined (if it has been).
   * This enables us to raise an error if a local label is defined
   * twice, and we can issue warnings if local labels are declared but
   * never defined. *)
  val localLabels : (string, location option) H.t = H.create 5

  method private addLocalLabels blk =
    List.iter (fun lbl -> H.add localLabels lbl None) blk.blabels
  method private removeLocalLabels blk =
    List.iter
      (fun lbl ->
         if H.find localLabels lbl = None then
           Kernel.warning ~current:true
             "Local label %s declared but not defined" lbl;
         H.remove localLabels lbl)
      blk.blabels

  method! vblock blk =
    (* Add the local labels, process the block, then remove the local labels *)
    self#addLocalLabels blk;
    ChangeDoChildrenPost (blk, fun _ -> (self#removeLocalLabels blk; blk))

  method! vstmt s =
    CurrentLoc.set (get_statementloc s);
    (match s.stmt_node with
     | LABEL (lbl,_,_) ->
       (try
          (match H.find localLabels lbl with
           | Some oldloc ->
             Kernel.error ~once:true ~current:true
               "Duplicate local label '%s' (previous definition was at %a)"
               lbl Cil_printer.pp_location oldloc
           | None ->
             (* Mark this label as defined *)
             H.replace localLabels lbl (Some (CurrentLoc.get())))
        with Not_found -> (* lbl is not a local label *)
          let newname, oldloc =
            newAlphaName s.stmt_ghost false "label" lbl
          in
          if newname <> lbl then
            Kernel.error ~once:true ~current:true
              "Duplicate label '%s' (previous definition was at %a)"
              lbl Cil_printer.pp_location oldloc)
     | _ -> ());
    DoChildren
end


(* Enter all the labels into the alpha renaming table to prevent
   duplicate labels when unfolding short-circuiting logical operators
   and when creating labels for (some) continue statements. *)
class registerLabelsVisitor = object
  inherit Cabsvisit.nopCabsVisitor

  method! vstmt s =
    let currentLoc = convLoc (Cabshelper.get_statementloc s) in
    (match s.stmt_node with
     | Cabs.LABEL (lbl,_,_) ->
       Alpha.registerAlphaName ~alphaTable
         ~lookupname:(kindPlusName "label" lbl) ~data:currentLoc
     | _ -> ());
    DoChildren
end



(* Maps local variables that are variable sized arrays to the expression that
 * denotes their length *)
let varSizeArrays : exp IH.t = IH.create 17

(**** EXP actions ***)
type expAction =
    ADrop                               (* Drop the result. Only the
                                         * side-effect is interesting *)
  | AType                               (* Only the type of the result
                                           is interesting.  *)
  | ASet of bool * lval * lval list * typ
  (* Put the result in a given lval,
   * provided it matches the type. The
   * type is the type of the lval.
   * the flag indicates whether this
   * should be considered in the
   * effects of current
   * chunk.
   * The lval list is the list of location that are read to evaluate
   * the location of the lval.
   * The location of lval is guaranteed
   * not to depend on its own value,
   * e.g. p[p[0]] when p[0] is initially
   * 0, so the location won't change
   * after assignment.
  *)
  | AExp of typ option                  (* Return the exp as usual.
                                         * Optionally we can specify an
                                         * expected type. This is useful for
                                         * constants. The expected type is
                                         * informational only, we do not
                                         * guarantee that the converted
                                         * expression has that type.You must
                                         * use a doCast afterwards to make
                                         * sure. *)
  | AExpLeaveArrayFun                   (* Do it like an expression, but do
                                         * not convert arrays of functions
                                         * into pointers *)


type expConst =
  | CConst
  | CMayConst
  | CNoConst

(*** Result of compiling conditional expressions *)
type condExpRes =
    CEExp of chunk * exp (* Do a chunk and then an expression *)
  | CEAnd of condExpRes * condExpRes
  | CEOr  of condExpRes * condExpRes
  | CENot of condExpRes

let rec clean_up_cond_locals =
  function
  | CEAnd(ce1, ce2) | CEOr(ce1, ce2) ->
    clean_up_cond_locals ce1; clean_up_cond_locals ce2
  | CENot ce -> clean_up_cond_locals ce
  | CEExp (c,_) -> clean_up_chunk_locals c

(* We have our own version of addAttributes that does not allow duplicates *)
let cabsAddAttributes al0 (al: attributes) : attributes =
  if al0 == [] then al else
    List.fold_left
      (fun acc (Attr(an, _) | AttrAnnot an as a) ->
         (* See if the attribute is already in there *)
         match filterAttributes an acc with
         | [] -> addAttribute a acc (* Nothing with that name *)
         | a' :: _ ->
           if Cil_datatype.Attribute.equal a a' then
             acc (* Already in *)
           else begin
             Kernel.debug ~level:3
               "Duplicate attribute %a along with %a"
               Cil_printer.pp_attribute a Cil_printer.pp_attribute a' ;
             (* let acc' = dropAttribute an acc in *)
             (* Keep both attributes *)
             addAttribute a acc
           end)
      al
      al0

type combineWhat =
    CombineFundef of bool
  (* The new definition is for a function definition. The old
   * is for a prototype. arg is [true] for an old-style declaration *)
  | CombineFunarg of bool
  (* Comparing a function argument type with an old prototype argument.
     arg is [true] for an old-style declaration, which
     triggers some ad hoc treatment in GCC mode. *)
  | CombineFunret (* Comparing the return of a function with that from an old
                   * prototype *)
  | CombineOther

(* [combineAttributes what olda a] combines the attributes in [olda] and [a]
   according to [what]:
   - if [what == CombineFunarg], then override old attributes;
     this is used to ensure that attributes from formal argument types in a
     function definition are not mixed with attributes from arguments in other
     (compatible, but with different qualifiers) declarations;
   - else, perform the union of old and new attributes. *)
let combineAttributes what olda a =
  match what with
  | CombineFunarg _ -> a (* override old attributes with new ones *)
  | _ -> cabsAddAttributes olda a (* union of attributes *)

(* BY: nothing cabs here, plus seems to duplicate most of Cil.typeAddAttributes *)
(* see [combineAttributes] above for details about the [what] argument *)
let rec cabsTypeCombineAttributes what a0 t =
  let combine = combineAttributes what in
  begin
    match a0 with
    | [] ->
      (* no attributes, keep same type *)
      t
    | _ ->
      (* anything else: add a0 to existing attributes *)
      let add (a: attributes) = combine a0 a in
      match t with
      | TVoid a -> TVoid (add a)
      | TInt (ik, a) ->
        (* Here we have to watch for the mode attribute *)
        (* sm: This stuff is to handle a GCC extension where you can request integers*)
        (* of specific widths using the "mode" attribute syntax; for example:     *)
        (*   typedef int int8_t __attribute__ ((__mode__ (  __QI__ ))) ;          *)
        (* The cryptic "__QI__" defines int8_t to be 8 bits wide, instead of the  *)
        (* 32 bits you'd guess if you didn't know about "mode".  The relevant     *)
        (* testcase is test/small2/mode_sizes.c, and it was inspired by my        *)
        (* /usr/include/sys/types.h.                                              *)
        (*                                                                        *)
        (* A consequence of this handling is that we throw away the mode          *)
        (* attribute, which we used to go out of our way to avoid printing anyway.*)
        let ik', a0' =
          (* Go over the list of new attributes and come back with a
           * filtered list and a new integer kind *)
          List.fold_left
            (fun (ik', a0') a0one ->
               match a0one with
               | Attr("mode", [ACons(mode,[])]) -> begin
                   (* (trace "gccwidth" (dprintf "I see mode %s applied to an int type\n"
                                        mode )); *)
                   (* the cases below encode the 32-bit assumption.. *)
                   match (ik', mode) with
                   | (IInt, "__QI__")      -> (IChar, a0')
                   | (IInt, "__byte__")    -> (IChar, a0')
                   | (IInt, "__HI__")      -> (IShort,  a0')
                   | (IInt, "__SI__")      -> (IInt, a0')   (* same as t *)
                   | (IInt, "__word__")    -> (IInt, a0')
                   | (IInt, "__pointer__") -> (IInt, a0')
                   | (IInt, "__DI__")      -> (ILongLong, a0')

                   | (IUInt, "__QI__")     -> (IUChar, a0')
                   | (IUInt, "__byte__")   -> (IUChar, a0')
                   | (IUInt, "__HI__")     -> (IUShort, a0')
                   | (IUInt, "__SI__")     -> (IUInt, a0')
                   | (IUInt, "__word__")   -> (IUInt, a0')
                   | (IUInt, "__pointer__")-> (IUInt, a0')
                   | (IUInt, "__DI__")     -> (IULongLong, a0')

                   | _ ->
                     Kernel.error ~once:true ~current:true
                       "GCC width mode %s applied to unexpected type, \
                        or unexpected mode"
                       mode;
                     (ik', a0one :: a0')

                 end
               | _ -> (ik', a0one :: a0'))
            (ik, [])
            a0
        in
        TInt (ik', combine a0' a)

      | TFloat (fk, a) -> TFloat (fk, add a)
      | TEnum (enum, a) -> TEnum (enum, add a)
      | TPtr (t, a) -> TPtr (t, add a)
      | TFun (t, args, isva, a) -> TFun(t, args, isva, add a)
      | TComp (comp, a) -> TComp (comp, add a)
      | TNamed (t, a) -> TNamed (t, add a)
      | TBuiltin_va_list a -> TBuiltin_va_list (add a)
      | TArray (t, l, a) ->
        let att_elt, att_typ = Cil.splitArrayAttributes a0 in
        TArray (cabsArrayPushAttributes what att_elt t, l,
                combineAttributes what att_typ a)
  end
and cabsArrayPushAttributes what al = function
  | TArray (bt, l, a) ->
    TArray (cabsArrayPushAttributes what al bt, l, a)
  | t -> cabsTypeCombineAttributes what al t

let cabsTypeAddAttributes =
  cabsTypeCombineAttributes CombineOther

exception Cannot_combine of string

(* Do types *)
(* Combine the types. Raises the Cannot_combine exception with an error message.
   [what] is used to recursively deal with function return types and function
   arguments in special ways.
   Note: we cannot force the qualifiers of oldt and t to be the same here,
   because in some cases (e.g. string literals and char pointers) it is
   allowed to have differences, while in others we want to be more strict. *)
let rec combineTypes (what: combineWhat) (oldt: typ) (t: typ) : typ =
  match oldt, t with
  | TVoid olda, TVoid a -> TVoid (combineAttributes what olda a)
  (* allows ignoring a returned value *)
  | _ , TVoid _ when what = CombineFunret -> t
  | TInt (oldik, olda), TInt (ik, a) ->
    let combineIK oldk k =
      if oldk = k then oldk else
        (match what with
         | CombineFunarg b when
             Cil.gccMode () && oldk = IInt
             && bytesSizeOf t <= (bytesSizeOfInt IInt) && b ->
           (* GCC allows a function definition to have a more precise integer
            * type than a prototype that says "int" *)
           k
         | _ ->
           raise (Cannot_combine
                    (Format.asprintf
                       "different integer types:@ '%a' and '%a'"
                       Cil_printer.pp_ikind oldk Cil_printer.pp_ikind k)))
    in
    TInt (combineIK oldik ik, combineAttributes what olda a)
  | TFloat (oldfk, olda), TFloat (fk, a) ->
    let combineFK oldk k =
      if oldk = k then oldk else
        ( match what with
          | CombineFunarg b when
              Cil.gccMode () && oldk = FDouble && k = FFloat && b ->
            (* GCC allows a function definition to have a more precise float
             * type than a prototype that says "double" *)
            k
          | _ ->
            raise (Cannot_combine "different floating point types"))
    in
    TFloat (combineFK oldfk fk, combineAttributes what olda a)
  | TEnum (_, olda), TEnum (ei, a) ->
    TEnum (ei, combineAttributes what olda a)

  (* Strange one. But seems to be handled by GCC *)
  | TEnum (oldei, olda) , TInt(IInt, a) -> TEnum(oldei,
                                                 combineAttributes what olda a)
  (* Strange one. But seems to be handled by GCC *)
  | TInt(IInt, olda), TEnum (ei, a) -> TEnum(ei, combineAttributes what olda a)


  | TComp (oldci, olda) , TComp (ci, a) ->
    if oldci.cstruct <> ci.cstruct then
      raise (Cannot_combine "different struct/union types");
    let comb_a = combineAttributes what olda a in
    if oldci.cname = ci.cname then
      TComp (oldci, comb_a)
    else
      raise (Cannot_combine (Format.sprintf "%ss with different tags"
                               (if oldci.cstruct then "struct" else "union")))

  | TArray (oldbt, oldsz, olda), TArray (bt, sz, a) ->
    let newbt = combineTypes CombineOther oldbt bt in
    let newsz =
      match oldsz, sz with
      | None, Some _ -> sz
      | Some _, None -> oldsz
      | None, None -> sz
      | Some oldsz', Some sz' ->
        (* They are not structurally equal. But perhaps they are equal if we
           evaluate them. Check first machine independent comparison. *)
        let checkEqualSize (machdep: bool) =
          let size_t = Cil.theMachine.Cil.typeOfSizeOf in
          let size_t_oldsz' = Cil.mkCast ~force:false ~newt:size_t oldsz' in
          let size_t_sz' = Cil.mkCast ~force:false ~newt:size_t sz' in
          ExpStructEq.equal
            (constFold machdep size_t_oldsz')
            (constFold machdep size_t_sz')
        in
        if checkEqualSize false then
          oldsz
        else if checkEqualSize true then begin
          Kernel.warning ~current:true
            "Array type comparison succeeds only based on machine-dependent \
             constant evaluation: %a and %a\n"
            Cil_printer.pp_exp oldsz' Cil_printer.pp_exp sz';
          oldsz
        end else
          raise (Cannot_combine "different array lengths")

    in
    TArray (newbt, newsz, combineAttributes what olda a)

  | TPtr (oldbt, olda), TPtr (bt, a) ->
    TPtr (combineTypes CombineOther oldbt bt, combineAttributes what olda a)

  | TFun (oldrt, oldargs, oldva, olda), TFun (rt, args, va, a) ->
    let newrt = combineTypes CombineFunret oldrt rt in
    if oldva != va then
      raise (Cannot_combine "different vararg specifiers");
    (* If one does not have arguments, believe the one with the
     * arguments *)
    let newargs, olda' =
      if oldargs = None then args, olda else
      if args = None then oldargs, olda else
        let (oldargslist, oldghostargslist) = argsToPairOfLists oldargs in
        let (argslist, ghostargslist) = argsToPairOfLists args in
        if List.length oldargslist <> List.length argslist then
          raise (Cannot_combine "different number of arguments")
        else if List.length oldghostargslist <> List.length ghostargslist then
          raise (Cannot_combine "different number of ghost arguments")
        else begin
          let oldargslist = oldargslist @ oldghostargslist in
          let argslist = argslist @ ghostargslist in
          (* Construct a mapping between old and new argument names. *)
          let map = H.create 5 in
          List.iter2
            (fun (on, _, _) (an, _, _) -> H.replace map on an)
            oldargslist argslist;
          (* Go over the arguments and update the old ones with the
           * adjusted types *)
          (* Format.printf "new type is %a@." Cil_datatype.Typ.pretty t; *)
          let what =
            match what with
            | CombineFundef b -> CombineFunarg b
            | _ -> CombineOther
          in
          Some
            (List.map2
               (fun (on, ot, oa) (an, at, aa) ->
                  (* Update the names. Always prefer the new name. This is
                   * very important if the prototype uses different names than
                   * the function definition. *)
                  let n = if an <> "" then an else on in
                  let t = combineTypes what ot at in
                  let a = addAttributes oa aa in
                  (n, t, a))
               oldargslist argslist),
          olda
        end
    in
    (* Drop missingproto as soon as one of the type is a properly declared one*)
    let olda =
      if not (Cil.hasAttribute "missingproto" a) then
        Cil.dropAttribute "missingproto" olda'
      else olda'
    in
    let a =
      if not (Cil.hasAttribute "missingproto" olda') then
        Cil.dropAttribute "missingproto" a
      else a
    in
    TFun (newrt, newargs, oldva, combineAttributes what olda a)

  | TNamed (oldt, olda), TNamed (t, a) when oldt.tname = t.tname ->
    TNamed (oldt, combineAttributes what olda a)

  | TBuiltin_va_list olda, TBuiltin_va_list a ->
    TBuiltin_va_list (combineAttributes what olda a)

  (* Unroll first the new type *)
  | _, TNamed (t, a) ->
    let res = combineTypes what oldt t.ttype in
    cabsTypeCombineAttributes what a res

  (* And unroll the old type as well if necessary *)
  | TNamed (oldt, a), _ ->
    let res = combineTypes what oldt.ttype t in
    cabsTypeCombineAttributes what a res

  | _ -> raise (Cannot_combine
                  (Format.asprintf "different type constructors:@ %a and %a"
                     Cil_datatype.Typ.pretty oldt Cil_datatype.Typ.pretty t))

let get_qualifiers t = Cil.filter_qualifier_attributes (Cil.typeAttrs t)

(* how type qualifiers must be checked *)
type qualifier_check_context =
  | Identical (* identical qualifiers. *)
  | IdenticalToplevel (* ignore at toplevel, use Identical when going under a
                         pointer. *)
  | Covariant (* first type can have const-qualifications
                 the second doesn't have. *)
  | CovariantToplevel
  (* accepts everything for current type, use Covariant when going under a
     pointer. *)
  | Contravariant (* second type can have const-qualifications
                     the first doesn't have. *)
  | ContravariantToplevel
  (* accepts everything for current type, use Contravariant when going under
     a pointer. *)

let qualifier_context_fun_arg = function
  | Identical | IdenticalToplevel -> IdenticalToplevel
  | Covariant | CovariantToplevel -> ContravariantToplevel
  | Contravariant | ContravariantToplevel -> CovariantToplevel

let qualifier_context_fun_ret = function
  | Identical | IdenticalToplevel -> IdenticalToplevel
  | Covariant | CovariantToplevel -> CovariantToplevel
  | Contravariant | ContravariantToplevel -> ContravariantToplevel

let qualifier_context_ptr = function
  | Identical | IdenticalToplevel -> Identical
  | Covariant | CovariantToplevel -> Covariant
  | Contravariant | ContravariantToplevel -> Contravariant

let included_qualifiers ?(context=Identical) a1 a2 =
  let a1 = Cil.filter_qualifier_attributes a1 in
  let a2 = Cil.filter_qualifier_attributes a2 in
  let a1 = Cil.dropAttribute "restrict" a1 in
  let a2 = Cil.dropAttribute "restrict" a2 in
  let a1_no_cv = Cil.dropAttributes ["const"; "volatile"] a1 in
  let a2_no_cv = Cil.dropAttributes ["const"; "volatile"] a2 in
  let is_equal = Cil_datatype.Attributes.equal a1 a2 in
  if is_equal then true
  else begin
    match context with
    | Identical -> false
    | Covariant -> Cil_datatype.Attributes.equal a1_no_cv a2
    | Contravariant -> Cil_datatype.Attributes.equal a1 a2_no_cv
    | CovariantToplevel | ContravariantToplevel | IdenticalToplevel -> true
  end

(* precondition: t1 and t2 must be "compatible" as per combineTypes, i.e.
   you must have called [combineTypes t1 t2] before calling this function. *)
let rec have_compatible_qualifiers_deep ?(context=Identical) t1 t2 =
  match unrollType t1, unrollType t2 with
  | TFun (tres1, Some args1, _, _), TFun (tres2, Some args2, _, _) ->
    have_compatible_qualifiers_deep
      ~context:(qualifier_context_fun_ret context) tres1 tres2 &&
    let context = qualifier_context_fun_arg context in
    List.for_all2 (fun (_, t1', a1) (_, t2', a2) ->
        have_compatible_qualifiers_deep ~context t1' t2' &&
        included_qualifiers ~context a1 a2)
      args1 args2
  | TPtr (t1', a1), TPtr (t2', a2)
  | TArray (t1', _, a1), TArray (t2', _, a2) ->
    (included_qualifiers ~context a1 a2) &&
    let context = qualifier_context_ptr context in
    have_compatible_qualifiers_deep ~context t1' t2'
  | _, _ -> included_qualifiers ~context (Cil.typeAttrs t1) (Cil.typeAttrs t2)

let compatibleTypes ?context t1 t2 =
  let r = combineTypes CombineOther t1 t2 in
  (* C99, 6.7.3 §9: "... to be compatible, both shall have the identically
     qualified version of a compatible type;" *)
  if not (have_compatible_qualifiers_deep ?context t1 t2) then
    raise (Cannot_combine "different qualifiers");
  (* Note: different non-qualifier attributes will be silently dropped. *)
  r

let areCompatibleTypes ?context t1 t2 =
  try
    ignore (compatibleTypes ?context t1 t2); true
  with Cannot_combine _ -> false

(* Specify whether the cast is from the source code *)
let rec castTo ?context ?(fromsource=false)
    (ot : typ) (nt : typ) (e : exp) : (typ * exp ) =
  Kernel.debug ~dkey:Kernel.dkey_typing_cast "@[%t: castTo:%s %a->%a@\n@]"
    Cil.pp_thisloc (if fromsource then "(source)" else "")
    Cil_datatype.Typ.pretty ot Cil_datatype.Typ.pretty nt;
  if not fromsource && not (need_cast ot nt) then begin
    (* Do not put the cast if it is not necessary, unless it is from the
     * source. *)
    Kernel.debug ~dkey:Kernel.dkey_typing_cast "no cast to perform";
    (ot, e)
  end else begin
    let nt = if fromsource then nt else !typeForInsertedCast e ot nt in
    let result = (nt, if theMachine.insertImplicitCasts || fromsource then
                    Cil.mkCastT ~force:true ~oldt:ot ~newt:nt e else e)
    in
    let error s =
      if fromsource then abort_context s else Kernel.fatal ~current:true s
    in
    (*  [BM] uncomment the following line to enable attributes static typing
        ignore (check_strict_attributes true ot nt  && check_strict_attributes false nt ot);*)
    Kernel.debug ~dkey:Kernel.dkey_typing_cast
      "@[castTo: ot=%a nt=%a\n  result is %a@\n@]"
      Cil_datatype.Typ.pretty ot Cil_datatype.Typ.pretty nt
      Cil_printer.pp_exp (snd result);
    (* Now see if we can have a cast here *)
    match Cil.unrollType ot, Cil.unrollType nt with
    | TNamed _, _
    | _, TNamed _ -> Kernel.fatal ~current:true "unrollType failed in castTo"
    | t, TInt(IBool,_) when is_scalar_type t ->
      if is_boolean_result e then result
      else
        nt,
        Cil.mkCastT
          ~oldt:ot ~newt:nt
          (constFold true
             (new_exp  ~loc:e.eloc
                (BinOp(Ne,e,Cil.integer ~loc:e.eloc 0,intType))))
    | TInt(_,_), TInt(_,_) ->
      (* We used to ignore attributes on integer-integer casts. Not anymore *)
      (* if ikindo = ikindn then (nt, e) else *)
      result
    | TPtr (TFun (_,args,va,_),_), TPtr(TFun (_,args',va',_),_) ->
      (* Checks on casting from a function type into another one.
         We enforce at least the same number of arguments, and emit a warning
         if types do not match. Note that empty argument lists are always
         compatible. *)
      if (va <> va' || bigger_length_args args args') &&
         (args <> None && args' <> None)
      then
        error
          "conversion between function types with \
           different number of arguments:@ %a@ and@ %a"
          Cil_datatype.Typ.pretty ot Cil_datatype.Typ.pretty nt;
      if not (areCompatibleTypes ?context ot nt) then
        Kernel.warning
          ~wkey:Kernel.wkey_incompatible_types_call
          ~current:true
          "implicit conversion between incompatible function types:@ \
           %a@ and@ %a"
          Cil_datatype.Typ.pretty ot Cil_datatype.Typ.pretty nt;
      result

    | TFun _, TPtr(TFun _, _) ->
      let clean_e =
        match e.enode with
        | Lval lv ->  Cil.mkAddrOf ~loc:e.eloc lv
        | _ -> e (* function decay into pointer anyway *)
      in
      castTo ?context ~fromsource (TPtr (ot, [])) nt clean_e

    (* accept converting a ptr to function to/from a ptr to void, even though
       not really accepted by the standard. gcc supports it. though
    *)
    | TPtr (TFun _,_), TPtr (TVoid _, _) -> result
    | TPtr (TVoid _, _), TPtr (TFun _,_) -> result
    (* Taking numerical address or calling an absolute location. Also
       accepted by gcc albeit with a warning. *)
    | TInt _, TPtr (TFun _, _) -> result

    (* pointer to potential function type. Note that we do not
       use unrollTypeDeep above in order to avoid needless divergence with
       original type in the sources.
    *)
    | TPtr(TFun _,_), TPtr(TNamed(ti,nattr),pattr) ->
      castTo ?context
        ~fromsource ot (TPtr (Cil.typeAddAttributes nattr ti.ttype, pattr)) e
    | TPtr(TNamed(ti,nattr),pattr), TPtr(TFun _,_) ->
      castTo ?context
        ~fromsource (TPtr (Cil.typeAddAttributes nattr ti.ttype, pattr)) nt e

    (* No other conversion implying a pointer to function
       and a pointer to object are supported. *)
    | TPtr (TFun _,_), TPtr _ ->
      Kernel.warning
        ~wkey:Kernel.wkey_incompatible_pointer_types
        ~current:true
        "casting function to %a" Cil_datatype.Typ.pretty nt;
      result
    | TPtr _, TPtr (TFun _,_) ->
      Kernel.warning
        ~wkey:Kernel.wkey_incompatible_pointer_types
        ~current:true
        "casting function from %a" Cil_datatype.Typ.pretty ot;
      result
    | _, TPtr (TFun _, _) ->
      error "cannot cast %a to function type" Cil_datatype.Typ.pretty ot
    | TPtr _, TPtr _ -> result

    | TInt _, TPtr _ -> result

    | TPtr _, TInt _ ->
      if not fromsource
      then
        Kernel.warning
          ~wkey:Kernel.wkey_int_conversion
          ~current:true
          "Conversion from a pointer to an integer without an explicit cast";
      result

    | TArray _, TPtr _ -> result

    | TArray(t1,_,_), TArray(t2,None,_)
      when Cil_datatype.Typ.equal t1 t2 -> (nt, e)

    | TPtr _, TArray(_,_,_) ->
      error "Cast over a non-scalar type %a" Cil_datatype.Typ.pretty nt;

    | TEnum _, TInt _ -> result
    | TFloat _, (TInt _|TEnum _) -> result
    | (TInt _|TEnum _), TFloat _ -> result
    | TFloat _, TFloat _ -> result
    | TInt (ik,_), TEnum (ei,_) ->
      (match e.enode with
       | Const (CEnum { eihost = ei'})
         when ei.ename = ei'.ename && not fromsource &&
              Cil.bytesSizeOfInt ik = Cil.bytesSizeOfInt ei'.ekind
         -> (nt,e)
       | _ -> result)
    | TEnum _, TEnum _ -> result

    | TEnum _, TPtr _ -> result
    | TBuiltin_va_list _, (TInt _ | TPtr _) ->
      result

    | (TInt _ | TPtr _), TBuiltin_va_list _ ->
      Kernel.debug ~dkey:Kernel.dkey_typing_cast ~current:true
        "Casting %a to __builtin_va_list" Cil_datatype.Typ.pretty ot ;
      result

    | TPtr _, TEnum _ ->
      Kernel.debug ~dkey:Kernel.dkey_typing_cast ~current:true
        "Casting a pointer into an enumeration type" ;
      result

    (* The expression is evaluated for its effects *)
    | (TInt _ | TEnum _ | TPtr _ ), TVoid _ ->
      Kernel.debug ~level:3
        "Casting a value into void: expr is evaluated for side effects";
      result

    (* Even casts between structs are allowed when we are only
     * modifying some attributes *)
    | TComp (comp1, _), TComp (comp2, _) when comp1.ckey = comp2.ckey ->
      result

    (* If we try to pass a transparent union value to a function
     * expecting a transparent union argument, the argument type would
     * have been changed to the type of the first argument, and we'll
     * see a cast from a union to the type of the first argument. Turn
     * that into a field access *)
    | TComp(_, _), _ -> begin
        match isTransparentUnion ot with
        | None ->
          Kernel.fatal ~current:true "castTo %a -> %a"
            Cil_datatype.Typ.pretty ot Cil_datatype.Typ.pretty nt
        | Some fstfield -> begin
            (* We do it now only if the expression is an lval *)
            let e' =
              match e.enode with
              | Lval lv ->
                new_exp ~loc:e.eloc
                  (Lval (addOffsetLval (Field(fstfield, NoOffset)) lv))
              | _ ->
                Kernel.fatal ~current:true
                  "castTo: transparent union expression is not an lval: %a\n"
                  Cil_printer.pp_exp e
            in
            (* Continue casting *)
            castTo ?context ~fromsource:fromsource fstfield.ftype nt e'
          end
      end
    | _ ->
      error "cannot cast from %a to %a@\n" Cil_datatype.Typ.pretty ot Cil_datatype.Typ.pretty nt
  end

(* Create and cache varinfo's for globals. Starts with a varinfo but if the
 * global has been declared already it might come back with another varinfo.
 * Returns the varinfo to use (might be the old one), and an indication
 * whether the variable exists already in the environment *)
let makeGlobalVarinfo (isadef: bool) (vi: varinfo) : varinfo * bool =
  let res =
    try (* See if already defined, in the global environment. We could also
         * look it up in the whole environment but in that case we might see a
         * local. This can happen when we declare an extern variable with
         * global scope but we are in a local scope. *)
      Kernel.debug ~dkey:Kernel.dkey_typing_global
        "makeGlobalVarinfo isadef=%B vi.vname=%s(%d), vreferenced=%B"
        isadef vi.vname vi.vid vi.vreferenced;
      (* This may throw an exception Not_found
         Note that we always search in all the context, including ghost *)
      let oldvi, oldloc = lookupGlobalVar true vi.vname in
      if oldvi.vghost <> vi.vghost then
        abort_context "Inconsistent ghost specification for %s.@ \
                       Previous declaration was at: %a"
          vi.vname Cil_datatype.Location.pretty oldloc ;

      Kernel.debug ~dkey:Kernel.dkey_typing_global
        "  %s(%d) already in the env at loc %a"
        vi.vname oldvi.vid Cil_printer.pp_location oldloc;
      (* It was already defined. We must reuse the varinfo. But clean up the
       * storage.  *)
      let newstorage = (* See 6.2.2 *)
        match oldvi.vstorage, vi.vstorage with
        | Extern, NoStorage when isadef -> NoStorage
        (* the case above is not strictly C standard, but will not accept
           more program and is more compatible with old implicit
           quasi-invariant that Extern == not defined. *)
        | Extern, (Extern | NoStorage) -> Extern
        | NoStorage, Extern -> if oldvi.vdefined then NoStorage else Extern
        | NoStorage, NoStorage -> NoStorage
        | Static, Extern -> Static (* 6.2.2§4 *)
        | Static, NoStorage when Cil.isFunctionType vi.vtype -> Static
        | _ ->
          if vi.vstorage != oldvi.vstorage then
            Kernel.error ~current:true
              "Inconsistent storage specification for %s. \
               Previous declaration: %a"
              vi.vname Cil_printer.pp_location oldloc;
          vi.vstorage
      in
      (* if _all_ declaration have the inline specifier, and none
         is extern we'll end up with an inline definition which must have
         a special treatment (see C11 6.7.4§7) *)
      oldvi.vinline <- oldvi.vinline && vi.vinline;
      (* If the new declaration has a section attribute, remove any
       * preexisting section attribute. This mimics behavior of gcc that is
       * required to compile the Linux kernel properly. *)
      if hasAttribute "section" vi.vattr then
        oldvi.vattr <- dropAttribute "section" oldvi.vattr;
      (* Before combining attributes, we need to check compatibility between
         qualifiers *)
      begin
        try
          let oldquals = get_qualifiers oldvi.vtype in
          let quals = get_qualifiers vi.vtype in
          if not (Cil_datatype.Attributes.equal oldquals quals) then
            raise (Cannot_combine
                     (Format.asprintf
                        "different qualifiers:@ '%a' and '%a'"
                        Cil_printer.pp_attributes oldquals
                        Cil_printer.pp_attributes quals));
          (* Union the attributes *)
          oldvi.vattr <- cabsAddAttributes oldvi.vattr vi.vattr;
          let what =
            if isadef then
              CombineFundef (hasAttribute "FC_OLDSTYLEPROTO" vi.vattr)
            else CombineOther
          in
          let mytype = combineTypes what oldvi.vtype vi.vtype in
          if not (Cil_datatype.Typ.equal oldvi.vtype vi.vtype)
          then begin
            DifferentDeclHook.apply (oldvi,vi);
            (* note: combineTypes is (purposedly) not very strict, so we
               use compatibleTypes here to perform more strict checks and
               raise Cannot_combine if necessary. However, due to old-style
               prototypes in GCC machdeps, we must support eccentric cases,
               for which we perform no such additional verification. *)
            if not (hasAttribute "FC_OLDSTYLEPROTO" vi.vattr) then
              ignore (compatibleTypes oldvi.vtype vi.vtype)
          end;
          Cil.update_var_type oldvi mytype;
        with Cannot_combine reason ->
          Kernel.debug ~dkey:Kernel.dkey_typing_global
            "old type = %a\nnew type = %a\n"
            Cil_datatype.Typ.pretty oldvi.vtype
            Cil_datatype.Typ.pretty vi.vtype ;
          Kernel.error ~once:true ~current:true
            "Declaration of %s does not match previous declaration from \
             %a (%s)."
            vi.vname Cil_printer.pp_location oldloc reason;
          IncompatibleDeclHook.apply (oldvi,vi,reason)
      end;
      (* Update the storage and vdecl if useful. Do so only after the hooks have
         been applied, as they may need to read those fields *)
      if oldvi.vstorage <> newstorage then begin
        oldvi.vstorage <- newstorage;
        (* Also update the location; [vi.vdecl] is a better
           declaration/definition site for [vi]. *)
        oldvi.vdecl <- vi.vdecl;
      end;
      (* Let's mutate the formals vid's name attribute and type for function
         prototypes. Logic specifications refer to the varinfo in this table. *)
      begin
        match vi.vtype with
        | TFun (_,Some formals , _, _ ) ->
          (try
             let old_formals_env = getFormalsDecl oldvi in
             List.iter2
               (fun old ((name,typ,attr) as decl) ->
                  let new_ghost = Cil.isGhostFormalVarDecl decl in
                  if old.vghost <> new_ghost then
                    raise (Invalid_argument "Incompatible ghost status")
                  else if name <> "" then begin
                    Kernel.debug ~dkey:Kernel.dkey_typing_global
                      "replacing formal %s with %s" old.vname name;
                    old.vname <- name;
                    if not oldvi.vdefined || isadef then begin
                      Cil.update_var_type old typ;
                      old.vattr <- attr;
                    end;
                    (match old.vlogic_var_assoc with
                     | None -> ()
                     | Some old_lv -> old_lv.lv_name <- name)
                  end)
               old_formals_env
               formals;
           with
           | Invalid_argument _ ->
             abort_context "Inconsistent formals" ;
           | Not_found ->
             Cil.setFormalsDecl oldvi vi.vtype)
        | _ -> ()
      end ;
      (* if [isadef] is true, [vi] is a definition.  *)
      if isadef then begin
        (* always favor the location of the definition.*)
        oldvi.vdecl <- vi.vdecl;
        oldvi.vdefined <- true;
        oldvi.vattr <- fc_stdlib_attribute oldvi.vattr
      end;
      (* notice that [vtemp] is immutable, and cannot be updated. Hopefully,
         temporaries have sufficiently fresh names that this is not a problem *)
      oldvi, true
    with Not_found -> begin (* A new one.  *)
        Kernel.debug ~dkey:Kernel.dkey_typing_global
          "  %s not in the env already" vi.vname;
        (* Announce the name to the alpha conversion table. This will not
         * actually change the name of the vi. See the definition of
         * alphaConvertVarAndAddToEnv *)
        let vi = alphaConvertVarAndAddToEnv true vi in
        (* update the field [vdefined] *)
        if isadef then vi.vdefined <- true;
        vi.vattr <- dropAttribute "FC_OLDSTYLEPROTO" vi.vattr;
        vi.vattr <- fc_stdlib_attribute vi.vattr;
        vi, false
      end
  in
  NewGlobalHook.apply res;
  res

type args_or_argtypes = Args of varinfo list | ArgTypes of typ list

(* Register a builtin function *)
let setupBuiltin ?(force_keep=false) name ?spec (resTyp, args_or_argtypes, isva) =
  let funargs, args = match args_or_argtypes with
    | Args args ->
      Some (List.map (fun vi -> (vi.vname, vi.vtype, vi.vattr)) args), args
    | ArgTypes argTypes ->
      let funargs =
        List.mapi
          (fun i at ->
             ("__x" ^ string_of_int i, at, [Cil.anonymous_attribute])) argTypes
      in
      Some funargs, List.map makeFormalsVarDecl funargs
  in
  let typ = TFun(resTyp, funargs, isva, []) in
  let v = makeGlobalVar name typ in
  ignore (alphaConvertVarAndAddToEnv true v);
  (* Add it to the file as well *)
  let funspec = match spec with
    | None -> empty_funspec ()
    | Some s -> s
  in
  cabsPushGlobal (GFunDecl (funspec, v, Cil_builtins.builtinLoc));
  Cil.unsafeSetFormalsDecl v args;
  if force_keep then
    v.vattr <- Cil.addAttribute (Attr ("FC_BUILTIN",[])) v.vattr;
  v
;;

(*  builtin is never ghost *)
let memoBuiltin ?force_keep ?spec name proto =
  try fst (lookupGlobalVar false name)
  with Not_found -> setupBuiltin ?force_keep ?spec name proto

let vla_alloc_fun () =
  let size_arg =
    Cil.makeVarinfo false true "size" theMachine.typeOfSizeOf
  in
  let res_iterm =
    Logic_const.new_identified_term
      (Logic_const.tresult Cil.voidPtrType)
  in
  let behavior =
    Cil.mk_behavior ~assigns:(Writes [(res_iterm, From [])])
      ~allocation:(FreeAlloc ([], [res_iterm])) ()
  in
  let spec = { (Cil.empty_funspec ()) with spec_behavior = [behavior]} in
  memoBuiltin ~force_keep:true "__fc_vla_alloc" ~spec
    (voidPtrType, Args [size_arg], false)

let vla_free_fun () =
  let p_arg = Cil.makeVarinfo false true "p" voidPtrType in
  let p_iterm = Logic_const.new_identified_term
      (Logic_const.tvar (Cil.cvar_to_lvar p_arg))
  in
  let behavior =
    Cil.mk_behavior ~assigns:(Writes [])
      ~allocation:(FreeAlloc ([p_iterm], [])) ()
  in
  let spec = { (Cil.empty_funspec ()) with spec_behavior = [behavior]} in
  memoBuiltin ~force_keep:true ~spec "__fc_vla_free"
    (voidType, Args [p_arg], false)

let conditionalConversion (t2: typ) (t3: typ) : typ =
  let tresult =  (* ISO 6.5.15 *)
    match unrollType t2, unrollType t3 with
    | (TInt _ | TEnum _ | TFloat _), (TInt _ | TEnum _ | TFloat _) ->
      arithmeticConversion t2 t3
    | TComp (comp2,_), TComp (comp3,_)
      when comp2.ckey = comp3.ckey -> t2
    | TPtr(_, _), TPtr(TVoid _, _) -> t2
    | TPtr(TVoid _, _), TPtr(_, _) -> t3
    | TPtr _, TPtr _ when Cil_datatype.Typ.equal t2 t3 -> t2
    | TPtr _, TInt _  -> t2 (* most likely comparison with 0 *)
    | TInt _, TPtr _ -> t3 (* most likely comparison with 0 *)

    (* When we compare two pointers of different types, we combine them
     * using the same algorithm when combining multiple declarations of
     * a global *)
    | (TPtr _) as t2', (TPtr _ as t3') -> begin
        try combineTypes CombineOther t2' t3'
        with Cannot_combine msg -> begin
            Kernel.warning ~current:true "A.QUESTION: %a does not match %a (%s)"
              Cil_datatype.Typ.pretty (unrollType t2) Cil_datatype.Typ.pretty (unrollType t3) msg;
            t2 (* Just pick one *)
          end
      end
    | _, _ ->
      Kernel.fatal ~current:true "invalid implicit conversion from %a to %a"
        Cil_datatype.Typ.pretty t2 Cil_datatype.Typ.pretty t3
  in
  tresult

let logicConditionalConversion t1 t2 =
  match unrollType t1, unrollType t2 with
  | TPtr _ , TInt _ | TInt _, TPtr _ ->
    Kernel.fatal ~current:true "invalid implicit conversion from %a to %a"
      Cil_datatype.Typ.pretty t2 Cil_datatype.Typ.pretty t1
  | _ -> conditionalConversion t1 t2

(* Some utilities for doing initializers *)

type preInit =
  | NoInitPre
  | SinglePre of exp * Cil_datatype.Lval.Set.t (* lval reads by the expression*)
  | CompoundPre of int ref (* the maximum used index *)
                   * preInit array ref (* an array with initializers *)

(* internal pretty-printing function for debugging purposes *)
let rec _pp_preInit fmt = function
  | NoInitPre -> Format.fprintf fmt "NoInitPre"
  | SinglePre (e,_) -> Format.fprintf fmt "SinglePre(%a)" Cil_printer.pp_exp e
  | CompoundPre (int_ref, preInit_a_ref) ->
    Format.fprintf fmt "CompoundPre(%d,@[%a@])" !int_ref
      (Pretty_utils.pp_array ~sep:",@ "
         (fun fmt index e -> Format.fprintf fmt "@[[%d -> %a]@]" index _pp_preInit e))
      !preInit_a_ref

(* special case for treating GNU extension on empty compound initializers. *)
let empty_preinit() =
  if Cil.gccMode () || Cil.msvcMode () then
    CompoundPre (ref (-1), ref [| |])
  else abort_context "empty initializers %s" (Cil.allowed_machdep "GCC/MSVC")

(* Set an initializer *)
let rec setOneInit this o preinit =
  match o with
  | NoOffset -> preinit
  | _ ->
    let idx, (* Index in the current comp *)
        restoff (* Rest offset *) =
      match o with
      | Index({enode = Const(CInt64(i,_,_))}, off) -> to_integer i, off
      | Field (f, off) ->
        (* Find the index of the field *)
        let rec loop (idx: int) = function
          | [] ->
            (* We have managed to build a fieldinfo whose fcomp field is a
               compinfo that does not include the corresponding field. This
               is not a typechecking error, but an internal failure of cabs2cil
            *)
            Kernel.fatal ~current:true
              "Cannot find field %s for initialization of type %s"
              f.fname (Cil.compFullName f.fcomp)
          | f' :: _ when f'.fname = f.fname -> idx
          | _ :: restf -> loop (idx + 1) restf
        in
        loop 0 (Option.value ~default:[] f.fcomp.cfields), off
      | _ -> abort_context "setOneInit: non-constant index"
    in
    let pMaxIdx, pArray =
      match this  with
      | NoInitPre  -> (* No initializer so far here *)
        begin
          try
            ref idx, ref (Array.make (max 32 (idx + 1)) NoInitPre)
          with Invalid_argument _ | Out_of_memory ->
            Kernel.abort ~current:true
              "array length too large: %d" ((max 32 (idx + 1)))
        end

      | CompoundPre (pMaxIdx, pArray) ->
        if !pMaxIdx < idx then begin
          pMaxIdx := idx;
          (* Maybe we also need to grow the array *)
          let l = Array.length !pArray in
          if l <= idx then begin
            let growBy = max (max 32 (idx + 1 - l)) (l / 2) in
            try
              let newarray = Array.make (growBy + idx) NoInitPre in
              Array.blit !pArray 0 newarray 0 l;
              pArray := newarray
            with Invalid_argument _ | Out_of_memory ->
              Kernel.abort ~current:true
                "array length too large for Frama-C: %d" (idx)
          end
        end;
        pMaxIdx, pArray
      | SinglePre _ ->
        Kernel.fatal ~current:true "Index %d is already initialized" idx
    in
    assert (idx >= 0 && idx < Array.length !pArray);
    let this' = setOneInit !pArray.(idx) restoff preinit in
    !pArray.(idx) <- this';
    CompoundPre (pMaxIdx, pArray)

(* collect a CIL initializer, given the original syntactic initializer
 * 'preInit'; this returns a type too, since initialization of an array
 * with unspecified size actually changes the array's type
 * (ANSI C, 6.7.8, para 22).
 * Finally, we return the set of lvals that are read for the evaluation of
 * the initializer (for unspecified sequences)
*)
let rec collectInitializer
    reads (* lval already read by the rest of the initializer. *)
    (this: preInit)
    (thistype: typ) ~(parenttype: typ) :
  (init * typ * Cil_datatype.Lval.Set.t) =
  (* parenttype is used to identify a tentative flexible array member
     initialization *)
  let dkey = Kernel.dkey_typing_init in
  let loc = CurrentLoc.get() in
  if this = NoInitPre then begin
    Kernel.debug ~dkey "zero-initializing object of type %a"
      Cil_datatype.Typ.pretty thistype;
    (makeZeroInit ~loc thistype), thistype, reads
  end else
    match unrollType thistype, this with
    | _ , SinglePre (e, r) ->
      Kernel.debug ~dkey "Initializing object of type %a to %a"
        Cil_datatype.Typ.pretty thistype Cil_printer.pp_exp e;
      SingleInit e, thistype, Cil_datatype.Lval.Set.union r reads
    | TArray (bt, leno, at), CompoundPre (pMaxIdx, pArray) ->
      Kernel.debug ~dkey
        "Initialization of an array object of type %a with index max %d"
        Cil_datatype.Typ.pretty thistype !pMaxIdx;
      let len, initializer_len_used =
        (* normal case: use array's declared length, newtype=thistype *)
        match leno with
        | Some len -> begin
            match constFoldToInt len with
            | Some ni when Integer.ge ni Integer.zero -> to_integer ni, false
            | _ ->
              Kernel.fatal ~current:true
                "Array length %a is not a compile-time constant: \
                 no explicit initializer allowed."
                Cil_printer.pp_exp len
          end
        | _ ->
          (* unsized array case, length comes from initializers *)
          (!pMaxIdx + 1), true
      in
      if !pMaxIdx >= len then
        abort_context
          "collectInitializer: too many initializers(%d >= %d)"
          (!pMaxIdx+1) len;
(*
        (* len could be extremely big. So omit the last initializers, if they
         * are many (more than 16). doInit will take care of that by
         * mem-setting everything to 0 in that case.
         *)
        let endAt =
          if len - 1 > !pMaxIdx + 16 then
            !pMaxIdx
          else
            len - 1
        in
        (* Make one zero initializer to be used next *)
        let oneZeroInit = makeZeroInit ~loc bt in
        let rec collect (acc: (offset * init) list) (idx: int) =
          if idx = -1 then acc
          else
            let thisi =
              if idx > !pMaxIdx then oneZeroInit
              else (fst (collectInitializer !pArray.(idx) bt))
            in
            collect ((Index(integer ~loc idx,NoOffset), thisi) :: acc) (idx - 1)
        in
*)
      let collect_one_init v (idx,init,typ,reads,len_used) =
        match v with
        | NoInitPre -> (idx-1,init,typ,reads,len_used)
        | _ ->
          let (vinit,typ', reads') =
            collectInitializer reads v typ ~parenttype:typ
          in
          let len_used =
            len_used || not (Cil_datatype.Typ.equal typ typ')
          in
          (idx-1,
           (Index (integer ~loc idx,NoOffset), vinit)::init,
           typ',
           Cil_datatype.Lval.Set.union reads' reads,
           len_used)
      in
      let (_,init,typ, reads, len_used) =
        Array.fold_right collect_one_init
          !pArray (Array.length !pArray - 1, [], bt, reads,initializer_len_used)
      in
      let newtype =
        (* detect flexible array member initialization *)
        match thistype, Cil.unrollType parenttype with
        | TArray (_, None, _), TComp (comp, _)
          when comp.cstruct && len > 0 ->
          (* incomplete array type inside a struct => FAM, with
             a non-empty initializer (len > 0)
          *)
          Kernel.debug ~dkey
            "Detected initialization of a flexible array member \
             (length %d, parenttype %a)" len Cil_datatype.Typ.pretty parenttype;
          Kernel.error ~once:true ~current:true
            "static initialization of flexible array members is an \
             unsupported GNU extension";
          TArray (typ, None, at)
        | _ -> (* not a flexible array member *)
          if len = 0 && not (Cil.gccMode() || Cil.msvcMode ()) then
            Kernel.error ~once:true ~current:true
              "arrays of size zero not supported in C99@ \
               (only allowed as compiler extensions)";
          TArray (typ, Some (integer ~loc len), at)
      in
      CompoundInit (newtype, (* collect [] endAt*)init),
      (* If the sizes of the initializers have not been used anywhere,
         we can fold back an eventual typedef. Otherwise, push the
         attributes to the elements of the array *)
      (if len_used then newtype else thistype),
      reads

    | TComp (comp, _) as t,
      CompoundPre (pMaxIdx, pArray) when comp.cstruct ->
      Kernel.debug ~dkey
        "Initialization of an object of type %a with at least %d components"
        Cil_datatype.Typ.pretty thistype !pMaxIdx;
      let rec collect (idx: int) reads = function
          [] -> [], reads
        | [ _ ] when Cil.has_flexible_array_member t && idx > !pMaxIdx ->
          (* Do not add an empty initializer to the FAM, making an ill-formed
             AST. An explicit initialization is allowed in gcc-mode. *)
          [], reads
        | f :: restf ->
          if f.fname = missingFieldName then
            collect (idx + 1) reads restf
          else
            let thisi, reads' =
              if idx > !pMaxIdx then
                makeZeroInit ~loc f.ftype, reads
              else
                collectFieldInitializer
                  reads !pArray.(idx) f ~parenttype:thistype
            in
            let rest, reads' = collect (idx+1) reads' restf in
            (Field(f, NoOffset), thisi) :: rest, reads'
      in
      let init, reads =
        collect 0 reads (Option.value ~default:[] comp.cfields) in
      CompoundInit (thistype, init), thistype, reads

    | TComp (comp, _), CompoundPre (pMaxIdx, pArray) when not comp.cstruct ->
      Kernel.debug ~dkey
        "Initialization of an object of type %a with at least %d components"
        Cil_datatype.Typ.pretty thistype !pMaxIdx;
      (* Find the field to initialize *)
      let rec findField (idx: int) = function
        | [] -> abort_context "collectInitializer: union"
        | _ :: rest when idx < !pMaxIdx && !pArray.(idx) = NoInitPre ->
          findField (idx + 1) rest
        | f :: _ when idx = !pMaxIdx ->
          let init, reads =
            collectFieldInitializer reads !pArray.(idx) f ~parenttype:thistype
          in
          (Field(f, NoOffset), init), reads

        | _ ->
          Kernel.fatal ~current:true "Can initialize only one field for union"
      in
      if Cil.msvcMode () && !pMaxIdx != 0 then
        Kernel.warning ~current:true
          "On MSVC we can initialize only the first field of a union";
      let init, reads = findField 0 (Option.value ~default:[] comp.cfields) in
      CompoundInit (thistype, [ init ]), thistype, reads

    | _ -> Kernel.fatal ~current:true "collectInitializer"

and collectFieldInitializer
    reads
    (this: preInit)
    (f: fieldinfo) ~(parenttype: typ) =
  (* collect, and rewrite type *)
  let init,newtype,reads =
    (collectInitializer reads this f.ftype ~parenttype)
  in
  f.ftype <- newtype;
  init, reads

type stackElem =
    InArray of offset * typ * int * int ref (* offset of parent, base type,
                                             * length, current index. If the
                                             * array length is unspecified we
                                             * use Int.max_int  *)
  | InComp  of offset * compinfo * offset list (* offset of parent,
                                                     base comp, current fields *)


(* A subobject is given by its address. The address is read from the end of
 * the list (the bottom of the stack), starting with the current object *)
type subobj = { mutable stack: stackElem list; (* With each stack element we
                                                * store the offset of its
                                                * PARENT  *)
                mutable eof: bool; (* The stack is empty and we reached the
                                    * end *)
                mutable soTyp: typ; (* The type of the subobject. Set using
                                     * normalSubobj after setting stack. *)
                mutable soOff: offset; (* The offset of the subobject. Set
                                        * using normalSubobj after setting
                                        * stack.  *)
                curTyp: typ; (* Type of current object. See ISO for
                              * the definition of the current object *)
                curOff: offset; (* The offset of the current obj *)
                host: varinfo; (* The host that we are initializing.
                                * For error messages *)
              }

(* maps vid to visitor used to perform renaming on function spec when there's
   a spec on a declaration and a definition for the function. This is done after
   typing.
*)
let alpha_renaming = Hashtbl.create 59

let rename_spec = function
  | GFunDecl(spec,v,_) ->
    (try
       let alpha = Hashtbl.find alpha_renaming v.vid in
       ignore (Cil.visitCilFunspec alpha spec)
     with Not_found -> ())
  | _ -> ()

(* Make a subobject iterator *)
let rec makeSubobj
    (host: varinfo)
    (curTyp: typ)
    (curOff: offset) =
  let so =
    { host = host; curTyp = curTyp; curOff = curOff;
      stack = []; eof = false;
      (* The next are fixed by normalSubobj *)
      soTyp = voidType; soOff = NoOffset } in
  normalSubobj so;
  so

(* Normalize a stack so the we always point to a valid subobject. Do not
 * descend into type *)
and normalSubobj (so: subobj) : unit =
  match so.stack with
  | [] -> so.soOff <- so.curOff; so.soTyp <- so.curTyp
  (* The array is over *)
  | InArray (parOff, bt, leno, current) :: rest ->
    if leno = !current then begin (* The array is over *)
      Kernel.debug ~dkey:Kernel.dkey_typing_init "Past the end of array";
      so.stack <- rest;
      advanceSubobj so
    end else begin
      so.soTyp <- bt;
      so.soOff <-
        addOffset
          (Index(integer ~loc:(CurrentLoc.get()) !current, NoOffset))
          parOff
    end

  (* The fields are over *)
  | InComp (parOff, compinfo, nextflds) :: rest ->
    if nextflds == [] then begin (* No more fields here *)
      Kernel.debug ~dkey:Kernel.dkey_typing_init "Past the end of structure";
      so.stack <- rest;
      advanceSubobj so
    end else begin
      let fst = List.hd nextflds
      and baseTyp = TComp (compinfo, []) in
      so.soTyp <- Cil.typeOffset baseTyp fst;
      so.soOff <- addOffset fst parOff
    end

(* Advance to the next subobject. Always apply to a normalized object *)
and advanceSubobj (so: subobj) : unit =
  if so.eof then abort_context "advanceSubobj past end";
  match so.stack with
  | [] ->
    Kernel.debug ~dkey:Kernel.dkey_typing_init "Setting eof to true";
    so.eof <- true
  | InArray (_, _, _, current) :: _ ->
    Kernel.debug ~dkey:Kernel.dkey_typing_init
      "  Advancing to [%d]" (!current + 1);
    (* so.stack <- InArray (parOff, bt, leno, current + 1) :: rest; *)
    incr current;
    normalSubobj so

  (* The fields are over *)
  | InComp (parOff, comp, nextflds) :: rest ->
    let fi, flds' =
      match nextflds with
      | Field (fi,_) :: flds' -> fi, flds'
      | _ -> abort_context "advanceSubobj"
    in
    Kernel.debug ~dkey:Kernel.dkey_typing_init
      "Advancing past .%s" fi.fname;
    so.stack <- InComp(parOff, comp, flds') :: rest;
    normalSubobj so

let anonCompFieldNameId = ref 0
let anonCompFieldName = "__anonCompField"

(* Find the fields to initialize in a composite. *)
let fieldsToInit
    (comp: compinfo)
    (designator: string option)
  : offset list =
  (* Traversal of the comp fields (also goes through anonymous comp)
     the resulting fields are in reverse order *)
  let rec add_comp (offset : offset) (comp : compinfo) acc =
    let in_union = not comp.cstruct in
    add_fields offset in_union (Option.value ~default:[] comp.cfields) acc
  and add_fields (offset : offset) (in_union : bool) (l : fieldinfo list) acc =
    match l with
    | [] -> acc
    | f :: l ->
      let (found, _ as acc) = add_field offset f acc in
      if found && in_union
      then acc (* only consider one field in an union - stop if we found it *)
      else add_fields offset in_union l acc
  and add_field (offset : offset) (f : fieldinfo) (found, loff as acc) =
    (* update current offset *)
    let offset = Cil.addOffset (Field (f, NoOffset)) offset in
    (* Ignore anonymous non-comp fields *)
    if f.fname = missingFieldName then
      acc
      (* if we have already found the designator, just append the current field *)
    else if found then
      found, offset :: loff
      (* if this field is an anonymous comp, search for the designator inside *)
    else if prefix anonCompFieldName f.fname && not found
            && f.forig_name <> f.fname then
      match unrollType f.ftype with
      | TComp (comp, _) ->
        add_comp offset comp acc (* go deeper inside *)
      | _ ->
        abort_context "unnamed field type is not a struct/union"
        (* does this field match the designator ? *)
    else match designator with
      | Some fn when f.fname = fn -> (true, [offset])
      | _ -> acc
  in
  let found, r = add_comp NoOffset comp (designator = None, []) in
  begin if not found then
      let fn = Option.get designator in
      Kernel.fatal ~current:true "Cannot find designated field %s" fn;
  end;
  List.rev r

let integerArrayLength (leno: exp option) : int =
  match leno with
  | None -> max_int
  | Some len ->
    try lenOfArray leno
    with
    | LenOfArray cause ->
      Kernel.abort ~current:true
        "Array length %a is %a: no explicit initializer allowed."
        Cil_printer.pp_exp len Cil.pp_incorrect_array_length cause

let find_field_offset cond (fidlist: fieldinfo list) : offset =
  (* Depth first search for the field. This appears to be what GCC does.
   * MSVC checks that there are no ambiguous field names, so it does not
   * matter how we search *)
  let rec search = function
      [] -> raise Not_found
    | fid :: _ when cond fid ->
      Field(fid, NoOffset)
    | fid :: rest when prefix anonCompFieldName fid.fname -> begin
        match unrollType fid.ftype with
        | TComp (ci, _) ->
          (try
             let off = search (Option.value ~default:[] ci.cfields) in
             Field(fid,off)
           with Not_found -> search rest  (* Continue searching *))
        | _ ->
          abort_context "unnamed field type is not a struct/union"
      end
    | _ :: rest -> search rest
  in
  search fidlist

let findField n comp =
  try
    find_field_offset (fun x -> x.fname = n) (Option.value ~default:[] comp.cfields)
  with Not_found ->
    abort_context "Cannot find field %s in type %s" n (Cil.compFullName comp)

(* Utility ***)
let rec replaceLastInList
    (lst: Cabs.expression list)
    (how: Cabs.expression -> Cabs.expression) : Cabs.expression list=
  match lst with
  | [] -> []
  | [e] -> [how e]
  | h :: t -> h :: replaceLastInList t how

let convBinOp (bop: Cabs.binary_operator) : binop =
  match bop with
  | Cabs.ADD -> PlusA
  | Cabs.SUB -> MinusA
  | Cabs.MUL -> Mult
  | Cabs.DIV -> Div
  | Cabs.MOD -> Mod
  | Cabs.BAND -> BAnd
  | Cabs.BOR -> BOr
  | Cabs.XOR -> BXor
  | Cabs.SHL -> Shiftlt
  | Cabs.SHR -> Shiftrt
  | Cabs.EQ -> Eq
  | Cabs.NE -> Ne
  | Cabs.LT -> Lt
  | Cabs.LE -> Le
  | Cabs.GT -> Gt
  | Cabs.GE -> Ge
  | _ -> Kernel.fatal ~current:true "convBinOp"

(**** PEEP-HOLE optimizations ***)

(* Should we collapse [tmp = f(); lv = tmp;] where the result type of [f]
   is [tf], and the [lv] has type [tlv *)
let allow_return_collapse ~tlv ~tf =
  Cil_datatype.Typ.equal tlv tf ||
  Kernel.DoCollapseCallCast.get () &&
  (match Cil.unrollType tlv, Cil.unrollType tf with
   | TPtr _, TPtr _ -> true (* useful for malloc and others. Could be
                                restricted to void* -> any if needed *)
   | TInt (iklv, _), TInt (ikf, _) ->
     Cil.isSigned iklv = Cil.isSigned ikf &&
     Cil.bitsSizeOfBitfield tlv = Cil.bitsSizeOf tf (* && *)
   (* not (Cil.typeHasQualifier "volatile" tlv) *)
   | TFloat (fklv, _), TFloat (fkf, _) -> fklv = fkf
   | _, _ -> false
  )

let tcallres f =
  match unrollType (typeOf f) with
  | TFun (rt, _, _, _) -> rt
  | _ -> abort_context "Function call to a non-function"

let can_collapse vi vi' destlv cast f =
  let tf = tcallres f in
  not vi.vglob && vi' == vi &&
  String.length vi.vname >= 3 &&
  (* Watch out for the possibility that we have an implied cast in
   * the call *)
  IH.mem callTempVars vi.vid &&
  Cil_datatype.Typ.equal cast (typeOfLval destlv) &&
  (* Depending on circumstances, temp var might either have the type of
     the destination variable or the returned type of f. We collapse in both
     cases. *)
  (Cil_datatype.Typ.equal vi.vtype cast ||
   Cil_datatype.Typ.equal vi.vtype tf)
  &&
  allow_return_collapse ~tf ~tlv:cast

let collapseCallCast (s1,s2) = match s1.skind, s2.skind with
  | Instr (Call(Some(Var vi, NoOffset), f, args, l)),
    Instr (Set(destlv,
               {enode = CastE (newt,
                               {enode = Lval(Var vi', NoOffset)})}, _)) ->
    if can_collapse vi vi' destlv newt f then begin
      s1.skind <- Instr(Call(Some destlv, f, args, l));
      Some [ s1 ]
    end
    else None
  | Instr (Call(Some(Var vi, NoOffset), f, args, l)),
    Instr (Set(destlv, {enode = Lval(Var vi', NoOffset)}, _)) ->
    if can_collapse vi vi' destlv (typeOfLval destlv) f then begin
      s1.skind <- Instr(Call(Some destlv, f, args, l));
      Some [ s1 ]
    end else None
  | Instr (Call (Some (Var vi, NoOffset),
                 ({ enode = Lval (Var f, NoOffset)} as ef), args, l)),
    Instr (
      Local_init(
        destv,
        AssignInit(
          SingleInit
            { enode = CastE(newt, { enode = Lval(Var vi', NoOffset)})}),_))->
    if can_collapse vi vi' (Cil.var destv) newt ef then begin
      s1.skind <- Instr(Local_init(destv, ConsInit(f,args,Plain_func),l));
      Some [s1]
    end else None
  | Instr (Call (Some (Var v1, NoOffset),
                 ({ enode = Lval (Var f, NoOffset)} as ef), args, l)),
    Instr (
      Local_init(
        v2, AssignInit(SingleInit { enode = Lval (Var v1', NoOffset) }),_)) ->
    if can_collapse v1 v1' (Cil.var v2) v2.vtype ef then begin
      s1.skind <- Instr(Local_init(v2, ConsInit(f,args,Plain_func),l));
      Some [ s1 ];
    end else None
  | _ -> None

let afterConversion ~ghost (c: chunk) : chunk =
  (* Now scan the statements and find Instr blocks *)
  (* We want to collapse sequences of the form "tmp = f(); v = tmp". This
   * will help significantly with the handling of calls to malloc, where it
   * is important to have the cast at the same place as the call *)
  let block = c2block ~ghost ~collapse_block:false c in
  let sl =
    if Kernel.DoCollapseCallCast.get () then
      peepHole2 ~aggressive:false collapseCallCast block.bstmts
    else block.bstmts
  in
  (* the call to c2block has taken care of a possible unspecified sequence.
     We do not need to keep track of effects at this level. *)
  let res =
    { c with stmts = (List.rev_map (fun x -> x,[],[],[],[]) sl);
             locals = block.blocals
    }
  in
  (*  Format.eprintf "Before conversion@\n%a@\nAfter conversion@\n%a@\n@."
      d_chunk c d_chunk res;
  *)
  res

(***** Try to suggest a name for the anonymous structures *)
let suggestAnonName (nl: Cabs.name list) =
  match nl with
  | [] -> ""
  | (n, _, _, _) :: _ -> n

(** Optional constant folding of binary operations *)
let optConstFoldBinOp loc machdep bop e1 e2 t =
  if theMachine.lowerConstants then
    constFoldBinOp ~loc machdep bop e1 e2 t
  else
    new_exp ~loc (BinOp(bop, e1, e2, t))

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

(* Exception raised by the instance of Logic_typing local to this module.
   See document of [error] below. *)
exception LogicTypeError of location * string

module C_logic_env =
struct
  let nb_loop = ref 0
  let is_loop () = !nb_loop > 0
  let anonCompFieldName = anonCompFieldName
  let conditionalConversion = logicConditionalConversion
  let find_macro _ = raise Not_found
  let find_var ?label var =
    let find_from_curr_env test =
      (* logic has always access to the ghost variables. *)
      match Datatype.String.Hashtbl.find ghost_env var with
      | EnvVar vi, _ when test vi -> cvar_to_lvar vi
      | _ -> raise Not_found
    in
    match label with
    | None -> find_from_curr_env (fun _ -> true)
    | Some "Here" | Some "Old" | Some "Post" ->
      (* the last two labels can only be found in contracts and refer
         to the pre/post state of the contracts: all local variables
         in scope at current point are also in scope in the labels. *)
      find_from_curr_env (fun _ -> true)
    | Some "Pre" ->
      find_from_curr_env (fun vi -> vi.vformal || vi.vglob)
    | Some "Init" -> find_from_curr_env (fun vi -> vi.vglob)
    | Some lab ->
      cvar_to_lvar
        (Datatype.String.Map.find var
           (Datatype.String.Hashtbl.find label_env lab))

  let find_enum_tag x =
    match Datatype.String.Hashtbl.find ghost_env x with
    | EnvEnum item,_ ->
      dummy_exp (Const (CEnum item)), typeOf item.eival
    | _ -> raise Not_found

  let find_comp_field info s = findField s info

  let find_type namespace s =
    match namespace with
    | Logic_typing.Typedef -> let t,_ = lookupTypeNoError true "type" s in t
    | Logic_typing.Union -> findCompType true "union" s []
    | Logic_typing.Struct -> findCompType true "struct" s []
    | Logic_typing.Enum -> findCompType true "enum" s []

  include Logic_labels

  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 = integral_cast

  (* This function raises a non-recoverable when [-continue-annot-error] is not
     set, and [LogicTypeError] otherwise. This exception must *not* escape
     Cabs2cil. Hence, each call to a function of module [Ltyping] below must
     catch it. *)
  let error loc msg =
    Pretty_utils.ksfprintf (fun e -> raise (LogicTypeError (loc,e))) msg

  let on_error f rollback x =
    try f x with
    | LogicTypeError (loc,e) as exn -> rollback (loc,e); raise exn

end

module Ltyping = Logic_typing.Make (C_logic_env)

let startLoop iswhile =
  incr C_logic_env.nb_loop;
  add_label_env "LoopEntry";
  add_label_env "LoopCurrent";
  continues :=
    (if iswhile then While (ref "") else NotWhile (ref "")) :: !continues;
  enter_break_env ()

let exitLoop () =
  decr C_logic_env.nb_loop;
  exit_break_env ();
  remove_label_env "LoopEntry";
  remove_label_env "LoopCurrent";
  match !continues with
  | [] -> Kernel.error ~once:true ~current:true "exit Loop not in a loop"
  | _ :: rest -> continues := rest

let enterScope () =
  scopes := (ref []) :: !scopes;
  C_logic_env.enter_scope ()

(* Exit a scope and clean the environment. We do not yet delete from
 * the name table *)
let exitScope () =
  let this, rest = match !scopes with
    | [] -> Kernel.fatal ~current:true "Not in a scope"
    | car :: cdr -> car, cdr
  in
  scopes := rest;
  let rec loop = function
      [] -> ()
    | UndoRemoveFromEnv (ghost, n) :: t ->
      Datatype.String.Hashtbl.remove ghost_env n;
      if not ghost then Datatype.String.Hashtbl.remove env n;
      loop t
    | UndoAlphaEnv undolist :: t ->
      Alpha.undoAlphaChanges ~alphaTable ~undolist;
      loop t
  in
  loop !this;
  C_logic_env.exit_scope ()

let consLabel ~ghost (l: string) (c: chunk) (loc: location)
    (in_original_program_text : bool) : chunk =
  (* Get the first statement and add the label to it *)
  let labstmt, stmts' = getFirstInChunk ~ghost ~loc c in
  (* Add the label *)
  add_label l labstmt;
  labstmt.labels <- Label (l, loc, in_original_program_text) ::
                    labstmt.labels;
  if c.stmts == stmts' then c else {c with stmts = stmts'}

let consLabContinue ~ghost (c: chunk) =
  match !continues with
  | [] -> Kernel.fatal ~current:true "labContinue not in a loop"
  | While lr :: _ ->
    begin
      assert (!doTransformWhile);
      if !lr = "" then c else consLabel ~ghost !lr c (CurrentLoc.get ()) false
    end
  | NotWhile lr :: _ ->
    if !lr = "" then c else consLabel ~ghost !lr c (CurrentLoc.get ()) false

(* Was a continue instruction used inside the current loop *)
let continueUsed () =
  match !continues with
  | [] -> Kernel.fatal ~current:true "not in a loop"
  | (While lr | NotWhile lr) :: _ -> !lr <> ""

(****** TYPE SPECIFIERS *******)

(* JS: return [Some s] if the attribute string is the attribute annotation [s]
   and [None] if it is not an annotation. *)
let attrAnnot s =
  let r = Str.regexp "/\\*@ \\(.+\\) \\*/" in
  if Str.string_match r s 0 then
    try Some (Str.matched_group 1 s) with Not_found -> assert false
  else
    None


type local_env =
  { authorized_reads: Lval.Set.t;
    known_behaviors: string list;
    is_ghost: bool;
    is_paren: bool; (* true for expressions whose parent is Cabs.PAREN *)
    inner_paren: bool
    (* used during unop/binop traversal to distinguish between
       Cabs.PAREN (Cabs.UNOP(...)) and Cabs.UNOP(Cabs.PAREN(...)) *)
  }

let empty_local_env =
  { authorized_reads = Lval.Set.empty;
    known_behaviors = [];
    is_ghost = false;
    is_paren = false;
    inner_paren = false;
  }

let ghost_local_env ghost = {empty_local_env with is_ghost = ghost }
let add_ghost_to_local_env env ghost =
  { env with is_ghost = env.is_ghost || ghost }

let paren_local_env env = { env with is_paren = true }
let no_paren_local_env env = { env with is_paren = false }
let inner_paren env = { env with inner_paren = true }
let no_inner_paren env = { env with inner_paren = false }

(* weimer: Sat Dec 8 17:30:47 2001 MSVC NT kernel headers include
 * functions like long convert(x) { __asm { mov eax, x \n cdq } }
 * That set a return value via an ASM statement. As a result, I
 * am changing this so a final ASM statement does not count as
 * "fall through" for the purposes of this warning.  *)
(* matth: But it's better to assume assembly will fall through,
 * since  most such blocks do.  It's probably better to print an
 * unnecessary warning than to break CIL's invariant that
 * return statements are inserted properly.  *)
let rec compute_from_root f = function
    [] -> false

  (* We have a label, perhaps we can jump here *)
  | s :: rest when s.labels <> [] ->
    Kernel.debug ~level:4 "computeFromRoot call f from stmt %a"
      Cil_printer.pp_location (Stmt.loc s);
    f (s :: rest)

  | _ :: rest -> compute_from_root f rest

let instrFallsThrough (i : instr) = match i with
  | Local_init _ -> true
  | Set _ -> true
  | Call (None, {enode = Lval (Var e, NoOffset)}, _, _) ->
    (* See if this is exit, or if it has the noreturn attribute *)
    if e.vname = "exit" then false
    else if hasAttribute "noreturn" e.vattr then false
    else true
  | Call _ -> true
  | Asm _ -> true
  | Skip _ -> true
  | Code_annot _ -> true

let rec stmtFallsThrough (s: stmt) : bool =
  Kernel.debug ~level:4 "stmtFallsThrough stmt %a"
    Cil_printer.pp_location (Stmt.loc s);
  match s.skind with
  | Instr(il) ->
    instrFallsThrough il
  | UnspecifiedSequence seq ->
    blockFallsThrough (block_from_unspecified_sequence seq)
  | Return _ | Break _ | Continue _ | Throw _ -> false
  | Goto _ -> false
  | If (_, b1, b2, _) ->
    blockFallsThrough b1 || blockFallsThrough b2
  | Switch (_e, b, targets, _) ->
    (* See if there is a "default" case *)
    if not
        (List.exists
           (fun s ->
              List.exists (function Default _ -> true | _ -> false)
                s.labels)
           targets)
    then begin
      true (* We fall through because there is no default *)
    end else begin
      (* We must examine all cases. If any falls through,
       * then the switch falls through. *)
      blockFallsThrough b || blockCanBreak b
    end
  | Loop (_,b, _, _, _) ->
    (* A loop falls through if it can break. *)
    blockCanBreak b
  | Block b -> blockFallsThrough b
  | TryCatch (b, l, _) ->
    List.fold_left
      (fun acc (_,b) -> acc || blockFallsThrough b)
      (blockFallsThrough b) l
  | TryFinally (_b, h, _) -> blockFallsThrough h
  | TryExcept (_b, _, _h, _) -> true (* Conservative *)
and stmtListFallsThrough = function
    [] -> true
  | s :: rest ->
    if stmtFallsThrough s then begin
      stmtListFallsThrough rest
    end else begin
      (* If we are not falling through then maybe there
       * are labels who are *)
      compute_from_root stmtListFallsThrough rest
    end
and blockFallsThrough b =
  stmtListFallsThrough b.bstmts

(* will we leave this statement or block with a break command? *)
and stmtCanBreak (s: stmt) : bool =
  Kernel.debug ~level:4 "stmtCanBreak stmt %a"
    Cil_printer.pp_location (Stmt.loc s);
  match s.skind with
  | Instr _ | Return _ | Continue _ | Goto _ | Throw _ -> false
  | Break _ -> true
  | UnspecifiedSequence seq ->
    blockCanBreak (block_from_unspecified_sequence seq)
  | If (_, b1, b2, _) ->
    blockCanBreak b1 || blockCanBreak b2
  | Switch _ | Loop _ ->
    (* switches and loops catch any breaks in their bodies *)
    false
  | Block b -> blockCanBreak b
  | TryCatch (b,l,_) ->
    List.fold_left
      (fun acc (_,b) -> acc || blockCanBreak b)
      (blockCanBreak b)
      l
  | TryFinally (b, h, _) -> blockCanBreak b || blockCanBreak h
  | TryExcept (b, _, h, _) -> blockCanBreak b || blockCanBreak h
and blockCanBreak b =
  let rec aux = function
      [] -> false
    | s::tl ->
      Kernel.debug ~level:4 "blockCanBreak from stmt %a"
        Cil_printer.pp_location (Stmt.loc s);
      stmtCanBreak s ||
      (if stmtFallsThrough s then aux tl
       else compute_from_root aux tl)
  in aux b.bstmts

let chunkFallsThrough c =
  let get_stmt (s,_,_,_,_) = s in
  let stmts = List.rev_map get_stmt c.stmts in
  stmtListFallsThrough stmts

let has_local_init chunk =
  List.exists
    (fun (s,_,_,_,_) ->
       match s.skind with Instr (Local_init _) -> true | _ -> false)
    chunk.stmts

let append_chunk_to_annot ~ghost annot_chunk current_chunk =
  match current_chunk.stmts with
  | [] -> annot_chunk @@ (current_chunk, ghost)
  (* don't forget locals of current_chunk *)

  (* if we have a single statement,
     we can avoid enclosing it into a block. *)
  | [ (_s,_,_,_,_) ] ->
    (*     Format.eprintf "Statement is: %a@." d_stmt _s;  *)
    annot_chunk @@ (current_chunk, ghost)
  (* Make a block, and put labels of the first statement
     on the block itself, so as to respect scoping rules
     for \at in further annotations. *)
  | _ ->
    if has_local_init current_chunk then begin
      (* See if we can collapse the statements of the chunk into a single one.
         Otherwise, we can't handle the combination, as putting the Local_init
         into a new block would change the scope of the local variable, at
         least in the pretty-printed code. Furthermore, the usefulness of
         such annotations is dubious at best.
      *)
      let res =
        match current_chunk.stmts with
        | [(s1, m1, w1, r1, c1); (s2, m2, w2, r2, c2)] ->
          Extlib.swap
            Option.bind
            (function
              | [ s1' ] -> Some (s1', m1 @ m2, w1 @ w2, r1 @ r2, c1 @ c2)
              | _ -> None (* should not happen. *))
            (collapseCallCast (s2,s1)) (* the chunk list is reversed.*)
        | _ -> None
      in
      match res with
      | Some s -> annot_chunk @@ ({current_chunk with stmts = [s]}, ghost)
      | None ->
        Kernel.warning ~wkey:Kernel.wkey_annot_error ~current:true
          "Statement contract and ACSL pragmas over a local definition \
           are not implemented. Ignoring annotation";
        current_chunk
    end else begin
      let b = c2block ~ghost current_chunk in
      (* The statement may contain some local variable
         declarations (but no definitions) coming from userland.
         We have to shift them from the inner block, otherwise they will not
         be accessible in the next statements.
      *)
      let locals = b.blocals in
      b.blocals <- [];
      b.battrs <-
        addAttributes [Attr(frama_c_keep_block,[])] b.battrs;
      let block = mkStmt ~ghost ~valid_sid (Block b) in
      let chunk = s2c block in
      let chunk = { chunk with cases = current_chunk.cases } in
      annot_chunk @@ (List.fold_left
                        local_var_chunk chunk (List.rev locals), ghost)
    end

let default_argument_promotion idx exp =
  let name = "x_" ^ string_of_int idx in
  let arg_type = Cil.typeOf exp in
  let typ =
    match Cil.unrollType arg_type with
    | TVoid _ -> voidType
    | TInt(k,_) when Cil.rank k < Cil.rank IInt ->
      if intTypeIncluded k IInt then intType
      else (* This may happen when char or short have the same size as int *)
        uintType
    | TInt(k,_) -> TInt(k,[])
    | TFloat(FFloat,_) -> doubleType
    | TFloat(k,_) -> TFloat(k,[])
    | TPtr(t,_) | TArray(t,_,_) -> TPtr(t,[])
    | (TFun _) as t -> TPtr(t,[])
    | TComp(ci,_) -> TComp(ci,[])
    | TEnum(ei,_) -> TEnum(ei,[])
    | TBuiltin_va_list _ ->
      abort_context "implicit prototype cannot have variadic arguments"
    | TNamed _ -> assert false (* unrollType *)
  in
  (* if we make a promotion, take it explicitly
     into account in the argument itself *)
  let (_,e) = castTo arg_type typ exp in
  (name,typ,[]), e

(* Promote variadic arguments with standard argument promotions.*)
let promote_variadic_arguments (chunk,args) =
  let args =
    Extlib.mapi
      (fun i arg -> snd (default_argument_promotion i arg))
      args
  in
  (chunk,args)

let rec evaluate_cond_exp = function
  | CEExp (_,e) ->
    (match Cil.constFoldToInt e with
     | None -> `CUnknown
     | Some z when Integer.is_zero z -> `CFalse
     | Some _ -> `CTrue)
  | CEAnd (e1,e2) ->
    let r = evaluate_cond_exp e1 in
    if r = `CTrue then evaluate_cond_exp e2 else r
  | CEOr(e1,e2) ->
    let r = evaluate_cond_exp e1 in
    if r = `CFalse then evaluate_cond_exp e2 else r
  | CENot e ->
    match evaluate_cond_exp e with
    | `CTrue -> `CFalse
    | `CFalse -> `CTrue
    | `CUnknown -> `CUnknown

let get_lval_compound_assigned op expr =
  match expr.enode with
  | Lval x
  (* A GCC extension. The operation is done at the cast type.
     The result is also of the cast type *)
  | CastE (_, {enode = Lval x}) ->
    if Cil.is_modifiable_lval x then x else
      Kernel.abort ~current:true
        "Cannot assign to non-modifiable lval %a"
        Cil_printer.pp_lval x
  | _ -> Kernel.fatal ~current:true "Expected lval for %s" op

(* The way formals are handled now might generate incorrect types, in the
   sense that they refer to a varinfo (in the case of VLA depending on a
   previously declared formal) that exists only during the call to doType.
   We replace them here with the definitive version of the formals' varinfos.
   A global refactoring of cabs2cil would be welcome, though.
*)
let fixFormalsType formals =
  let table = Hashtbl.create 5 in
  let vis =
    object
      inherit Cil.nopCilVisitor
      method! vvrbl v =
        if v.vformal then begin
          try
            ChangeTo (Hashtbl.find table v.vname)
          with Not_found ->
            Kernel.fatal ~current:true "Formal %a not tied to a varinfo"
              Cil_printer.pp_varinfo v;
        end else SkipChildren
    end
  in
  let treat_one_formal v =
    Cil.update_var_type v (Cil.visitCilType vis v.vtype);
    Hashtbl.add table v.vname v;
  in
  List.iter treat_one_formal formals

(* Map from standard int type names like [uint16_t] to their expected sizes,
   and a flag whether the given size is exact (or a lower bound). That is,
   [uint16_t] maps to [(16, true)], and [uint_least16_t] to [(16, false)].
   Used by [checkTypedefSize] below. *)
let stdIntegerSizes = Hashtbl.create 5

(* Initialize the stdIntegerSizes table. *)
let initStdIntegerSizes () =
  let bases = ["int"; "uint"] in
  let sizes = [8; 16; 32; 64] in
  let add_std_type base size =
    let add_variant (variant, exact) =
      let key = base ^ variant ^ (string_of_int size) ^ "_t" in
      Hashtbl.add stdIntegerSizes key (size, exact)
    in
    (* Store exact "normal" variant, inexact "fast" and "least" variants. *)
    List.iter add_variant [("", true); ("_fast", false); ("_least", false)]
  in
  List.iter (fun b -> List.iter (add_std_type b) sizes) bases;
  (* Also store variants of [intptr_t] using the size of [void *], and
     [intmax_t] variants using the size of [long long]. *)
  let add_special_types name size =
    let add base =
      Hashtbl.add stdIntegerSizes (base ^ name ^ "_t") (size, true)
    in
    List.iter add bases
  in
  add_special_types "ptr" (Cil.bitsSizeOf Cil.voidPtrType);
  add_special_types "max" (Cil.bitsSizeOf Cil.longLongType)

(* [checkTypedefSize name typ] checks if [name] is acceptable as a typedef
   name for type [typ]. If [name] is one of the standard integer type names
   like [uint16_t] but [typ] has the wrong bit size, emits a warning. *)
let checkTypedefSize name typ =
  if Hashtbl.length stdIntegerSizes = 0 then
    initStdIntegerSizes ();
  if Cil.isIntegralType typ then begin
    let size = Cil.bitsSizeOf typ in
    try
      let intended_size, exact = Hashtbl.find stdIntegerSizes name in
      if (exact && size <> intended_size) ||
         (not exact && size < intended_size)
      then
        Kernel.warning ~current:true
          "bad type '%a' (%d bits) for typedef '%s';@ \
           check for mismatch between -machdep flag and headers used"
          Typ.pretty typ size name
    with
    (* Not a standard integer type, ignore it. *)
      Not_found -> ()
  end

(* Checks for invalid 'restrict' qualifiers,
   and reports [Kernel.error] if they are found. *)
let rec checkRestrictQualifierDeep t =
  if typeHasQualifier "restrict" t then
    match unrollType t with
    | TArray (bt, _, _) | TPtr (bt, _) ->
      if isFunctionType bt then
        Kernel.error ~once:true ~current:true
          "function pointer type does not allow 'restrict' qualifier"
      else
        checkRestrictQualifierDeep bt
    | _ -> Kernel.error ~once:true ~current:true
             "invalid usage of 'restrict' qualifier"
  else
    match unrollType t with
    | TArray (bt, _, _) | TPtr (bt, _) ->
      checkRestrictQualifierDeep bt
    | TFun (rt, args, _, _) ->
      checkRestrictQualifierDeep rt;
      begin
        match args with
        | None -> ()
        | Some args ->
          List.iter (fun (_, t, _) -> checkRestrictQualifierDeep t) args
      end
    | _ -> ()

let rec doSpecList ghost (suggestedAnonName: string)
    (* This string will be part of
     * the names for anonymous
     * structures and enums  *)
    (specs: Cabs.spec_elem list)
  (* Returns the base type, the storage, whether it is inline and the
   * (unprocessed) attributes *)
  : typ * storage * bool * Cabs.attribute list =
  (* Do one element and collect the type specifiers *)
  let isinline = ref false in (* If inline appears *)
  (* The storage is placed here *)
  let storage : storage ref = ref NoStorage in

  (* Collect the attributes.  Unfortunately, we cannot treat GCC
   * __attributes__ and ANSI C const/volatile the same way, since they
   * associate with structures differently.  Specifically, ANSI
   * qualifiers never apply to structures (ISO 6.7.3), whereas GCC
   * attributes always do (GCC manual 4.30).  Therefore, they are
   * collected and processed separately. *)
  let attrs : Cabs.attribute list ref = ref [] in      (* __attribute__, etc. *)
  let cvattrs : Cabs.cvspec list ref = ref [] in       (* const/volatile *)
  let suggestedAnonName =
    if suggestedAnonName <> "" then suggestedAnonName
    else if get_current_stdheader () = "" then ""
    else "fc_stdlib"
  in
  let doSpecElem (se: Cabs.spec_elem)
      (acc: Cabs.typeSpecifier list)
    : Cabs.typeSpecifier list =
    match se with
    | Cabs.SpecTypedef -> acc
    | Cabs.SpecInline -> isinline := true; acc
    | Cabs.SpecStorage st ->
      if !storage <> NoStorage then
        Kernel.error ~once:true ~current:true "Multiple storage specifiers";
      let sto' =
        match st with
        | Cabs.NO_STORAGE -> NoStorage
        | Cabs.AUTO -> NoStorage
        | Cabs.REGISTER -> Register
        | Cabs.STATIC -> Static
        | Cabs.EXTERN -> Extern
      in
      storage := sto';
      acc

    | Cabs.SpecCV cv -> cvattrs := cv :: !cvattrs; acc
    | Cabs.SpecAttr a -> attrs := a :: !attrs; acc
    | Cabs.SpecType ts -> ts :: acc
    | Cabs.SpecPattern _ -> abort_context "SpecPattern in cabs2cil input"
  in
  (* Now scan the list and collect the type specifiers. Preserve the order *)
  let tspecs = List.fold_right doSpecElem specs [] in

  let tspecs' =
    (* GCC allows a named type that appears first to be followed by things
     * like "short", "signed", "unsigned" or "long". *)
    match tspecs with
    | Cabs.Tnamed _ :: (_ :: _ as rest) when Cil.gccMode () ->
      (* If rest contains "short" or "long" then drop the Tnamed *)
      if List.exists (function Cabs.Tshort -> true
                             | Cabs.Tlong -> true | _ -> false) rest then
        rest
      else
        tspecs

    | _ -> tspecs
  in
  let tspecs'' =
    match specs, List.rev tspecs' with
    | Cabs.SpecTypedef :: _, Cabs.Tnamed _ :: [] ->
      tspecs'
    | Cabs.SpecTypedef :: _, Cabs.Tnamed _ :: rest ->
      List.rev rest
    | _ -> tspecs'
  in
  (* Sort the type specifiers *)
  let sortedspecs =
    let order = function (* Don't change this *)
      | Cabs.Tvoid -> 0
      | Cabs.Tsigned -> 1
      | Cabs.Tunsigned -> 2
      | Cabs.Tchar -> 3
      | Cabs.Tshort -> 4
      | Cabs.Tlong -> 5
      | Cabs.Tint -> 6
      | Cabs.Tint64 -> 7
      | Cabs.Tfloat -> 8
      | Cabs.Tdouble -> 9
      | _ -> 10 (* There should be at most one of the others *)
    in
    List.stable_sort (fun ts1 ts2 ->
        Datatype.Int.compare (order ts1) (order ts2)) tspecs''
  in
  let getTypeAttrs () : Cabs.attribute list =
    (* Partitions the attributes in !attrs.
       Type attributes are removed from attrs and returned, so that they
       can go into the type definition.  Name attributes are left in attrs,
       so they will be returned by doSpecAttr and used in the variable
       declaration.
       Testcase: small1/attr9.c *)
    let an, af, at = cabsPartitionAttributes ghost ~default:AttrType !attrs in
    attrs := an;      (* Save the name attributes for later *)
    if af <> [] then
      Kernel.error ~once:true ~current:true
        "Invalid position for function type attributes.";
    at
  in

  (* And now try to make sense of it. See ISO 6.7.2 *)
  let bt =
    match sortedspecs with
    | [Cabs.Tvoid] -> TVoid []
    | [Cabs.Tchar] -> TInt(IChar, [])
    | [Cabs.Tbool] -> TInt(IBool, [])
    | [Cabs.Tsigned; Cabs.Tchar] -> TInt(ISChar, [])
    | [Cabs.Tunsigned; Cabs.Tchar] -> TInt(IUChar, [])

    | [Cabs.Tshort] -> TInt(IShort, [])
    | [Cabs.Tsigned; Cabs.Tshort] -> TInt(IShort, [])
    | [Cabs.Tshort; Cabs.Tint] -> TInt(IShort, [])
    | [Cabs.Tsigned; Cabs.Tshort; Cabs.Tint] -> TInt(IShort, [])

    | [Cabs.Tunsigned; Cabs.Tshort] -> TInt(IUShort, [])
    | [Cabs.Tunsigned; Cabs.Tshort; Cabs.Tint] -> TInt(IUShort, [])

    | [] -> TInt(IInt, [])
    | [Cabs.Tint] -> TInt(IInt, [])
    | [Cabs.Tsigned] -> TInt(IInt, [])
    | [Cabs.Tsigned; Cabs.Tint] -> TInt(IInt, [])

    | [Cabs.Tunsigned] -> TInt(IUInt, [])
    | [Cabs.Tunsigned; Cabs.Tint] -> TInt(IUInt, [])

    | [Cabs.Tlong] -> TInt(ILong, [])
    | [Cabs.Tsigned; Cabs.Tlong] -> TInt(ILong, [])
    | [Cabs.Tlong; Cabs.Tint] -> TInt(ILong, [])
    | [Cabs.Tsigned; Cabs.Tlong; Cabs.Tint] -> TInt(ILong, [])

    | [Cabs.Tunsigned; Cabs.Tlong] -> TInt(IULong, [])
    | [Cabs.Tunsigned; Cabs.Tlong; Cabs.Tint] -> TInt(IULong, [])

    | [Cabs.Tlong; Cabs.Tlong] -> TInt(ILongLong, [])
    | [Cabs.Tsigned; Cabs.Tlong; Cabs.Tlong] -> TInt(ILongLong, [])
    | [Cabs.Tlong; Cabs.Tlong; Cabs.Tint] -> TInt(ILongLong, [])
    | [Cabs.Tsigned; Cabs.Tlong; Cabs.Tlong; Cabs.Tint] -> TInt(ILongLong, [])

    | [Cabs.Tunsigned; Cabs.Tlong; Cabs.Tlong] -> TInt(IULongLong, [])
    | [Cabs.Tunsigned; Cabs.Tlong; Cabs.Tlong; Cabs.Tint] -> TInt(IULongLong, [])

    (* int64 is to support MSVC *)
    | [Cabs.Tint64] -> TInt(ILongLong, [])
    | [Cabs.Tsigned; Cabs.Tint64] -> TInt(ILongLong, [])

    | [Cabs.Tunsigned; Cabs.Tint64] -> TInt(IULongLong, [])

    | [Cabs.Tfloat] -> TFloat(FFloat, [])
    | [Cabs.Tdouble] -> TFloat(FDouble, [])

    | [Cabs.Tlong; Cabs.Tdouble] -> TFloat(FLongDouble, [])

    (* Now the other type specifiers *)
    | [Cabs.Tnamed "__builtin_va_list"]
      when Cil.theMachine.theMachine.has__builtin_va_list ->
      TBuiltin_va_list []
    | [Cabs.Tnamed "__fc_builtin_size_t"] -> Cil.theMachine.typeOfSizeOf
    | [Cabs.Tnamed n] ->
      (match lookupType ghost "type" n with
       | (TNamed _) as x, _ -> x
       | _ ->
         Kernel.fatal ~current:true "Named type %s is not mapped correctly" n)

    | [Cabs.Tstruct (n, None, _)] -> (* A reference to a struct *)
      if n = "" then
        Kernel.error ~once:true ~current:true
          "Missing struct tag on incomplete struct";
      findCompType ghost "struct" n []
    | [Cabs.Tstruct (n, Some nglist, extraAttrs)] -> (* A definition of a struct *)
      let n' =
        if n <> "" then n else anonStructName "struct" suggestedAnonName in
      (* Use the (non-cv, non-name) attributes in !attrs now *)
      let a = extraAttrs @ (getTypeAttrs ()) in
      makeCompType ghost true n' ~norig:n nglist (doAttributes ghost a)

    | [Cabs.Tunion (n, None, _)] -> (* A reference to a union *)
      if n = "" then
        Kernel.error ~once:true ~current:true
          "Missing union tag on incomplete union";
      findCompType ghost "union" n []
    | [Cabs.Tunion (n, Some nglist, extraAttrs)] -> (* A definition of a union *)
      let n' =
        if n <> "" then n else anonStructName "union" suggestedAnonName in
      (* Use the attributes now *)
      let a = extraAttrs @ (getTypeAttrs ()) in
      makeCompType ghost false n' ~norig:n nglist (doAttributes ghost a)

    | [Cabs.Tenum (n, None, _)] -> (* Just a reference to an enum *)
      if n = "" then
        Kernel.error ~once:true ~current:true
          "Missing enum tag on incomplete enum";
      findCompType ghost "enum" n []

    | [Cabs.Tenum (n, Some eil, extraAttrs)] -> (* A definition of an enum *)
      let n' =
        if n <> "" then n else anonStructName "enum" suggestedAnonName in
      (* make a new name for this enumeration *)
      let n'', _  = newAlphaName ghost true "enum" n' in

      (* Create the enuminfo, or use one that was created already for a
       * forward reference *)
      let enum, _ = createEnumInfo n'' ~norig:n in
      let a = extraAttrs @ (getTypeAttrs ()) in
      enum.eattr <- enum.eattr @ (doAttributes ghost a);
      let res = TEnum (enum, []) in
      let smallest = ref Integer.zero in
      let largest = ref Integer.zero in
      (* Life is fun here. ANSI says: enum constants are ints,
         and there's an implementation-dependent underlying integer
         type for the enum, which must be capable of holding all the
         enum's values.
         For MSVC, we follow these rules and assume the enum's
         underlying type is int.
         GCC allows enum constants that don't fit in int: the enum
         constant's type is the smallest type (but at least int) that
         will hold the value, with a preference for unsigned types.
         The underlying type EI of the enum is picked as follows:
         – let T be the smallest integer type that holds all the enum's
           values; T is signed if any enum value is negative, unsigned otherwise
         – if the enum is packed or sizeof(T) >= sizeof(int), then EI = T
         – otherwise EI = int if T is signed and unsigned int otherwise
         Note that these rules make the enum unsigned if possible *)
      let updateEnum i : ikind =
        if Integer.lt i !smallest then
          smallest := i;
        if Integer.gt i !largest then
          largest := i;
        if Cil.msvcMode () then
          IInt
        else begin
          match Kernel.Enums.get () with
          (* gcc-short-enum will try to pack the enum _type_, not the enum
             constant... *)
          | "" | "help" | "gcc-enums" | "gcc-short-enums" ->
            if fitsInInt IInt i then IInt
            else if fitsInInt IUInt i then IUInt
            else if fitsInInt ILongLong i then ILongLong
            else IULongLong
          | "int" -> IInt
          | s ->
            Kernel.fatal ~current:true "Unknown enums representations '%s'" s
        end
      in
      (* as each name,value pair is determined, this is called *)
      let rec processName kname (i: exp) loc rest = begin
        (* add the name to the environment, but with a faked 'typ' field;
         * we don't know the full type yet (since that includes all of the
         * tag values), but we won't need them in here  *)

        (* add this tag to the list so that it ends up in the real
         * environment when we're finished  *)
        let newname, _  = newAlphaName ghost true "" kname in
        let item = { eiorig_name = kname;
                     einame = newname;
                     eival = i;
                     eiloc = loc;
                     eihost = enum }
        in
        addLocalToEnv ghost kname (EnvEnum item);
        (kname, item) :: loop (increm i 1) rest
      end

      and loop i = function
          [] -> []
        | (kname, { expr_node = Cabs.NOTHING}, cloc) :: rest ->
          (* use the passed-in 'i' as the value, since none specified *)
          processName kname i (convLoc cloc) rest

        | (kname, e, cloc) :: rest ->
          (* constant-eval 'e' to determine tag value *)
          let e' = getIntConstExp ghost e in
          let e' = match constFoldToInt e' with
            | None ->
              Kernel.fatal ~current:true
                "Constant initializer %a not an integer"
                Cil_printer.pp_exp e'
            | Some i ->
              let ik = updateEnum i in
              if theMachine.lowerConstants then
                kinteger64 ~loc:e.expr_loc ~kind:ik i
              else
                e'
          in
          processName kname e' (convLoc cloc) rest
      in

      (*TODO: find a better loc*)
      let fields = loop (zero ~loc:(CurrentLoc.get())) eil in
      (* Now set the right set of items *)
      enum.eitems <- List.map (fun (_, x) -> x) fields;
      (* Pick the enum's kind - see discussion above *)
      begin
        let unsigned = Integer.ge !smallest Integer.zero in
        let smallKind = intKindForValue !smallest unsigned in
        let largeKind = intKindForValue !largest unsigned in
        let real_kind =
          if (bytesSizeOfInt smallKind) > (bytesSizeOfInt largeKind) then
            smallKind
          else
            largeKind
        in
        let ekind =
          match Kernel.Enums.get () with
          | "" | "help" | "gcc-enums" ->
            if hasAttribute "packed" enum.eattr ||
               bytesSizeOfInt real_kind >= bytesSizeOfInt IInt
            then real_kind
            else if unsigned then IUInt else IInt
          | "int" -> IInt
          | "gcc-short-enums" -> real_kind
          | s -> Kernel.fatal ~current:true "Unknown enum representation '%s'" s
        in
        enum.ekind <- ekind;
      end;
      (* Record the enum name in the environment *)
      addLocalToEnv ghost (kindPlusName "enum" n') (EnvTyp res);
      (* And define the tag *)
      cabsPushGlobal (GEnumTag (enum, CurrentLoc.get ()));
      res

    | [Cabs.TtypeofE e] ->
      let (_, s, e', t) =
        doExp (ghost_local_env ghost) CNoConst e AExpLeaveArrayFun
      in
      clean_up_chunk_locals s;
      let t' =
        match e'.enode with
        (* If this is a string literal, then we treat it as in sizeof*)
        | Const (CStr s) -> begin
            match typeOf e' with
            | TPtr(bt, _) -> (* This is the type of array elements *)
              TArray(bt,
                     Some (new_exp ~loc:e'.eloc (SizeOfStr s)),
                     [])
            | _ -> abort_context "The typeOf a string is not a pointer type"
          end
        | _ -> t
      in
      (*
        ignore (E.log "typeof(%a) = %a\n" d_exp e' d_type t');
       *)
      t'

    | [Cabs.TtypeofT (specs, dt)] ->
      doOnlyType ghost specs dt

    | l ->
      Kernel.fatal ~current:true
        "Invalid combination of type specifiers:@ %a"
        (pp_list ~sep:"@ " Cprint.print_type_spec) l;
  in
  bt,!storage,!isinline,List.rev (!attrs @ (convertCVtoAttr !cvattrs))

(* given some cv attributes, convert them into named attributes for
 * uniform processing *)
and convertCVtoAttr (src: Cabs.cvspec list) : Cabs.attribute list =
  match src with
  | [] -> []
  | CV_CONST    :: tl -> ("const",[])    :: (convertCVtoAttr tl)
  | CV_VOLATILE :: tl -> ("volatile",[]) :: (convertCVtoAttr tl)
  | CV_RESTRICT :: tl -> ("restrict",[]) :: (convertCVtoAttr tl)
  | CV_ATTRIBUTE_ANNOT a :: tl -> (mkAttrAnnot a, []) :: convertCVtoAttr tl
  | CV_GHOST    :: tl -> ("ghost",[]) :: (convertCVtoAttr tl)

and makeVarInfoCabs
    ~(ghost:bool)
    ~(isformal: bool)
    ~(isglobal: bool)
    ?(isgenerated=false)
    ?(referenced=false)
    (ldecl : location)
    (bt, sto, inline, attrs)
    (n,ndt,a)
  : varinfo =
  let vtype, nattr =
    doType ghost isformal (AttrName false)
      ~allowVarSizeArrays:isformal  (* For locals we handle var-sized arrays
                                       before makeVarInfoCabs; for formals
                                       we do it afterwards *)
      bt (Cabs.PARENTYPE(attrs, ndt, a)) in
  (*Format.printf "Got yp:%a->%a(%a)@." d_type bt d_type vtype d_attrlist nattr;*)
  if hasAttribute "thread" nattr then begin
    let wkey = Kernel.wkey_inconsistent_specifier in
    let source = fst ldecl in
    if isFunctionType vtype then
      Kernel.warning ~wkey ~source "only objects can be thread-local"
    else if not isglobal && (sto = NoStorage || sto = Register) then
      Kernel.warning ~wkey ~source "a local object cannot be thread-local";
  end;
  if not isgenerated && ghost then begin
    if hasAttribute "ghost" (Cil.typeAttrs vtype) then
      Kernel.warning
        ~wkey:Kernel.wkey_ghost_already_ghost ~once:true ~current:true
        "'%s' is already ghost" n;
    if isArrayType vtype then
      if hasAttribute "ghost" (Cil.typeAttrs (typeOf_array_elem vtype)) then
        Kernel.warning
          ~wkey:Kernel.wkey_ghost_already_ghost ~once:true ~current:true
          "'%s' elements are already ghost" n;
  end ;

  if inline && not (isFunctionType vtype) then
    Kernel.error ~once:true ~current:true "inline for a non-function: %s" n;
  checkRestrictQualifierDeep vtype;
  (*  log "Looking at %s(%b): (%a)@." n isformal d_attrlist nattr;*)
  let vi = makeVarinfo ~ghost ~referenced ~temp:isgenerated ~loc:ldecl isglobal isformal n vtype
  in
  vi.vstorage <- sto;
  vi.vattr <- nattr;
  vi.vdefined <-
    not (isFunctionType vtype) && isglobal && (sto = NoStorage || sto = Static);

  (*  if false then
      log "Created varinfo %s : %a\n" vi.vname d_type vi.vtype;*)

  vi

(* Process a local variable declaration and allow variable-sized arrays *)
and makeVarSizeVarInfo ghost (ldecl : location)
    spec_res
    (n,ndt,a)
  : varinfo * chunk * exp * bool =
  if not (Cil.msvcMode ()) then
    match isVariableSizedArray ghost ndt with
    | None ->
      makeVarInfoCabs ~ghost ~isformal:false
        ~isglobal:false
        ldecl spec_res (n,ndt,a), empty, zero ~loc:ldecl, false
    | Some (ndt', se, len) ->
      makeVarInfoCabs ~ghost ~isformal:false
        ~isglobal:false
        ldecl spec_res (n,ndt',a), se, len, true
  else
    makeVarInfoCabs ~ghost ~isformal:false
      ~isglobal:false
      ldecl spec_res (n,ndt,a), empty, zero ~loc:ldecl, false

and doAttr ghost (a: Cabs.attribute) : attribute list =
  (* Strip the leading and trailing underscore *)
  match a with
  | ("__attribute__", []) -> []  (* An empty list of gcc attributes *)
  | (s, []) ->
    let s = stripUnderscore s in
    [ match attrAnnot s with None -> Attr(s, []) | Some s -> AttrAnnot s ]
  | (s, el) ->

    let rec attrOfExp (strip: bool)
        ?(foldenum=true)
        (a: Cabs.expression) : attrparam =
      let loc = a.expr_loc in
      match a.expr_node with
      | Cabs.VARIABLE n -> begin
          let n' = if strip then stripUnderscore n else n in
          (* See if this is an enumeration *)
          try
            if not foldenum then raise Not_found;
            let env = if ghost then ghost_env else env in
            match Datatype.String.Hashtbl.find env n' with
            | EnvEnum item, _ -> begin
                match constFoldToInt item.eival with
                | Some i64 when theMachine.lowerConstants ->
                  AInt i64
                |  _ -> ACons(n', [])
              end
            | _ -> ACons (n', [])
          with Not_found -> ACons(n', [])
        end
      | Cabs.CONSTANT (Cabs.CONST_STRING s) -> AStr s
      | Cabs.CONSTANT (Cabs.CONST_INT str) -> begin
          match parseIntExpRes ~loc str with
          | Ok {enode = Const (CInt64 (v64,_,_)) } ->
            AInt v64
          | _ ->
            Kernel.error ~current:true "Invalid attribute constant: %s" str;
            AInt Integer.one
        end
      | Cabs.CONSTANT (Cabs.CONST_FLOAT str) ->
        ACons ("__fc_float", [AStr str])
      | Cabs.CALL({expr_node = Cabs.VARIABLE n}, args, []) -> begin
          let n' = if strip then stripUnderscore n else n in
          let ae' = List.map ae args in
          ACons(n', ae')
        end
      | Cabs.EXPR_SIZEOF e -> ASizeOfE (ae e)
      | Cabs.TYPE_SIZEOF (bt, dt) -> ASizeOf (doOnlyType ghost bt dt)
      | Cabs.EXPR_ALIGNOF e -> AAlignOfE (ae e)
      | Cabs.TYPE_ALIGNOF (bt, dt) -> AAlignOf (doOnlyType ghost bt dt)
      | Cabs.BINARY(Cabs.AND, aa1, aa2) ->
        ABinOp(LAnd, ae aa1, ae aa2)
      | Cabs.BINARY(Cabs.OR, aa1, aa2) ->
        ABinOp(LOr, ae aa1, ae aa2)
      | Cabs.BINARY(Cabs.ASSIGN,aa1,aa2) ->
        (* Bit of a hack to account for OSX specific syntax. *)
        ACons ("__fc_assign", [ae aa1; ae aa2])
      | Cabs.BINARY(abop, aa1, aa2) ->
        ABinOp (convBinOp abop, ae aa1, ae aa2)
      | Cabs.UNARY(Cabs.PLUS, aa) -> ae aa
      | Cabs.UNARY(Cabs.MINUS, aa) -> AUnOp (Neg, ae aa)
      | Cabs.UNARY(Cabs.BNOT, aa) -> AUnOp(BNot, ae aa)
      | Cabs.UNARY(Cabs.NOT, aa) -> AUnOp(LNot, ae aa)
      | Cabs.MEMBEROF (e, s) -> ADot (ae e, s)
      | Cabs.PAREN(e) -> attrOfExp strip ~foldenum:foldenum e
      | Cabs.UNARY(Cabs.MEMOF, aa) -> AStar (ae aa)
      | Cabs.UNARY(Cabs.ADDROF, aa) -> AAddrOf (ae aa)
      | Cabs.MEMBEROFPTR (aa1, s) -> ADot(AStar(ae aa1), s)
      | Cabs.INDEX(aa1, aa2) -> AIndex(ae aa1, ae aa2)
      | Cabs.QUESTION(aa1, aa2, aa3) -> AQuestion(ae aa1, ae aa2, ae aa3)
      | _ ->
        Kernel.fatal ~current:true
          "cabs2cil: invalid expression in attribute: %a"
          Cprint.print_expression a

    and ae (e: Cabs.expression) = attrOfExp false e in

    (* Sometimes we need to convert attrarg into attr *)
    let arg2attr = function
      | ACons (s, args) -> Attr (s, args)
      | a ->
        Kernel.fatal ~current:true
          "Invalid form of attribute: %a"
          Cil_printer.pp_attrparam a;
    in
    if s = "__attribute__" then (* Just a wrapper for many attributes*)
      List.map (fun e -> arg2attr (attrOfExp true ~foldenum:false e)) el
    else if s = "__blockattribute__" then (* Another wrapper *)
      List.map (fun e -> arg2attr (attrOfExp true ~foldenum:false e)) el
    else if s = "__declspec" then
      List.map (fun e -> arg2attr (attrOfExp false ~foldenum:false e)) el
    else
      [Attr(stripUnderscore s, List.map (attrOfExp ~foldenum:false false) el)]

and doAttributes (ghost:bool) (al: Cabs.attribute list) : attribute list =
  List.fold_left (fun acc a -> cabsAddAttributes (doAttr ghost a) acc) [] al

(* A version of Cil.partitionAttributes that works on CABS attributes.
   It would  be better to use Cil.partitionAttributes instead to avoid
   the extra doAttr conversions here, but that's hard to do in doSpecList.*)
and cabsPartitionAttributes
    ghost
    ~(default:attributeClass)
    (attrs:  Cabs.attribute list) :
  Cabs.attribute list * Cabs.attribute list * Cabs.attribute list =
  let rec loop (n,f,t) = function
      [] -> n, f, t
    | a :: rest ->
      let kind = match doAttr ghost a with
        | [] -> default
        | (Attr(an, _) | AttrAnnot an)::_ ->
          (try attributeClass an with Not_found -> default)
      in
      match kind with
      | AttrName _ -> loop (a::n, f, t) rest
      | AttrFunType _ -> loop (n, a::f, t) rest
      | AttrType -> loop (n, f, a::t) rest
  in
  loop ([], [], []) attrs



and doType (ghost:bool) isFuncArg
    (nameortype: attributeClass) (* This is AttrName if we are doing
                                  * the type for a name, or AttrType
                                  * if we are doing this type in a
                                  * typedef *)
    ?(allowZeroSizeArrays=false)
    ?(allowVarSizeArrays=false)
    (bt: typ)                    (* The base type *)
    (dt: Cabs.decl_type)
  (* Returns the new type and the accumulated name (or type attribute
     if nameoftype =  AttrType) attributes *)
  : typ * attribute list =

  (* Now do the declarator type. But remember that the structure of the
   * declarator type is as printed, meaning that it is the reverse of the
   * right one *)
  let rec doDeclType (bt: typ) (acc: attribute list) decl_type =
    checkRestrictQualifierDeep bt;
    match decl_type with
    | Cabs.JUSTBASE -> bt, acc
    | Cabs.PARENTYPE (a1, d, a2) ->
      let a1' = doAttributes ghost a1 in
      let a1n, a1f, a1t = partitionAttributes ~default:AttrType a1' in
      let a2' = doAttributes ghost a2 in
      let a2n, a2f, a2t = partitionAttributes ~default:nameortype a2' in
      (*Format.printf "doType: @[a1n=%a@\na1f=%a@\na1t=%a@\na2n=%a@\na2f=%a@\na2t=%a@]@\n" d_attrlist a1n d_attrlist a1f d_attrlist a1t d_attrlist a2n d_attrlist a2f d_attrlist a2t;*)
      let bt' = cabsTypeAddAttributes a1t bt in
      (*        log "bt' = %a@." d_type bt';*)

      let bt'', a1fadded =
        match unrollType bt with
        | TFun _ -> cabsTypeAddAttributes a1f bt', true
        | _ -> bt', false
      in
      (* Now recurse *)
      let restyp, nattr = doDeclType bt'' acc d in
      (* Add some more type attributes *)
      let restyp = cabsTypeAddAttributes a2t restyp in
      (* See if we can add some more type attributes *)
      let restyp' =
        match unrollType restyp with
        | TFun _ ->
          if a1fadded then
            cabsTypeAddAttributes a2f restyp
          else
            cabsTypeAddAttributes a2f
              (cabsTypeAddAttributes a1f restyp)
        | TPtr ((TFun _ as tf), ap) when not (Cil.msvcMode ()) ->
          if a1fadded then
            TPtr(cabsTypeAddAttributes a2f tf, ap)
          else
            TPtr(cabsTypeAddAttributes a2f
                   (cabsTypeAddAttributes a1f tf), ap)
        | _ ->
          if a1f <> [] && not a1fadded then
            Kernel.error ~once:true ~current:true
              "Invalid position for (prefix) function type attributes:%a"
              Cil_printer.pp_attributes a1f;
          if a2f <> [] then
            Kernel.error ~once:true ~current:true
              "Invalid position for (post) function type attributes:%a"
              Cil_printer.pp_attributes a2f;
          restyp
      in
      (*        log "restyp' = %a@." d_type restyp';*)

      (* Now add the name attributes and return *)
      restyp', cabsAddAttributes a1n (cabsAddAttributes a2n nattr)

    | Cabs.PTR (al, d) ->
      let al' = doAttributes ghost al in
      let an, af, at = partitionAttributes ~default:AttrType al' in
      (* Now recurse *)
      let restyp, nattr = doDeclType (TPtr(bt, at)) acc d in
      (* See if we can do anything with function type attributes *)
      let restyp' =
        match unrollType restyp with
        | TFun _ -> cabsTypeAddAttributes af restyp
        | TPtr((TFun _ as tf), ap) ->
          TPtr(cabsTypeAddAttributes af tf, ap)
        | _ ->
          if af <> [] then
            Kernel.error ~once:true ~current:true
              "Invalid position for function type attributes:%a"
              Cil_printer.pp_attributes af;
          restyp
      in
      (* Now add the name attributes and return *)
      restyp', cabsAddAttributes an nattr

    | Cabs.ARRAY (d, al, len) ->
      if Cil.isFunctionType bt then
        Kernel.error ~once:true ~current:true
          "declaration of array of function type '%a`"
          Cil_datatype.Typ.pretty bt
      else if not (Cil.isCompleteType ~allowZeroSizeArrays:true bt) then
        Kernel.error ~once:true ~current:true
          "declaration of array of incomplete type '%a`"
          Cil_datatype.Typ.pretty bt
      else if not allowZeroSizeArrays &&
              not (Cil.isCompleteType ~allowZeroSizeArrays:false bt)
      then
        (* because we tested previously for incomplete types and now tested again
           forbidding zero-length arrays, bt is necessarily a zero-length array *)
        if Cil.gccMode () || Cil.msvcMode () then
          Kernel.warning ~once:true ~current:true
            "declaration of array of 'zero-length arrays' ('%a`);@ \
             zero-length arrays are a compiler extension"
            Cil_datatype.Typ.pretty bt
        else
          Kernel.error ~once:true ~current:true
            "declaration of array of 'zero-length arrays' ('%a`);@ \
             zero-length arrays are not allowed in C99"
            Cil_datatype.Typ.pretty bt;
      let lo =
        match len.expr_node with
        | Cabs.NOTHING -> None
        | _ ->
          (* Check that len is a constant expression.
             We used to also cast the length to int here, but that's
             theoretically too restrictive on 64-bit machines. *)
          let len' = doPureExp (ghost_local_env ghost) len in
          if not (isIntegralType (typeOf len')) then
            Kernel.error ~once:true ~current:true
              "Array length %a does not have an integral type."
              Cil_printer.pp_exp len';
          (* Check that len' is admissible *)
          let cst = constFold true len' in
          (match cst.enode with
           | Const(CInt64(i, _, _)) ->
             if Integer.lt i Integer.zero then
               Kernel.error ~once:true ~current:true
                 "Array length is negative."
           | _  when not allowVarSizeArrays ->
             if isConstant cst then
               (* e.g., there may be a float constant involved.
                * We'll leave it to the user to ensure the length is
                * non-negative, etc.*)
               Kernel.warning ~once:true ~current:true
                 "Unable to do constant-folding on array length %a. \
                  Some CIL operations on this array may fail."
                 Cil_printer.pp_exp cst
             else
               Kernel.error ~once:true ~current:true
                 "Array length %a is not a compile-time constant,@ \
                  and currently VLAs may only have their first dimension \
                  as variable."
                 Cil_printer.pp_exp cst
           | _ -> ());
          if Cil.isZero len' && not allowZeroSizeArrays &&
             not (Cil.gccMode () || Cil.msvcMode ())
          then
            Kernel.error ~once:true ~current:true
              "zero-length arrays %s" (Cil.allowed_machdep "GCC/MSVC");
          Some len'
      in
      let al' = doAttributes ghost al in
      if not isFuncArg && hasAttribute "static" al' then
        Kernel.error ~once:true ~current:true
          "static specifier inside array argument is allowed only in \
           function argument";
      doDeclType (TArray(bt, lo, al')) acc d

    | Cabs.PROTO (d, args, ghost_args, isva) ->
      (* Start a scope for the parameter names *)
      enterScope ();
      (* Intercept the old-style use of varargs.h. On GCC this means that
       * we have ellipsis and a last argument "builtin_va_alist:
       * builtin_va_alist_t". On MSVC we do not have the ellipsis and we
       * have a last argument "va_alist: va_list" *)
      let args', isva' =
        if args != [] && Cil.msvcMode () = not isva then begin
          let newisva = ref isva in
          let rec doLast = function
              [([Cabs.SpecType (Cabs.Tnamed atn)], (an, Cabs.JUSTBASE, [], _))]
              when isOldStyleVarArgTypeName atn &&
                   isOldStyleVarArgName an -> begin
                (* Turn it into a vararg *)
                newisva := true;
                (* And forget about this argument *)
                []
              end

            | a :: rest -> a :: doLast rest
            | [] -> []
          in
          let args' = doLast args in
          (args', !newisva)
        end else (args, isva)
      in
      (* Make the argument as for a formal *)
      let doOneArg argl_length is_ghost (s, (n, ndt, a, cloc)) : varinfo =
        let ghost = is_ghost || ghost in
        let s' = doSpecList ghost n s in
        let vi = makeVarInfoCabs ~ghost ~isformal:true ~isglobal:false
            (convLoc cloc) s' (n,ndt,a) in
        if isVoidType vi.vtype then begin
          if argl_length > 1 then
            Kernel.error ~once:true ~current:true
              "'void' must be the only parameter if specified";
          if vi.vname <> "" then
            Kernel.error ~once:true ~current:true
              "named parameter '%s' has void type" vi.vname
        end;
        (* Add the formal to the environment, so it can be referenced by
           other formals  (e.g. in an array type, although that will be
           changed to a pointer later, or though typeof).  *)
        addLocalToEnv ghost vi.vname (EnvVar vi);
        vi
      in
      let make_noopt_targs ghost args =
        let argl_length = List.length args in
        List.map (doOneArg argl_length ghost) args
      in
      let noopt_targs = make_noopt_targs false args' in
      let noopt_ghost_targs = make_noopt_targs true ghost_args in
      let targs : varinfo list option =
        match noopt_targs with
        | [] -> None (* No argument list *)
        | [t] when isVoidType t.vtype -> Some []
        | l -> Some l
      in
      let ghost_targs : varinfo list =
        match noopt_ghost_targs with
        | [t] when isVoidType t.vtype ->
          Kernel.error ~once:true ~current:true
            "ghost parameters list cannot be void" ;
          []
        | l -> l
      in
      let all_targs =
        match targs, ghost_targs with
        | None, [] -> None
        | None, g -> Some g
        | Some ng, g -> Some (ng @ g)
      in
      exitScope ();
      (* Turn [] types into pointers in the arguments and the result type.
       * Turn function types into pointers to respective. This simplifies
       * our life a lot, and is what the standard requires. *)
      let turnArrayIntoPointer (bt: typ)
          (lo: exp option) (a: attributes) : typ =
        let main_attrs = dropAttribute "static" a in
        let a' : attributes =
          match lo with
          | None -> []
          | Some l -> begin
              let static = if hasAttribute "static" a then
                  [Attr ("static",[])]
                else []
              in
              (* Transform the length into an attribute expression *)
              try
                let la : attrparam = expToAttrParam l in
                Attr("arraylen", [ la ]) :: static
              with NotAnAttrParam _ -> begin
                  Kernel.warning ~once:true ~current:true
                    "Cannot represent the length '%a' of array as an attribute"
                    Cil_printer.pp_exp l
                  ;
                  static (* Leave unchanged *)
                end
            end
        in
        let attrs = Cil.addAttributes a' main_attrs in
        TPtr(bt, attrs)
      in
      let rec fixupArgumentTypes (argidx: int) (args: varinfo list) : unit =
        match args with
        | [] -> ()
        | a :: args' ->
          (match unrollType a.vtype with
           | TArray(bt,lo,attr) ->
             (* Note that for multi-dimensional arrays we strip off only
                the first TArray and leave bt alone. *)
             let real_type = turnArrayIntoPointer bt lo attr in
             Cil.update_var_type a real_type
           | TFun _ -> Cil.update_var_type a (TPtr(a.vtype, []))
           | TComp (_,_) -> begin
               match isTransparentUnion a.vtype with
               | None ->  ()
               | Some fstfield ->
                 transparentUnionArgs :=
                   (argidx, a.vtype) :: !transparentUnionArgs;
                 Cil.update_var_type a fstfield.ftype;
             end
           | _ -> ());
          fixupArgumentTypes (argidx + 1) args'
      in
      let args =
        match all_targs with
        | None -> None
        | Some argl ->
          fixupArgumentTypes 0 argl;
          let arg_type_from_vi vi =
            let attrs =
              if vi.vghost then
                cabsAddAttributes [Attr (frama_c_ghost_formal, [])] vi.vattr
              else
                vi.vattr
            in (vi.vname, vi.vtype, attrs)
          in
          Some (List.map arg_type_from_vi argl)
      in
      let tres =
        match unrollType bt with
        | TArray(t,lo,attr) -> turnArrayIntoPointer t lo attr
        | _ -> bt
      in
      (* Drop qualifiers on the return type. They are meaningless (qualifiers
         make sense only on l-values), and they make life more complicated:
         the return type of the function is used e.g. for the type of retres,
         and probably in many other places. *)
      let tres = Cil.type_remove_qualifier_attributes tres in
      doDeclType (TFun (tres, args, isva', [])) acc d
  in
  doDeclType bt [] dt

(* If this is a declarator for a variable size array then turn it into a
   pointer type and a length *)
and isVariableSizedArray ghost (dt: Cabs.decl_type)
  : (Cabs.decl_type * chunk * exp) option =
  let res = ref None in
  let rec findArray = function
      ARRAY (JUSTBASE, al, lo) when lo.expr_node != Cabs.NOTHING ->
      (* Checks whether the expression is an integer constant expression,
         that is:
         – it contains no side-effect
         – it can be evaluated at compile-time
         Note that we should not pass true as asconst argument for doExp,
         since we are precisely trying to determine whether the expression
         is a constant or not.
      *)
      let (_, se, e', _) =
        doExp (ghost_local_env ghost) CMayConst lo (AExp (Some intType)) in
      if isNotEmpty se || not (isConstant e') then begin
        res := Some (se, e');
        PTR (al, JUSTBASE)
      end else
        ARRAY (JUSTBASE, al, lo)
    | ARRAY (dt, al, lo) -> ARRAY (findArray dt, al, lo)
    | PTR (al, dt) -> PTR (al, findArray dt)
    | JUSTBASE -> JUSTBASE
    | PARENTYPE (prea, dt, posta) -> PARENTYPE (prea, findArray dt, posta)
    | PROTO (dt, f, g, a) -> PROTO (findArray dt, f, g, a)
  in
  let dt' = findArray dt in
  match !res with
  | None -> None
  | Some (se, e) -> Some (dt', se, e)

and doOnlyType ghost (specs: Cabs.spec_elem list) (dt: Cabs.decl_type) : typ =
  let bt',sto,inl,attrs = doSpecList ghost "" specs in
  if sto <> NoStorage || inl then
    Kernel.error ~once:true ~current:true "Storage or inline specifier in type only";
  let tres, nattr =
    doType ghost false AttrType bt' (Cabs.PARENTYPE(attrs, dt, [])) in
  if nattr <> [] then
    Kernel.error ~once:true ~current:true
      "Name attributes in only_type: %a" Cil_printer.pp_attributes nattr;
  tres


and makeCompType ghost (isstruct: bool)
    (n: string)
    ~(norig: string)
    (nglist: Cabs.field_group list)
    (a: attribute list) =
  (* Make a new name for the structure *)
  let kind = if isstruct then "struct" else "union" in
  let n', _  = newAlphaName ghost true kind n in
  (* Create the self cell for use in fields and forward references. Or maybe
   * one exists already from a forward reference  *)
  let comp, _ = createCompInfo isstruct n' ~norig in
  let rec fold f acc = function
    | [] -> acc
    | [x] -> f ~last:true acc x
    | x :: l -> fold f (f ~last:false acc x) l
  in

  let addFieldGroup ~last:last_group (flds : fieldinfo list)
      ((s: Cabs.spec_elem list), (nl: (Cabs.name * Cabs.expression option) list)) =
    (* Do the specifiers exactly once *)
    let sugg = match nl with
      | [] -> ""
      | ((n, _, _, _), _) :: _ -> n
    in
    let bt, sto, inl, attrs = doSpecList ghost sugg s in
    (* Do the fields *)
    let addFieldInfo ~last:last_field (flds : fieldinfo list)
        (((n,ndt,a,cloc) : Cabs.name), (widtho : Cabs.expression option))
      : fieldinfo list =
      let source = fst cloc in
      if sto <> NoStorage || inl then
        Kernel.error ~once:true ~source "Storage or inline not allowed for fields";
      let allowZeroSizeArrays = Cil.gccMode () || Cil.msvcMode () in
      let ftype, fattr =
        doType
          ~allowZeroSizeArrays ghost false (AttrName false) bt
          (Cabs.PARENTYPE(attrs, ndt, a))
      in
      (* check for fields whose type is incomplete. In particular, this rules
         out circularity:
         struct C1 { struct C2 c2; };          //This line is now an error.
         struct C2 { struct C1 c1; int dummy; };
      *)
      if Cil.isFunctionType ftype then
        Kernel.error ~source
          "field `%s' declared as a function" n
      else if Cil.has_flexible_array_member ftype && isstruct then begin
        if not (last_group && last_field) then
          Kernel.error ~source
            "non-final field `%s' declared with a type containing a flexible \
             array member."
            n
        else if not (Cil.gccMode() || Cil.msvcMode ()) then
          Kernel.error ~source
            "field `%s' declared with a type containing a flexible array \
             member %s."
            n (Cil.allowed_machdep "GCC/MSVC")
      end
      else if not (Cil.isCompleteType ~allowZeroSizeArrays ftype)
      then begin
        match Cil.unrollType ftype with
        | TArray(_,None,_) when last_group && last_field ->
          begin
            (* possible flexible array member; check if struct contains at least
               one other field *)
            if flds = [] then (* struct is empty *)
              Kernel.error ~source
                "flexible array member '%s' (type %a) \
                 not allowed in otherwise empty struct"
                n Cil_datatype.Typ.pretty ftype
            else (* valid flexible array member *) ()
          end
        | _ ->
          Kernel.error ~source
            "field `%s' is declared with incomplete type %a"
            n Cil_datatype.Typ.pretty ftype
      end;
      let fbitfield, ftype =
        match widtho with
        | None -> None, ftype
        | Some w -> begin
            let source = fst w.expr_loc in
            (match unrollType ftype with
             | TInt (_, _) -> ()
             | TEnum _ -> ()
             | _ ->
               Kernel.abort ~once:true ~source
                 "Base type for bitfield is not an integer type");
            match isIntegerConstant ghost w with
            | None ->
              Kernel.abort ~source
                "bitfield width is not a valid integer constant";
            | Some s as w ->
              begin
                if s < 0 then
                  Kernel.abort ~source "negative bitfield width (%d)" s;
                try
                  if s > Cil.bitsSizeOf ftype then
                    Kernel.error ~source
                      "bitfield width (%d) exceeds its type (%a, %d bits)"
                      s Cil_datatype.Typ.pretty ftype (Cil.bitsSizeOf ftype)
                with
                  SizeOfError _ ->
                  Kernel.fatal ~source
                    "Unable to compute size of %a" Cil_datatype.Typ.pretty ftype
              end;
              let ftype =
                typeAddAttributes
                  [Attr (bitfield_attribute_name, [AInt (Integer.of_int s)])]
                  ftype
              in
              w, ftype
          end
      in
      (* Compute the order of the field in the structure *)
      let forder = match flds with
        | [] -> 0
        | { forder=previous_order } :: _ -> previous_order + 1
      in
      (* If the field is unnamed and its type is a structure of union type
       * then give it a distinguished name  *)
      let fname =
        if n = missingFieldName then begin
          match unrollType ftype with
          | TComp _ -> begin
              if not (Kernel.C11.get ()) then
                Kernel.warning ~once:true ~current:true
                  "unnamed fields are a C11 extension \
                   (use %s to avoid this warning)"
                  Kernel.C11.name;
              incr anonCompFieldNameId;
              anonCompFieldName ^ (string_of_int !anonCompFieldNameId)
            end
          | _ -> n
        end else begin
          if fbitfield = Some 0 then
            Kernel.error ~source:(fst cloc)
              "named bitfield (%s) with zero width" n;
          n
        end
      in
      let rec is_circular t =
        match Cil.unrollType t with
        | TArray(bt,_,_) -> is_circular bt
        | TComp (comp',_) ->
          if Cil_datatype.Compinfo.equal comp comp' then begin
            (* abort and not error, as this circularity could lead
               to infinite recursion... *)
            Kernel.abort ~current:true
              "type %s %s is circular"
              (if comp.cstruct then "struct" else "union")
              comp.cname;
          end else
            List.iter
              (fun f -> is_circular f.ftype)
              (Option.value ~default:[] comp'.cfields);
        | _ -> ()
      in
      is_circular ftype;
      { fcomp =  comp;
        forder;
        forig_name = n;
        fname;
        ftype;
        fbitfield;
        fattr;
        floc =  convLoc cloc;
        faddrof = false;
        fsize_in_bits = None;
        foffset_in_bits = None;
      } :: flds
    in
    fold addFieldInfo flds nl
  in

  (* Do regular fields first. *)
  let to_field = function
    | TYPE_ANNOT _ -> None
    | STATIC_ASSERT_FG (e, s, loc) ->
      let (_, _, cond_exp, _) = doExp empty_local_env CConst e ADrop in
      begin
        match Cil.constFoldToInt ~machdep:true cond_exp with
        | Some i ->
          if Integer.(equal i zero) then
            Kernel.error ~source:(fst loc) "static assertion failed%s%s@."
              (if s <> "" then ": " else "") s
        | None ->
          Kernel.error ~source:(fst loc)
            "failed to evaluate constant expression in static assertion:@ \
             @[%a@]"
            Cprint.print_expression e
      end;
      (* _Static_assert is not stored in the Cil AST *)
      None
    | FIELD (f,g) -> Some (f,g) in
  let flds = Extlib.filter_map_opt to_field nglist in
  let flds = List.rev (fold addFieldGroup [] flds) in

  let fld_table = Hashtbl.create 17 in
  let check f =
    try
      let oldf = Hashtbl.find fld_table f.fname in
      let source = fst f.floc in
      Kernel.error ~source
        "field %s occurs multiple times in aggregate %a. \
         Previous occurrence is at line %d."
        f.fname Cil_datatype.Typ.pretty (TComp(comp,[]))
        (fst oldf.floc).Filepath.pos_lnum
    with Not_found ->
      (* Do not add unnamed bitfields: they can share the empty name. *)
      if f.fname <> "" then Hashtbl.add fld_table f.fname f
  in
  if flds = [] && not (Cil.acceptEmptyCompinfo ()) then
    Kernel.error ~current:true ~once:true
      "empty %ss %s"
      (if comp.cstruct then "struct" else "union")
      (Cil.allowed_machdep "GCC/MSVC");
  List.iter check flds;
  if comp.cfields <> None then begin
    let old_fields = Option.get comp.cfields in
    (* This appears to be a multiply defined structure. This can happen from
     * a construct like "typedef struct foo { ... } A, B;". This is dangerous
     * because at the time B is processed some forward references in { ... }
     * appear as backward references, which could lead to circularity in
     * the type structure. We do a thorough check and then we reuse the type
     * for A *)
    if List.length old_fields <> List.length flds
    || (List.exists2 (fun f1 f2 -> not (Cil_datatype.Typ.equal f1.ftype f2.ftype))
          old_fields flds)
    then
      Kernel.error ~once:true ~current:true
        "%s seems to be multiply defined" (compFullName comp)
  end else
    begin
      comp.cfields <- Some flds;
      let fields_with_pragma_attrs =
        List.map (fun fld ->
            (* note: in the call below, we CANNOT use fld.fcomp.cattr because it has not
               been filled in yet, so we need to pass the list of attributes [a] to it *)
            {fld with fattr = (process_pragmas_pack_align_field_attributes fld fld.fattr a)}
          ) flds
      in
      comp.cfields <- Some fields_with_pragma_attrs
    end;

  (*  ignore (E.log "makeComp: %s: %a\n" comp.cname d_attrlist a); *)
  let a = Cil.addAttributes comp.cattr a in
  comp.cattr <- process_pragmas_pack_align_comp_attributes comp a;
  let res = TComp (comp, []) in
  (* Create a typedef for this one *)
  cabsPushGlobal (GCompTag (comp, CurrentLoc.get ()));

  (* There must be a self cell created for this already *)
  addLocalToEnv ghost (kindPlusName kind n) (EnvTyp res);
  (* Now create a typedef with just this type *)
  res

and preprocessCast ghost (specs: Cabs.specifier)
    (dt: Cabs.decl_type)
    (ie: Cabs.init_expression)
  : Cabs.specifier * Cabs.decl_type * Cabs.init_expression =
  let typ = doOnlyType ghost specs dt in
  (* If we are casting to a union type then we have to treat this as a
   * constructor expression. This is to handle the gcc extension that allows
   * cast from a type of a field to the type of the union  *)
  (* However, it may just be casting of a whole union to its own type.  We
   * will resolve this later, when we'll convert casts to unions. *)
  let ie' =
    match unrollType typ, ie with
    | TComp (c, _), Cabs.SINGLE_INIT _ when not c.cstruct ->
      Cabs.COMPOUND_INIT [(Cabs.INFIELD_INIT ("___matching_field",
                                              Cabs.NEXT_INIT),
                           ie)]
    | _, _ -> ie
  in
  (* Maybe specs contains an unnamed composite. Replace with the name so that
   * when we do again the specs we get the right name  *)
  let specs1 =
    match typ with
    | TComp (ci, _) ->
      List.map
        (function
            Cabs.SpecType (Cabs.Tstruct ("", _, [])) ->
            Cabs.SpecType (Cabs.Tstruct (ci.cname, None, []))
          | Cabs.SpecType (Cabs.Tunion ("", _, [])) ->
            Cabs.SpecType (Cabs.Tunion (ci.cname, None, []))
          | s -> s) specs
    | _ -> specs
  in
  specs1, dt, ie'

and getIntConstExp ghost (aexp) : exp =
  let loc = aexp.expr_loc in
  let _, c, e, _ = doExp (ghost_local_env ghost) CConst aexp (AExp None) in
  if not (isEmpty c) then
    Kernel.error ~once:true ~current:true "Constant expression %a has effects"
      Cil_printer.pp_exp e;
  match e.enode with
  (* first, filter for those Const exps that are integers *)
  | Const (CInt64 _ ) -> e
  | Const (CEnum _) -> e
  | Const (CChr i) -> new_exp ~loc (Const(charConstToIntConstant i))

  (* other Const expressions are not ok *)
  | Const _ ->
    Kernel.fatal ~current:true "Expected integer constant and got %a"
      Cil_printer.pp_exp e

  (* now, anything else that 'doExp true' returned is ok (provided
     that it didn't yield side effects); this includes, in particular,
     the various sizeof and alignof expression kinds *)
  | _ -> e

and isIntegerConstant ghost (aexp) : int option =
  match doExp (ghost_local_env ghost) CMayConst aexp (AExp None) with
  | (_, c, e, _) when isEmpty c -> constFoldToInteger e
  | _ -> None

(* Process an expression and in the process do some type checking,
 * extract the effects as separate statements.
 * doExp returns the following 4-uple:
 * - a list of read accesses performed for the evaluation of the expression
 * - a chunk representing side-effects occurring during evaluation
 * - the CIL expression
 * - its type.
*)
and doExp local_env
    (asconst: expConst)   (* This expression is used as a constant *)
    (e: Cabs.expression)
    (what: expAction)
  =
  let ghost = local_env.is_ghost in
  let loc = e.expr_loc in
  (* will be reset at the end of the compilation of current expression. *)
  let oldLoc = CurrentLoc.get() in
  CurrentLoc.set loc;
  let checkVoidLval e t =
    if (match e.enode with Lval _ -> true | _ -> false) && isVoidType t then
      Kernel.fatal ~current:true
        "lvalue of type void: %a@\n" Cil_printer.pp_exp e
  in
  (* A subexpression of array type is automatically turned into StartOf(e).
   * Similarly an expression of function type is turned into AddrOf. So
   * essentially doExp should never return things of type TFun or TArray *)
  let processArrayFun e t =
    let loc = e.eloc in
    match e.enode, unrollType t with
    | (Lval(lv) | CastE(_, {enode = Lval lv})), TArray(tbase, _, a) ->
      mkStartOfAndMark loc lv, TPtr(tbase, a)
    | Lval(Mem _, _), TFun _ -> e, t (* Do not turn pointer function types *)
    | (Lval(lv) | CastE(_, {enode = Lval lv})), TFun _  ->
      mkAddrOfAndMark loc lv, TPtr(t, [])
    | _, (TArray _ | TFun _) ->
      Kernel.fatal ~current:true
        "Array or function expression is not lval: %a@\n"
        Cil_printer.pp_exp e
    | _ -> e, t
  in
  (* Before we return we call finishExp *)
  let finishExp ?(newWhat=what) reads (se: chunk) (e: exp) (t: typ) =
    match newWhat with
    | ADrop
    | AType ->
      let (e', t') = processArrayFun e t in
      (reads, se, e', t')
    | AExpLeaveArrayFun ->
      (reads, se, e, t)
    (* It is important that we do not do "processArrayFun" in
     * this case. We exploit this when we process the typeOf construct *)
    | AExp _ ->
      let (e', t') = processArrayFun e t in
      checkVoidLval e' t';
      (*
        ignore (E.log "finishExp: e'=%a, t'=%a\n"
        Cil_printer.pp_exp e' d_type t');
       *)
      (reads, se, e', t')

    | ASet (is_real_write,lv, r, lvt) -> begin
        (* See if the set was done already *)
        match e.enode with
        | Lval(lv') when lv == lv' ->
          (reads,se, e, t) (* if this is the case, the effects have also been
                              taken into account in the chunk. *)
        | _ ->
          let (e', t') = processArrayFun e t in
          let (t'', e'') = castTo t' lvt e' in
          checkVoidLval e'' t'';
          (*Kernel.debug "finishExp: e = %a\n  e'' = %a\n" Cil_printer.pp_exp e Cil_printer.pp_exp e'';*)
          let writes = if is_real_write then [lv] else [] in
          ([], (* the reads are incorporated in the chunk. *)
           ((unspecified_chunk empty) @@ (remove_reads lv se, ghost))
           +++
           (mkStmtOneInstr ~ghost ~valid_sid (Set(lv, e'', CurrentLoc.get ())),
            writes,writes,
            List.filter (fun x -> not (LvalStructEq.equal x lv)) r @ reads),
           e'', t'')

      end
  in
  let result =
    match e.expr_node with
    | Cabs.PAREN e -> doExp (paren_local_env local_env) asconst e what
    | Cabs.NOTHING when what = ADrop ->
      finishExp [] (unspecified_chunk empty) (integer ~loc 0) intType
    | Cabs.NOTHING ->
      let res = new_exp ~loc (Const(CStr "exp_nothing")) in
      finishExp [] (unspecified_chunk empty) res (typeOf res)
    (* Do the potential lvalues first *)
    | Cabs.VARIABLE n -> begin
        if is_stdlib_function_macro n then begin
          (* These must be macros. They can be implemented with a function
             of the same name, but in that case, it is not possible to
             take the address of the function (or do anything else than
             calling the function, which is matched later on). *)
          Kernel.warning ~wkey:Kernel.wkey_cert_msc_38 ~current:true
            "%s is a standard macro. Its definition cannot be suppressed, \
             see CERT C coding rules MSC38-C" n
        end;
        (* Look up in the environment *)
        try
          let env = if ghost then ghost_env else env in
          let envdata = Datatype.String.Hashtbl.find env n in
          match envdata with
          | EnvVar vi, _ ->
            let lval = var vi in
            let reads =
              if
                (* Always allow to read the address of an
                   array or a function, as it will never be written to:
                   no read/write interference is possible. *)
                Cil.isArrayType vi.vtype ||
                Cil.isFunctionType vi.vtype ||
                Lval.Set.mem lval local_env.authorized_reads
              then []
              else [ lval ]
            in
            (* if isconst &&
               not (isFunctionType vi.vtype) &&
               not (isArrayType vi.vtype)then
               Cil.error "variable appears in constant"; *)
            finishExp
              reads (unspecified_chunk empty)
              (new_exp ~loc (Lval lval)) (dropQualifiers vi.vtype)
          | EnvEnum item, _ ->
            let typ = Cil.typeOf item.eival in
            (*Kernel.debug "Looking for %s got enum %s : %a of type %a"
              n item.einame Cil_printer.pp_exp item.eival
              Cil_datatype.Typ.pretty typ; *)
            if Cil.theMachine.Cil.lowerConstants then
              finishExp [] (unspecified_chunk empty) item.eival typ
            else
              finishExp []
                (unspecified_chunk empty)
                (new_exp ~loc (Const (CEnum item)))
                typ
          | _ -> raise Not_found
        with Not_found -> begin
            if isOldStyleVarArgName n then
              Kernel.abort ~current:true
                "Cannot resolve variable %s. \
                 This could be a CIL bug due to \
                 the handling of old-style variable argument functions"
                n
            else if only_ghost_symbol n then
              Kernel.abort ~current:true
                "Variable %s is a ghost symbol. \
                 It cannot be used in non-ghost context. \
                 Did you forget a /*@@ ghost ... /?" n
            else
              Kernel.abort ~current:true "Cannot resolve variable %s" n
          end
      end
    | Cabs.INDEX (e1, e2) -> begin
        (* Recall that doExp turns arrays into StartOf pointers *)
        let (r1, se1, e1', t1) =
          doExp (no_paren_local_env local_env) CNoConst e1 (AExp None) in
        let (r2,se2, e2', t2) =
          doExp (no_paren_local_env local_env) CNoConst e2 (AExp None) in
        let se = se1 @@ (se2, ghost) in
        let (e1'', t1, e2'', tresult) =
          (* Either e1 or e2 can be the pointer *)
          match unrollType t1, unrollType t2 with
          | TPtr(t1e,_), (TInt _|TEnum _) -> e1', t1, e2', t1e
          | (TInt _|TEnum _), TPtr(t2e,_) -> e2', t2, e1', t2e
          | _ ->
            Kernel.fatal ~current:true
              "Expecting exactly one pointer type in array access %a[%a] (%a \
               and %a)"
              Cil_printer.pp_exp e1' Cil_printer.pp_exp e2'
              Cil_datatype.Typ.pretty t1 Cil_datatype.Typ.pretty t2
        in
        (* We have to distinguish the construction based on the type of e1'' *)
        let res =
          match e1''.enode with
          | StartOf array -> (* A real array indexing operation *)
            addOffsetLval (Index(e2'', NoOffset)) array
          | _ -> (* Turn into *(e1 + e2) *)
            mkMem
              ~addr:(new_exp ~loc:e1''.eloc (BinOp(PlusPI, e1'', e2'', t1)))
              ~off:NoOffset
        in
        (* Do some optimization of StartOf *)
        let reads =
          let l = r1 @ r2 in
          if Lval.Set.mem res local_env.authorized_reads
          then l
          else res :: l
        in
        finishExp reads se (new_exp ~loc (Lval res)) (dropQualifiers tresult)
      end
    | Cabs.UNARY (Cabs.MEMOF, e) ->
      if asconst = CConst then
        Kernel.warning ~current:true "MEMOF in constant";
      let (r,se, e', t) =
        doExp (no_paren_local_env local_env) CNoConst e (AExp None)
      in
      let tresult =
        match unrollType t with
        | TPtr(te, _) -> te
        | _ ->
          Kernel.fatal ~current:true
            "Expecting a pointer type in *. Got %a."
            Cil_datatype.Typ.pretty t
      in
      let res = mkMem ~addr:e' ~off:NoOffset in
      let reads =
        if Lval.Set.mem res local_env.authorized_reads
        then r
        else res :: r
      in
      finishExp reads se (new_exp ~loc (Lval res)) (dropQualifiers tresult)

    (* e.str = (& e + off(str)). If e = (be + beoff) then e.str = (be
     * + beoff + off(str))  *)
    | Cabs.MEMBEROF (e, str) ->
      (* member of is actually allowed if we only take the address *)
      (* if isconst then Cil.error "MEMBEROF in constant";  *)
      let (r,se, e', t') =
        doExp (no_paren_local_env local_env) CNoConst e (AExp None)
      in
      let lv =
        match e'.enode with
        | Lval x -> x
        | CastE(_, { enode = Lval x}) -> x
        | _ ->
          Kernel.fatal ~current:true
            "Expected an lval in MEMBEROF (field %s)"
            str
      in
      (* We're not reading the whole lval, just a chunk of it. *)
      let r =
        List.filter (fun x -> not (Lval.equal x lv)) r
      in
      let field_offset =
        match unrollType t' with
        | TComp (comp, _) -> findField str comp
        | _ ->
          Kernel.fatal ~current:true "expecting a struct with field %s" str
      in
      let lv' = addOffsetLval field_offset lv in
      let field_type = typeOfLval lv' in
      let reads =
        if Lval.Set.mem lv' local_env.authorized_reads
        then r
        else lv':: r
      in
      finishExp reads se (new_exp ~loc (Lval lv')) (dropQualifiers field_type)

    (* e->str = * (e + off(str)) *)
    | Cabs.MEMBEROFPTR (e, str) ->
      if asconst = CConst then
        Kernel.warning ~current:true "MEMBEROFPTR in constant";
      let (r,se, e', t') =
        doExp (no_paren_local_env local_env) CNoConst e (AExp None)
      in
      let pointedt = match unrollType t' with
        | TPtr(t1, _) -> t1
        | TArray(t1,_,_) -> t1
        | _ -> Kernel.fatal ~current:true "expecting a pointer to a struct"
      in
      let field_offset = match unrollType pointedt with
        | TComp (comp, _) -> findField str comp
        | x ->
          Kernel.fatal ~current:true
            "expecting a struct with field %s. Found %a. t1 is %a"
            str Cil_datatype.Typ.pretty x Cil_datatype.Typ.pretty t'
      in
      let lv' = mkMem ~addr:e' ~off:field_offset in
      let field_type = typeOfLval lv' in
      let reads =
        if Lval.Set.mem lv' local_env.authorized_reads
        then r
        else lv' :: r
      in
      finishExp reads se (new_exp ~loc (Lval lv')) (dropQualifiers field_type)

    | Cabs.CONSTANT ct -> begin
        match ct with
        | Cabs.CONST_INT str -> begin
            let res =
              match parseIntExpRes ~loc str with
              | Ok e -> e
              | Error msg ->
                Kernel.error ~current:true "%s" msg;
                (* assign an arbitrary expression,
                   since we must return something *)
                Cil.one ~loc
            in
            finishExp [] (unspecified_chunk empty) res (typeOf res)
          end

        | Cabs.CONST_WSTRING (ws: int64 list) ->
          let res =
            new_exp ~loc
              (Const(CWStr ((* intlist_to_wstring *) ws)))
          in
          finishExp [] (unspecified_chunk empty) res (typeOf res)

        | Cabs.CONST_STRING s ->
          (* Maybe we buried __FUNCTION__ in there *)
          let s' =
            try
              let start = String.index s (Char.chr 0) in
              let l = String.length s in
              let tofind = (String.make 1 (Char.chr 0)) ^ "__FUNCTION__" in
              let past = start + String.length tofind in
              if past <= l &&
                 String.sub s start (String.length tofind) = tofind then
                (if start > 0 then String.sub s 0 start else "") ^
                !currentFunctionFDEC.svar.vname ^
                (if past < l then String.sub s past (l - past) else "")
              else
                s
            with Not_found -> s
          in
          let res = new_exp ~loc (Const(CStr s')) in
          finishExp [] (unspecified_chunk empty) res (typeOf res)

        | Cabs.CONST_CHAR char_list ->
          let a, b = (interpret_character_constant char_list) in
          finishExp [] (unspecified_chunk empty) (new_exp ~loc (Const a)) b

        | Cabs.CONST_WCHAR char_list ->
          (* matth: I can't see a reason for a list of more than one char
           * here, since the kinteger64 below will take only the lower 16
           * bits of value.  ('abc' makes sense, because CHAR constants have
           * type int, and so more than one char may be needed to represent
           * the value.  But L'abc' has type wchar, and so is equivalent to
           * L'c').  But gcc allows L'abc', so I'll leave this here in case
           * I'm missing some architecture dependent behavior. *)
          let value = reduce_multichar theMachine.wcharType char_list in
          let result = kinteger64 ~loc ~kind:theMachine.wcharKind
              (Integer.of_int64 value)
          in
          finishExp [] (unspecified_chunk empty) result (typeOf result)

        | Cabs.CONST_FLOAT str -> begin
            Floating_point.set_round_nearest_even ();
            let kind, parsed_float = Floating_point.parse str in
            let nearest_float = parsed_float.Floating_point.f_nearest in
            if Floating_point.(parsed_float.f_lower <> parsed_float.f_upper)
            then
              Kernel.warning ~wkey:Kernel.wkey_decimal_float ~current:true
                "Floating-point constant %s is not represented exactly. \
                 Will use %a."
                str (Floating_point.pretty_normal ~use_hex:true) nearest_float;
            let node = Const (CReal (nearest_float, kind, Some str)) in
            let typ = TFloat (kind, []) in
            finishExp [] (unspecified_chunk empty) (new_exp ~loc node) typ
          end
      end

    | Cabs.TYPE_SIZEOF (bt, dt) ->
      let typ = doOnlyType local_env.is_ghost bt dt in
      fail_if_incompatible_sizeof ~ensure_complete:true "sizeof" typ;
      let res = new_exp ~loc (SizeOf typ) in
      finishExp [] (unspecified_chunk empty) res theMachine.typeOfSizeOf

    | Cabs.EXPR_SIZEOF e ->
      (* Allow non-constants in sizeof *)
      (* Do not convert arrays and functions into pointers. *)
      let (_, se, e', lvt) =
        doExp (no_paren_local_env local_env) CNoConst e AExpLeaveArrayFun
      in
      fail_if_incompatible_sizeof ~ensure_complete:false "sizeof()" lvt;
      let scope_chunk = drop_chunk "sizeof" se e e' in
      let size =
        match e'.enode with
        (* Maybe we are taking the sizeof a variable-sized array *)
        | Lval (Var vi, NoOffset) -> begin
            try
              IH.find varSizeArrays vi.vid
            with Not_found -> new_exp ~loc (SizeOfE e')
          end
        | Const (CStr s) -> new_exp ~loc (SizeOfStr s)
        | _ -> new_exp ~loc (SizeOfE e')
      in
      finishExp [] scope_chunk size theMachine.typeOfSizeOf

    | Cabs.TYPE_ALIGNOF (bt, dt) ->
      let typ = doOnlyType local_env.is_ghost bt dt in
      fail_if_incompatible_sizeof ~ensure_complete:true "alignof" typ;
      let res = new_exp ~loc (AlignOf typ) in
      finishExp [] (unspecified_chunk empty) res theMachine.typeOfSizeOf

    | Cabs.EXPR_ALIGNOF e ->
      let (_, se, e', lvt) =
        doExp (no_paren_local_env local_env) CNoConst e AExpLeaveArrayFun
      in
      fail_if_incompatible_sizeof ~ensure_complete:false "alignof()" lvt;
      let scope_chunk = drop_chunk "alignof" se e e' in
      let e'' =
        match e'.enode with (* If we are taking the alignof an
                             * array we must drop the StartOf  *)
        | StartOf(lv) -> new_exp ~loc:e'.eloc (Lval(lv))

        | _ -> e'
      in
      finishExp [] scope_chunk (new_exp ~loc (AlignOfE(e'')))
        theMachine.typeOfSizeOf

    | Cabs.CAST ((specs, dt), ie) ->
      let s', dt', ie' = preprocessCast local_env.is_ghost specs dt ie in
      (* We know now that we can do s' and dt' many times *)
      let typ = doOnlyType local_env.is_ghost s' dt' in
      let what' =
        match what with
        | AExp (Some _) -> AExp (Some typ)
        | AExp None -> what
        | ADrop | AType | AExpLeaveArrayFun -> what
        | ASet (_, _, _, lvt) ->
          (* If the cast from typ to lvt would be dropped, then we
           * continue with a Set *)
          if false && Cil_datatype.Typ.equal typ lvt then
            what
          else
            AExp None (* We'll create a temporary *)
      in
      (* Remember here if we have done the Set *)
      let (r,se, e', t'), (needcast: bool) =
        match ie' with
        | Cabs.SINGLE_INIT e ->
          doExp (no_paren_local_env local_env) asconst e what', true

        | Cabs.NO_INIT -> Kernel.fatal ~current:true "missing expression in cast"

        | Cabs.COMPOUND_INIT _ -> begin
            (* Pretend that we are declaring and initializing a brand new
             * variable  *)
            let newvar = "__constr_expr_" ^ string_of_int (!constrExprId) in
            incr constrExprId;
            let spec_res = doSpecList local_env.is_ghost "" s' in
            let se1 =
              if !scopes == [] then begin
                (* This is a global.  Mark the new vars as static *)
                let spec_res' =
                  let t, _, inl, attrs = spec_res in
                  t, Static, inl, attrs
                in
                ignore (createGlobal local_env.is_ghost None spec_res'
                          ((newvar, dt', [], loc), ie'));
                (unspecified_chunk empty)
              end else
                createLocal
                  local_env.is_ghost spec_res ((newvar, dt', [], loc), ie')
            in
            (* Now pretend that e is just a reference to the newly created
             * variable *)
            let v = { expr_node = Cabs.VARIABLE newvar; expr_loc = loc } in
            let r, se, e', t' =
              doExp (no_paren_local_env local_env) asconst v what'
            in
            (* If typ is an array then the doExp above has already added a
             * StartOf. We must undo that now so that it is done once by
             * the finishExp at the end of this case *)
            let e2, t2 =
              match unrollType typ, e'.enode with
              | TArray _, StartOf lv -> new_exp ~loc (Lval lv), typ
              | _, _ -> e', t'
            in
            (* If we are here, then the type t2 is guaranteed to match the
             * type of the expression e2, so we do not need a cast. We have
             * to worry about this because otherwise, we might need to cast
             * between arrays or structures. *)
            (r, se1 @@ (se, ghost), e2, t2), false
          end
      in
      let (t'', e'') =
        match typ with
        | TVoid _ when what' = ADrop -> (t', e') (* strange GNU thing *)
        |  _ ->
          (* Do this to check the cast, unless we are sure that we do not
           * need the check. *)
          let newtyp, newexp =
            if needcast then
              castTo ~fromsource:true t' typ e'
            else
              t', e'
          in
          newtyp, newexp
      in
      finishExp r se e'' t''

    | Cabs.UNARY(Cabs.MINUS, e) ->
      let (r, se, e', t) =
        doExp (no_paren_local_env local_env) asconst e (AExp None)
      in
      if isIntegralType t then
        let tres = integralPromotion t in
        let e'' =
          new_exp ~loc (UnOp(Neg, makeCastT ~e:e' ~oldt:t ~newt:tres, tres))
        in
        finishExp r se e'' tres
      else
      if isArithmeticType t then
        finishExp r se (new_exp ~loc:e'.eloc (UnOp(Neg,e',t))) t
      else
        Kernel.fatal ~current:true "Unary - on a non-arithmetic type"

    | Cabs.UNARY(Cabs.BNOT, e) ->
      let (r, se, e', t) =
        doExp (no_paren_local_env local_env) asconst e (AExp None)
      in
      if isIntegralType t then
        let tres = integralPromotion t in
        let e'' =
          new_exp ~loc (UnOp(BNot, makeCastT ~e:e' ~oldt:t ~newt:tres, tres))
        in
        finishExp r se e'' tres
      else
        Kernel.fatal ~current:true "Unary ~ on a non-integral type"

    | Cabs.UNARY(Cabs.PLUS, e) -> doExp (no_paren_local_env local_env) asconst e what

    | Cabs.UNARY(Cabs.ADDROF, e) ->
      (* some normalization is needed here to remove potential COMMA, QUESTION
         and PAREN. the normalization will take care of setting
         local_env.is_paren as appropriate while removing PAREN. *)
      let action local_env e what =
        match e.expr_node with
        | Cabs.COMMA _ | Cabs.QUESTION _ | Cabs.PAREN _ ->
          Kernel.fatal ~current:true "normalization of unop failed"
        | Cabs.VARIABLE s when
            isOldStyleVarArgName s
            && (match !currentFunctionFDEC.svar.vtype with
                  TFun(_, _, true, _) -> true | _ -> false) ->
          (* We are in an old-style variable argument function and we are
           * taking the address of the argument that was removed while
           * processing the function type. We compute the address based on
           * the address of the last real argument *)
          if Cil.msvcMode () then begin
            let rec getLast = function
              | [] ->
                Kernel.fatal ~current:true
                  "old-style variable argument function without real \
                   arguments"
              | [ a ] -> a
              | _ :: rest -> getLast rest
            in
            let last = getLast !currentFunctionFDEC.sformals in
            let res = mkAddrOfAndMark e.expr_loc (var last) in
            let tres = typeOf res in
            let tres', res' = castTo tres (TInt(IULong, [])) res in
            (* Now we must add to this address to point to the next
             * argument. Round up to a multiple of 4  *)
            let sizeOfLast =
              (((bitsSizeOf last.vtype) + 31) / 32) * 4
            in
            let res'' =
              new_exp ~loc
                (BinOp(PlusA, res', kinteger ~loc IULong sizeOfLast, tres'))
            in
            finishExp [] (unspecified_chunk empty) res'' tres'
          end else begin (* On GCC the only reliable way to do this is to
                          * call builtin_next_arg. If we take the address of
                          * a local we are going to get the address of a copy
                          * of the local ! *)

            doExp local_env asconst
              (cabs_exp loc
                 (Cabs.CALL (cabs_exp loc (Cabs.VARIABLE "__builtin_next_arg"),
                             [cabs_exp loc (Cabs.CONSTANT (Cabs.CONST_INT "0"))],[])))
              what
          end

        | Cabs.VARIABLE _ | Cabs.UNARY (Cabs.MEMOF, _) (* Regular lvalues *)
        | Cabs.CONSTANT (Cabs.CONST_STRING _) | Cabs.CONSTANT (Cabs.CONST_WSTRING _)
        | Cabs.INDEX _ | Cabs.MEMBEROF _ | Cabs.MEMBEROFPTR _
        | Cabs.CAST (_, Cabs.COMPOUND_INIT _) ->
          begin
            let (r, se, e', t) =
              doExp local_env CNoConst e (AExp None)
            in
            (* ignore (E.log "ADDROF on %a : %a\n" Cil_printer.pp_exp e'
               Cil_datatype.Typ.pretty t); *)
            match e'.enode with
            | Lval x | CastE(_, {enode = Lval x}) | StartOf x ->
              (* Recover type qualifiers that were dropped by dropQualifiers
                 when the l-value was created *)
              let tres = match e'.enode with
                | Lval x | StartOf x -> Cil.typeOfLval x
                | _ -> t
              in
              let reads =
                match r with
                | x' :: r when LvalStructEq.equal x x' -> r
                | _ -> r
              in
              finishExp reads se (mkAddrOfAndMark loc x) (TPtr(tres, []))

            | Const (CStr _ | CWStr _) ->
              (* string to array *)
              finishExp r se e' (TPtr(t, []))

            (* Function names are converted into pointers to the function.
             * Taking the address-of again does not change things *)
            | AddrOf (Var v, NoOffset) when isFunctionType v.vtype ->
              finishExp r se e' t

            | _ ->
              Kernel.fatal ~current:true "Expected lval for ADDROF. Got %a"
                Cil_printer.pp_exp e'
          end
        | _ -> Kernel.fatal ~current:true "Unexpected operand for addrof"
      in
      normalize_unop Cabs.ADDROF action CNoConst
        (no_paren_local_env local_env) e what
    | Cabs.UNARY((Cabs.PREINCR|Cabs.PREDECR) as uop, e) ->
      let action local_env e _what =
        match e.expr_node with
        | Cabs.COMMA _ | Cabs.QUESTION _ | Cabs.PAREN _ ->
          Kernel.fatal ~current:true "normalization of unop failed"
        | (Cabs.VARIABLE _ | Cabs.UNARY (Cabs.MEMOF, _) | (* Regular lvalues *)
           Cabs.INDEX _ | Cabs.MEMBEROF _ | Cabs.MEMBEROFPTR _ |
           Cabs.CAST _ (* A GCC extension *)) -> begin
            let uop' = if uop = Cabs.PREINCR then PlusA else MinusA in
            if asconst = CConst then
              Kernel.warning ~current:true "PREINCR or PREDECR in constant";
            let (r, se, e', t) = doExp local_env CNoConst e (AExp None) in
            let lv = get_lval_compound_assigned "++ or --" e' in
            let se' = remove_reads lv se in
            let r' =
              List.filter (fun x -> not (Lval.equal x lv)) r
            in
            let tresult, result =
              doBinOp loc uop' e' t (one ~loc:e'.eloc) intType
            in
            finishExp []
              (se' +++
               (mkStmtOneInstr ~ghost:local_env.is_ghost ~valid_sid
                  (Set(lv, snd (castTo tresult t result),
                       CurrentLoc.get ())),[],[lv],r'))
              e'
              t
          end
        | _ ->
          Kernel.fatal ~current:true "Unexpected operand for prefix -- or ++"
      in
      normalize_unop uop action asconst (no_paren_local_env local_env) e what

    | Cabs.UNARY((Cabs.POSINCR|Cabs.POSDECR) as uop, e) ->
      let action local_env e what =
        match e.expr_node with
        | Cabs.COMMA _ | Cabs.QUESTION _ | Cabs.PAREN _ ->
          Kernel.fatal ~current:true "normalization of unop failed"
        | Cabs.VARIABLE _ | Cabs.UNARY (Cabs.MEMOF, _) (* Regular lvalues *)
        | Cabs.INDEX _ | Cabs.MEMBEROF _ | Cabs.MEMBEROFPTR _
        | Cabs.CAST _ (* A GCC extension *) -> begin
            if asconst = CConst then
              Kernel.warning ~current:true "POSTINCR or POSTDECR in constant";
            (* If we do not drop the result then we must save the value *)
            let uop' = if uop = Cabs.POSINCR then PlusA else MinusA in
            let (r,se, e', t) = doExp local_env CNoConst e (AExp None) in
            let lv = get_lval_compound_assigned "++ or --" e' in
            let se' = remove_reads lv se in
            let r' =
              List.filter (fun x -> not (Lval.equal x lv)) r
            in
            let tresult, opresult =
              doBinOp loc uop' e' t (one ~loc:e'.eloc)
                intType
            in
            let reads, se', result =
              if what <> ADrop && what <> AType then
                let descr =
                  Format.asprintf "%a%s"
                    Cil_descriptive_printer.pp_exp  e'
                    (if uop = Cabs.POSINCR then "++" else "--") in
                let tmp = newTempVar ~ghost loc descr true t in
                ([var tmp],
                 local_var_chunk se' tmp +++
                 (mkStmtOneInstr ~ghost:local_env.is_ghost ~valid_sid
                    (Set(var tmp, e', CurrentLoc.get ())),[],[],[]),
                 (* the tmp variable should not be investigated for
                    unspecified writes: it occurs at the right place in
                    the sequence.
                 *)
                 new_exp ~loc (Lval(var tmp)))
              else
                [],se, e'
            in
            finishExp reads
              (se' +++
               (mkStmtOneInstr ~ghost:local_env.is_ghost ~valid_sid
                  (Set(lv,
                       snd (castTo tresult (typeOfLval lv) opresult),
                       CurrentLoc.get ())),
                [],[lv], r'))
              result
              t
          end
        | _ ->
          Kernel.fatal ~current:true "Unexpected operand for suffix ++ or --"
      in
      normalize_unop uop action asconst (no_paren_local_env local_env) e what

    | Cabs.BINARY(Cabs.ASSIGN, e1, e2) ->
      let action local_env asconst e what =
        match e.expr_node with
        | Cabs.COMMA _ | Cabs.QUESTION _ | Cabs.CAST (_,Cabs.SINGLE_INIT _) | Cabs.PAREN _ ->
          Kernel.fatal
            ~current:true "normalization of lval in assignment failed"
        | (Cabs.VARIABLE _ | Cabs.UNARY (Cabs.MEMOF, _) | (* Regular lvalues *)
           Cabs.INDEX _ | Cabs.MEMBEROF _ | Cabs.MEMBEROFPTR _ ) -> begin
            if asconst = CConst then
              Kernel.warning ~current:true "ASSIGN in constant";
            let se0 = unspecified_chunk empty in
            let (r1,se1, e1', lvt) = doExp local_env CNoConst e (AExp None) in
            let lv =
              match e1'.enode with
              | Lval x when Cil.is_modifiable_lval x -> x
              | Lval x ->
                Kernel.abort ~current:true
                  "Cannot assign to non-modifiable lval %a"
                  Cil_printer.pp_lval x
              | StartOf lv ->
                Kernel.abort ~current:true
                  "Cannot assign array %a" Cil_printer.pp_lval lv
              | _ ->
                Kernel.abort ~current:true
                  "Expected lval for assignment. Got %a"
                  Cil_printer.pp_exp e1'
            in
            let se1' = remove_reads lv se1 in
            let r1' = List.filter (fun x -> not (Lval.equal x lv)) r1 in
            let local_env =
              { local_env with
                authorized_reads =
                  Lval.Set.add lv local_env.authorized_reads }
            in
            (*[BM]: is this useful?
              let (_, _, _) = doExp ghost false e2 (ASet(lv, lvt)) in*)
            (* Catch the case of an lval that might depend on itself,
               e.g. p[p[0]] when p[0] == 0.  We need to use a temporary
               here if the result of the expression will be used:
               tmp := e2; lv := tmp; use tmp as the result
               Test: small1/assign.c *)
            let needsTemp =
              not (isBitfield lv) && (* PC: BTS 933, 968 *)
              match what, lv with
              | (ADrop|AType), _ -> false
              | _, (Mem e, off) ->
                not (isConstant e) || not (isConstantOffset off)
              | _, (Var _, off) -> not (isConstantOffset off)
            in
            let r1, tmplv, se3 =
              if needsTemp then
                let descr =
                  Format.asprintf "%a" Cil_descriptive_printer.pp_lval lv
                in
                let tmp = newTempVar ~ghost loc descr true lvt in
                let chunk =
                  i2c
                    (mkStmtOneInstr ~ghost:local_env.is_ghost ~valid_sid
                       (Set(lv, new_exp ~loc:e1'.eloc (Lval(var tmp)), loc)),
                     [lv],[lv], r1')
                in
                ([],var tmp, local_var_chunk chunk tmp)
              else r1',lv, empty
            in
            let (r2,se2, _, _) =
              doExp local_env CNoConst e2 (ASet (not needsTemp, tmplv,  r1, lvt))
            in
            let (@@) s1 s2 = s1 @@ (s2, ghost) in
            (* Format.eprintf "chunk for assigns is %a@." d_chunk se2; *)
            (* r1 is read in the assignment part itself *)
            finishExp r2  ((empty @@ ((se0 @@ se1') @@ se2)) @@ se3)
              (new_exp ~loc (Lval tmplv)) lvt
          end
        | _ -> Kernel.fatal ~current:true "Invalid left operand for ASSIGN"
      in
      normalize_binop
        Cabs.ASSIGN action (no_paren_local_env local_env) asconst e1 e2 what
    | Cabs.BINARY((Cabs.ADD|Cabs.SUB|Cabs.MUL|Cabs.DIV|Cabs.MOD|Cabs.BAND|Cabs.BOR|Cabs.XOR|
                   Cabs.SHL|Cabs.SHR|Cabs.EQ|Cabs.NE|Cabs.LT|Cabs.GT|Cabs.GE|Cabs.LE) as bop,
                  e1, e2) ->
      let check_bitwise = is_bitwise_bop bop && not local_env.is_paren in
      let se0 = unspecified_chunk empty in
      let bop' = convBinOp bop in
      let (r1,se1, e1', t1) =
        doExp (no_paren_local_env local_env) asconst e1 (AExp None) in
      let (r2,se2, e2', t2) =
        doExp (no_paren_local_env local_env) asconst e2 (AExp None) in
      if check_bitwise then begin
        check_logical_operand e1 t1;
        check_logical_operand e2 t2;
      end;
      let tresult, result = doBinOp loc bop' e1' t1 e2' t2 in
      let (@@) s1 s2 = s1 @@ (s2, ghost) in
      finishExp (r1 @ r2) ((se0 @@ se1) @@ se2) result tresult

    (* assignment operators *)
    | Cabs.BINARY((Cabs.ADD_ASSIGN|Cabs.SUB_ASSIGN|Cabs.MUL_ASSIGN|Cabs.DIV_ASSIGN|
                   Cabs.MOD_ASSIGN|Cabs.BAND_ASSIGN|Cabs.BOR_ASSIGN|Cabs.SHL_ASSIGN|
                   Cabs.SHR_ASSIGN|Cabs.XOR_ASSIGN) as bop, e1, e2) ->
      let se0 = unspecified_chunk empty in
      let action local_env asconst e _what =
        match e.expr_node with
        | Cabs.COMMA _ | Cabs.QUESTION _ | Cabs.PAREN _ ->
          Kernel.fatal ~current:true "normalization of lval in compound assignment failed"
        | Cabs.VARIABLE _ | Cabs.UNARY (Cabs.MEMOF, _) | (* Regular lvalues *)
          Cabs.INDEX _ | Cabs.MEMBEROF _ | Cabs.MEMBEROFPTR _ |
          Cabs.CAST _ (* GCC extension *) -> begin
            if asconst = CConst then
              Kernel.warning ~current:true "op_ASSIGN in constant";
            let bop' = match bop with
              | Cabs.ADD_ASSIGN -> PlusA
              | Cabs.SUB_ASSIGN -> MinusA
              | Cabs.MUL_ASSIGN -> Mult
              | Cabs.DIV_ASSIGN -> Div
              | Cabs.MOD_ASSIGN -> Mod
              | Cabs.BAND_ASSIGN -> BAnd
              | Cabs.BOR_ASSIGN -> BOr
              | Cabs.XOR_ASSIGN -> BXor
              | Cabs.SHL_ASSIGN -> Shiftlt
              | Cabs.SHR_ASSIGN -> Shiftrt
              | _ -> Kernel.fatal ~current:true "binary +="
            in
            let (r1,se1, e1', t1) = doExp local_env CNoConst e (AExp None) in
            let lv1 = get_lval_compound_assigned "assignment with arith" e1' in
            let se1' = remove_reads lv1 se1 in
            let r1' = List.filter (fun x -> not (Lval.equal x lv1)) r1 in
            let local_env =
              { local_env with
                authorized_reads =
                  Lval.Set.add lv1 local_env.authorized_reads }
            in
            let (r2, se2, e2', t2) = doExp local_env CNoConst e2 (AExp None) in
            let se2 = remove_reads lv1 se2 in
            let tresult, result = doBinOp loc bop' e1' t1 e2' t2 in
            (* We must cast the result to the type of the lv1, which may be
             * different than t1 if lv1 was a Cast *)
            let _, result' = castTo tresult (typeOfLval lv1) result in
            (* The type of the result is the type of the left-hand side  *)
            let (@@) s1 s2 = s1 @@ (s2, ghost) in
            finishExp []
              (se0 @@
               (empty @@ (se1' @@ se2) +++
                         (mkStmtOneInstr ~ghost:local_env.is_ghost ~valid_sid
                            (Set(lv1, result', loc)),
                          [lv1],[lv1], r1' @ r2)))
              e1'
              t1
          end
        | _ ->
          Kernel.fatal ~current:true
            "Unexpected left operand for assignment with arith"
      in
      normalize_binop
        bop action (no_paren_local_env local_env) asconst e1 e2 what
    | Cabs.BINARY((Cabs.AND|Cabs.OR), _, _) | Cabs.UNARY(Cabs.NOT, _) -> begin
        let ce = doCondExp local_env asconst e in
        (* We must normalize the result to 0 or 1 *)
        match ce with
        | CEExp (se, ({enode = Const c;eloc=loc})) ->
          finishExp [] se
            (match isConstTrueFalse c with
             | `CTrue -> one ~loc
             | `CFalse -> zero ~loc)
            intType
        | CEExp (se, ({enode = UnOp(LNot, _, _)} as e)) ->
          (* already normalized to 0 or 1 *)
          finishExp [] se e intType
        | CEExp (se, e) ->
          let e' =
            let te = typeOf e in
            let _, zte = castTo intType te (zero ~loc:e.eloc) in
            new_exp ~loc (BinOp(Ne, e, zte, intType))
          in
          finishExp [] se e' intType
        | _ ->
          let tmp =
            newTempVar ~ghost loc "<boolean expression>" true intType
          in
          let condChunk =
            compileCondExp ~ghost ce
              (empty +++
               (mkStmtOneInstr ~ghost ~valid_sid
                  (Set(var tmp, integer ~loc 1,loc)),[],[],[]))
              (empty +++
               (mkStmtOneInstr ~ghost ~valid_sid
                  (Set(var tmp, integer ~loc 0,loc)),[],[],[]))
          in
          finishExp []
            (local_var_chunk condChunk tmp)
            (new_exp ~loc (Lval (var tmp)))
            intType
      end

    | Cabs.CALL(f, args, ghost_args) ->
      let (rf,sf, f', ft') =
        match (stripParen f).expr_node with
        (* Treat the VARIABLE case separate because we might be calling a
         * function that does not have a prototype. In that case assume it
         * takes INTs as arguments  *)
        | Cabs.VARIABLE n -> begin
            try
              (* First look for polymorphic builtins. The typing rule is
                 luckily always the same one. *)
              let n = match n with
                | "__sync_add_and_fetch" | "__sync_sub_and_fetch"
                | "__sync_or_and_fetch" | "__sync_and_and_fetch"
                | "__sync_xor_and_fetch" | "__sync_nand_and_fetch"
                | "__sync_fetch_and_add" | "__sync_fetch_and_sub"
                | "__sync_fetch_and_or" | "__sync_fetch_and_and"
                | "__sync_fetch_and_xor" | "__sync_fetch_and_nand"
                | "__sync_bool_compare_and_swap"
                | "__sync_val_compare_and_swap"
                | "__sync_lock_release" | "__sync_lock_test_and_set" ->
                  begin
                    match args with
                    | a1::_ ->
                      (* The available prototypes are
                         typ' f(typ* a1,typ a2,typ a3,...);
                         typ' f(typ* a1,typ a2,...);
                         typ' f(typ* a1,...);
                         Hence we just infer the right type
                         looking at the first argument. *)
                      let _,c,_,t =
                        doExp (no_paren_local_env local_env) CNoConst a1 AType
                      in
                      clean_up_chunk_locals c;
                      let t = typeOf_pointed t in
                      Format.sprintf "%s_%sint%d_t"
                        n
                        (if isSignedInteger t then "" else "u")
                        (bitsSizeOf t)
                    | [] ->
                      Kernel.error ~once:true ~current:true
                        "Too few arguments for builtin %s" n;
                      n
                  end
                | _ -> n
              in
              let vi, _ = lookupVar ghost n in
              let reads =
                if Lval.Set.mem
                    (var vi) local_env.authorized_reads
                   ||
                   (vi.vglob && Cil.isFunctionType vi.vtype)
                then []
                else [ var vi ]
              in
              (reads, unspecified_chunk empty,
               new_exp ~loc:f.expr_loc (Lval(var vi)), vi.vtype)
            (* Found. Do not use finishExp. Simulate what = AExp None  *)
            with Not_found -> begin
                if only_ghost_symbol n then
                  Kernel.abort ~current:true
                    "Function %s is a ghost symbol. \
                     It cannot be used in non-ghost context. \
                     Did you forget a /*@@ ghost ... /?" n ;
                Kernel.debug ~level:3
                  "Calling function %s without prototype." n ;
                let ftype = TFun(intType, None, false,
                                 [Attr("missingproto",[])]) in
                (* Add a prototype to the environment *)
                let proto, _ =
                  makeGlobalVarinfo false
                    (makeGlobalVar ~temp:false n ftype) in
                (* Make it EXTERN *)
                proto.vstorage <- Extern;
                proto.vdecl <- f.expr_loc;
                ImplicitPrototypeHook.apply proto;
                (* Add it to the file as well *)
                cabsPushGlobal
                  (GFunDecl (empty_funspec (),proto, f.expr_loc));
                ([var proto],unspecified_chunk empty,
                 new_exp ~loc:f.expr_loc (Lval(var proto)), ftype)
              end
          end
        | _ -> doExp (no_paren_local_env local_env) CNoConst f (AExp None)
      in
      (* Get the result type and the argument types *)
      let (resType, argTypes, isvar, f'',attrs) =
        match unrollType ft' with
        | TFun(rt,at,isvar,attrs) -> (rt,at,isvar,f',attrs)
        | TPtr (t, _) -> begin
            match unrollType t with
            | TFun(rt,at,isvar,_) -> (* Make the function pointer
                                      * explicit  *)
              let f'' =
                match f'.enode with
                | AddrOf lv -> new_exp ~loc:f'.eloc (Lval(lv))
                | _ ->
                  new_exp ~loc:f'.eloc
                    (Lval (mkMem ~addr:f' ~off:NoOffset))
              in
              (rt,at,isvar, f'',[])
            | x ->
              Kernel.fatal ~current:true
                "Unexpected type of the called function %a: %a"
                Cil_printer.pp_exp f' Cil_datatype.Typ.pretty x
          end
        | x ->
          Kernel.fatal ~current:true
            "Unexpected type of the called function %a: %a"
            Cil_printer.pp_exp f' Cil_datatype.Typ.pretty x
      in
      let argTypesList = argsToList argTypes in
      let warn_no_proto f =
        (* Do not punish twice users of completely undeclared functions. *)
        if not (Cil.typeHasAttribute "missingproto" f.vtype) then
          Kernel.warning ~source:(fst loc) ~wkey:Kernel.wkey_no_proto
            "Calling function %a that is declared without prototype.@ \
             Its formals will be inferred from actual arguments"
            Cil_printer.pp_varinfo f
      in
      (* Drop certain qualifiers from the result type *)
      let resType' = typeRemoveAttributes ["warn_unused_result"] resType in
      (* Before we do the arguments we try to intercept a few builtins. For
       * these we have defined then with a different type, so we do not
       * want to give warnings. We'll just leave the arguments of these
       * functions alone*)
      let isSpecialBuiltin =
        match f''.enode with
        | Lval (Var fv, NoOffset) -> Cil_builtins.is_special_builtin fv.vname
        | _ -> false
      in
      let init_chunk = unspecified_chunk empty in
      (* Do the arguments. In REVERSE order !!! Both GCC and MSVC do this *)
      let rec loopArgs ?(are_ghost=false) = function
        | ([], []) ->
          (match argTypes, f''.enode with
           | None, Lval (Var f,NoOffset) ->
             (* we call a function without prototype with 0 argument.
                Hence, it really has no parameter.
             *)
             if not isSpecialBuiltin && not are_ghost then begin
               warn_no_proto f;
               let typ = TFun (resType, Some [], false,attrs) in
               Cil.update_var_type f typ;
             end
           | None, _ (* TODO: treat function pointers. *)
           | Some _, _ -> ()
          );
          (init_chunk, [])

        | _, [] ->
          if not isSpecialBuiltin then
            Kernel.error ~once:true ~current:true
              "Too few%s arguments in call to %a."
              (if are_ghost then " ghost" else "") Cil_printer.pp_exp f' ;
          (init_chunk, [])

        | ((_, at, _) :: atypes, a :: args) ->
          let (ss, args') = loopArgs ~are_ghost (atypes, args) in
          (* Do not cast as part of translating the argument. We let
           * the castTo do this work. This was necessary for
           * test/small1/union5, in which a transparent union is passed
           * as an argument *)
          let (sa, a', att) =
            let local_env = add_ghost_to_local_env local_env are_ghost in
            let (r, c, e, t) =
              doExp (no_paren_local_env local_env) CNoConst a (AExp None)
            in
            (add_reads ~ghost:local_env.is_ghost loc r c, e, t)
          in
          let (texpected, a'') =
            castTo ~context:ContravariantToplevel att at a'
          in
          (* A posteriori check that the argument type was compatible,
             to generate a warning otherwise;
             if a'' = a', no check needs to be done (no cast was introduced).
             Note: this check is conservative (it may not emit warnings when
             it should), and compilers can often detect more errors. *)
          if not (Exp.equal a' a'') &&
             match Cil.isArithmeticType texpected, Cil.isArithmeticType att with
             | true, true -> (* never a problem *) false
             | true, false -> true
             | false, true ->
               (* pointer with no pointer: problematic, except NULL;
                  if expected pointer and got null pointer constant => ok *)
               not (Cil.isPointerType texpected && Ast_info.is_null_expr a')
             | false, false ->
               (* Ghost compatibility is considered 'after_cleanup' *)
               let texpected = Cil.typeRemoveAttributesDeep [ "ghost" ] texpected in
               let att = Cil.typeRemoveAttributesDeep [ "ghost" ] att in
               (* pointers: check compatible modulo void ptr and modulo
                  literal strings (too many warnings otherwise) *)
               let ok1 =
                 (* accept literal strings even when expecting non-const char*;
                    equivalent to GCC's default behavior (-Wno-write-strings) *)
                 (Typ.equal (Cil.unrollType texpected) Cil.charPtrType &&
                  Typ.equal (Cil.unrollType att) Cil.charConstPtrType) ||
                 (* all pointers are convertible to void* *)
                 (Cil.isVoidPtrType texpected && Cil.isPointerType att) ||
                 (* allow implicit void* -> char* conversion *)
                 (Cil.isAnyCharPtrType texpected && Cil.isVoidPtrType att) ||
                 (* always allow null pointers *)
                 (Cil.isPointerType texpected && Ast_info.is_null_expr a') ||
                 areCompatibleTypes ~context:ContravariantToplevel att texpected
               in
               let ok =
                 if ok1 then true
                 (* special warning for void* -> any* conversions;
                    this is equivalent to option '-Wc++-compat' in GCC *)
                 else if Cil.isVoidPtrType att && Cil.isPointerType texpected
                 then begin
                   Kernel.warning ~wkey:Kernel.wkey_implicit_conv_void_ptr
                     ~current:true ~once:true
                     "implicit conversion from %a to %a"
                     Cil_datatype.Typ.pretty Cil.voidPtrType
                     Cil_datatype.Typ.pretty texpected;
                   true
                 end else
                   false
               in
               not ok
          then
            Kernel.warning ~wkey:Kernel.wkey_incompatible_types_call
              ~current:true ~once:true
              "expected '%a' but got argument of type '%a': %a"
              Cil_datatype.Typ.pretty texpected Cil_datatype.Typ.pretty att
              Cil_printer.pp_exp a';
          (ss @@ (sa, ghost), a'' :: args')

        | ([], args) -> (* No more types *)
          if not isvar && argTypes != None && not isSpecialBuiltin then
            (* Do not give a warning for functions without a prototype*)
            Kernel.error ~once:true ~current:true
              "Too many%s arguments in call to %a"
              (if are_ghost then " ghost" else "") Cil_printer.pp_exp f';
          let rec loop = function
              [] -> (init_chunk, [])
            | a :: args ->
              let (ss, args') = loop args in
              let (sa, a', _) =
                let (r, c, e, t) =
                  doExp (no_paren_local_env local_env) CNoConst a (AExp None)
                in
                (add_reads ~ghost:local_env.is_ghost loc r c, e, t)
              in
              (ss @@ (sa, ghost), a' :: args')
          in
          let (chunk,args as res) = loop args in
          (match argTypes, f''.enode with
           | Some _,_ ->
             if isvar then begin
               (* use default argument promotion to infer the type of the
                  variadic actuals, see C11:6.5.2.2:7 *)
               promote_variadic_arguments res
             end else
               res
           | None, Lval (Var f, NoOffset)
             when not isSpecialBuiltin ->
             begin
               (* use default argument promotion to infer the type of the
                  function, see 6.5.2.2.6 *)
               assert (not isvar);
               (* No nullary variadics see C11:6.7.6 *)
               warn_no_proto f;
               let (prm_types,args) =
                 List.split
                   (Extlib.mapi default_argument_promotion args)
               in
               let typ = TFun (resType, Some prm_types, false,attrs) in
               Cil.update_var_type f typ;
               Cil.setFormalsDecl f typ;
               (chunk,args)
             end
           | None, _ -> res
           (* TODO: treat function pointers.
              The issue is that their origin is more
              difficult to trace than plain variables (e.g. we'd have
              to take into account possible assignments, or update
              accordingly the signature of current function in case
              of a formal.
           *)
          )
      in
      let (argTypes, ghostArgTypes) =
        List.partition (fun d -> not (isGhostFormalVarDecl d) || ghost) argTypesList
      in
      let args = if ghost then args @ ghost_args else args in

      (* Again, we process arguments in REVERSE order. *)
      let (sghost, ghosts') = loopArgs ~are_ghost:true (ghostArgTypes, ghost_args) in
      let (sargs, args') = loopArgs (argTypes, args) in

      let sargs = sghost @@ (sargs, false) in

      let (sargs, args') = (sargs, args' @ ghosts') in
      (* Setup some pointer to the elements of the call. We may change
       * these below *)
      let s0 = unspecified_chunk empty in
      (* there is a sequence point between evaluations of args
         and the call itself, but we have to check that args wo side-effects
         (thus not appearing anywhere in sargs) are not modified by others...
         The call must thus be in the unspecified chunk
      *)
      let sargs = if isEmpty sargs then empty else sargs in
      let prechunk = ref ((s0 @@ (sf, ghost)) @@ (sargs, ghost)) in
      (* Do we actually have a call, or an expression? *)
      let piscall: bool ref = ref true in

      let pf: exp ref = ref f'' in (* function to call *)
      let pargs: exp list ref = ref args' in (* arguments *)
      let pis__builtin_va_arg: bool ref = ref false in
      let pwhat: expAction ref = ref what in (* what to do with result *)
      let locals = ref [] in

      (* If we do not have a call, this is the result *)
      let pres: exp ref = ref (zero ~loc:e.expr_loc) in

      let prestype: typ ref = ref intType in

      let rec dropCasts e = match e.enode with
        | CastE (_, e) -> dropCasts e
        | _ -> e
      in
      (* Get the name of the last formal *)
      let getNameLastNonGhostFormal () : string =
        match !currentFunctionFDEC.svar.vtype with
        | TFun(_, Some args, true, _) -> begin
            let args, _ = Cil.argsToPairOfLists (Some args) in
            match List.rev args with
            | (last_par_name, _, _) :: _ -> last_par_name
            | _ -> ""
          end
        | _ -> ""
      in
      (* Try to intercept some builtins *)
      (match (!pf).enode with
       | Lval(Var fv, NoOffset) -> begin
           match fv.vname with
           | "__builtin_va_arg" ->
             begin
               match !pargs with
               | marker :: ({enode = SizeOf resTyp} as size) :: _ -> begin
                   (* Make a variable of the desired type *)
                   let is_real, destlv, r, destlvtyp =
                     match !pwhat with
                     | ASet (is_real,lv, r, lvt) -> is_real, lv, r, lvt
                     | _ ->
                       let v = newTempVar ~ghost loc "vararg" true resTyp in
                       locals := v::!locals;
                       false, var v, [], resTyp
                   in
                   pwhat := (ASet (is_real, destlv, r, destlvtyp));
                   pargs := [marker; size;
                             new_exp ~loc
                               (CastE(voidPtrType,
                                      new_exp ~loc (AddrOf destlv)))];
                   pis__builtin_va_arg := true;
                 end
               | _ ->
                 Kernel.warning ~current:true "Invalid call to %s\n" fv.vname;
             end

           | "__builtin_va_start" ->
             let variad = match (!currentFunctionFDEC).svar.vtype with
               | TFun(_,_,t,_) -> t
               | _ -> assert false
             in
             let name =
               (!currentFunctionFDEC).svar.vname
             in
             begin
               match !pargs with
               | marker :: last :: [] -> begin
                   let isOk =
                     match (dropCasts last).enode with
                     | Lval (Var lastv, NoOffset) ->
                       lastv.vname = getNameLastNonGhostFormal ()
                     | _ -> false
                   in
                   if not isOk && variad then
                     Kernel.error ~current:true
                       "The last argument in call to __builtin_va_start \
                        should be the last formal argument of %s" name;

                   if not isOk && not variad then
                     Kernel.error ~current:true
                       "Invalid call to __builtin_va_start \
                        in non-variadic function %s"
                       name;

                   (* Check that "lastv" is indeed the last variable in the
                    * prototype and then drop it *)
                   pargs := [ marker ]
                 end
               | _ ->
                 Kernel.warning ~current:true "Invalid call to %s\n" name;

                 (* We have to turn uses of __builtin_varargs_start into uses
                  * of __builtin_stdarg_start (because we have dropped the
                  * __builtin_va_alist argument from this function) *)
             end

           | "__builtin_stdarg_start" ->
             let name =
               (!currentFunctionFDEC).svar.vname
             in
             begin
               match !pargs with
               | marker :: last :: [] -> begin
                   let isOk =
                     match (dropCasts last).enode with
                     | Lval (Var lastv, NoOffset) ->
                       lastv.vname = getNameLastNonGhostFormal ()
                     | _ -> false
                   in
                   if not isOk then
                     Kernel.warning ~current:true
                       "The last argument in call to __builtin_stdarg_start \
                        should be the last formal argument of %s" name;

                   (* Check that "lastv" is indeed the last variable in the
                    * prototype and then drop it *)
                   pargs := [ marker ]
                 end
               | _ ->
                 Kernel.warning ~current:true "Invalid call to %s\n" name;

                 (* We have to turn uses of __builtin_varargs_start into uses
                  * of __builtin_stdarg_start (because we have dropped the
                  * __builtin_va_alist argument from this function) *)
             end

           | "__builtin_varargs_start" ->
             begin
               (* Lookup the prototype for the replacement *)
               let v, _  =
                 (* builtin is not ghost *)
                 try lookupGlobalVar false "__builtin_stdarg_start"
                 with Not_found ->
                   abort_context
                     "Cannot find __builtin_stdarg_start to replace %s"
                     fv.vname
               in
               pf := new_exp ~loc (Lval (var v))
             end
           |  "__builtin_next_arg" ->
             begin
               match !pargs with
               | last :: [] -> begin
                   let isOk =
                     match (dropCasts last).enode with
                     | Lval (Var lastv, NoOffset) ->
                       lastv.vname = getNameLastNonGhostFormal ()
                     | _ -> false
                   in
                   if not isOk then
                     Kernel.warning ~current:true
                       "The argument in call to %s should be \
                        the last formal argument\n" fv.vname;

                   pargs := [ ]
                 end
               | _ ->
                 Kernel.warning ~current:true "Invalid call to %s\n" fv.vname;
             end
           | "__builtin_va_arg_pack" ->
             begin
               (match !pargs with
                | [ ] -> begin
                    piscall := false;
                    pres := new_exp ~loc:e.expr_loc (SizeOfE !pf);
                    prestype := theMachine.typeOfSizeOf
                  end
                | _ ->
                  Kernel.warning ~current:true
                    "Invalid call to builtin_va_arg_pack");
             end
           | "__builtin_constant_p" ->
             begin
               (* Before emptying the chunk, we remove the corresponding
                  generated labels from the tables. Otherwise, they will
                  be dangling when we iterate over the tables to fix
                  forward gotos, leading to errors. *)
               let remove_label s =
                 let vis = object
                   inherit Cil.nopCilVisitor
                   method! vstmt { labels } =
                     List.iter
                       (function
                         | Label (l, _, _) ->
                           H.remove labelStmt l;
                           H.remove backPatchGotos l
                         | _ -> ())
                       labels;
                     DoChildren
                 end
                 in
                 ignore (Cil.visitCilStmt vis s)
               in
               List.iter
                 (fun (stmt, _, _, _, _) ->
                    remove_label stmt
                 ) !prechunk.stmts;
               clean_up_chunk_locals !prechunk;
               (* Drop the side-effects *)
               prechunk := empty;
               (* Constant-fold the argument and see if it is a constant *)
               (match !pargs with
                | [ arg ] -> begin
                    match (constFold true arg).enode with
                    | Const _ -> piscall := false;
                      pres := integer ~loc:e.expr_loc 1 ;
                      prestype := intType

                    | _ -> piscall := false;
                      pres := integer ~loc:e.expr_loc 0;
                      prestype := intType
                  end
                | _ ->
                  Kernel.warning ~current:true
                    "Invalid call to builtin_constant_p")
             end
           | "__builtin_offsetof" ->
             begin
               match !pargs with
               | [{ enode = CastE (_, {enode = AddrOf (host, offset)}) } as e] ->
                 begin
                   piscall := false;
                   prestype := Cil.theMachine.Cil.typeOfSizeOf;
                   let typ = Cil.typeOfLhost host in
                   try
                     let start, _width = Cil.bitsOffset typ offset in
                     if start mod 8 <> 0 then
                       Kernel.error ~current:true "Using offset of bitfield";
                     let kind = Cil.theMachine.kindOfSizeOf in
                     pres := Cil.kinteger ~loc:e.eloc kind (start / 8);
                   with SizeOfError (s, _) ->
                     pres := e;
                     Kernel.error ~once:true ~current:true
                       "Unable to compute offset %a in type %a: %s"
                       Cil_datatype.Offset.pretty offset
                       Cil_datatype.Typ.pretty typ
                       s;
                 end
               | _ ->
                 Kernel.abort ~current:true "Invalid call to builtin_offsetof"
             end
           | "__builtin_types_compatible_p" ->
             begin
               (* Constant-fold the argument and see if it is a constant *)
               (match !pargs with
                | [ {enode = SizeOf t1}; {enode = SizeOf t2}] -> begin
                    (* Drop the side-effects *)
                    prechunk := empty;
                    piscall := false;
                    let compatible =
                      try ignore(combineTypes CombineOther t1 t2); true
                      with Cannot_combine _ -> false
                    in if compatible then
                      pres := integer ~loc 1
                    else
                      pres := integer ~loc 0;
                    prestype := intType
                  end
                | _ ->
                  Kernel.warning
                    ~once:true
                    ~current:true
                    "Invalid call to builtin_types_compatible_p");
             end
           | "__builtin_expect" ->
             begin
               match !pargs with
               | [ arg;_ ] ->
                 (* Keep all side-effects, including those stemming
                    from the second argument. This is quite strange but
                    compliant with GCC's behavior. *)
                 piscall := false;
                 pres := arg
               | _ ->
                 Kernel.warning ~once:true ~current:true
                   "Invalid call to builtin_expect"
             end

           | "__fc_infinity" -> begin
               piscall := false;
               let cst = CReal (infinity, FFloat, Some "INFINITY") in
               pres := Cil.new_exp ~loc (Const cst);
               prestype := Cil.floatType;
             end
           | "__fc_nan" -> begin
               piscall := false;
               let cst = CReal (nan, FFloat, Some "NAN") in
               pres := Cil.new_exp ~loc (Const cst);
               prestype := Cil.floatType;
             end

           (* TODO: Only keep the side effects of the 1st or 2nd argument
              | "__builtin_choose_expr" ->
              begin match !pargs with
              | [ arg; e1; e2 ] ->
                begin
                  let constfolded = constFold true arg in
                  match constfolded.enode with
                  | Const _ ->
                    piscall := false;
                    if isZero constfolded then begin
                    (* Keep only 3rd arg side effects *)
                      (*TODO: prechunk := sf @@ (List.nth sargsl 2);*)
                      pres := e2;
                      prestype := typeOf e2
                    end else begin
                    (* Keep only 2nd arg side effects *)
                      (*TODO prechunk := sf @@ (List.nth sargsl 1);*)
                      pres := e1;
                      prestype := typeOf e1
                    end
                  | _ -> Kernel.warning ~once:true ~current:true
                    "builtin_choose_expr expects a constant first argument"
                end
              | _ ->
              Kernel.warning ~once:true ~current:true
                "Invalid call to builtin_choose_expr: 3 arguments are \
                 expected but %d are provided."
                (List.length !pargs)
              end*)
           | _ ->
             if asconst = CConst then
               (* last special case: we cannot allow a function call
                  at this point.*)
               begin
                 piscall := false;
                 abort_context
                   "Call to %a in constant." Cil_printer.pp_varinfo fv;
               end
         end
       | _ -> ());

      (* Now we must finish the call *)
      if !piscall then begin
        let addCall ?(is_real_var=true) calldest res t =
          let my_write =
            match calldest with
            | None -> []
            | Some c when is_real_var -> [c]
            | Some _ -> []
          in
          prechunk :=
            (empty @@ (!prechunk, ghost)) +++
            (mkStmtOneInstr ~ghost:local_env.is_ghost ~valid_sid
               (Call(calldest,!pf,!pargs,loc)),
             [],my_write, rf);
          pres := res;
          prestype := t
        in
        match !pwhat with
        | ADrop -> addCall None (zero ~loc:e.expr_loc) intType
        | AType -> prestype := resType'
        | ASet(is_real_var, lv, _, vtype) when !pis__builtin_va_arg ->
          (* Make an exception here for __builtin_va_arg *)
          addCall
            ~is_real_var
            None
            (new_exp ~loc:e.expr_loc (Lval(lv)))
            vtype

        | ASet(is_real_var, lv, _, vtype)
          when (allow_return_collapse ~tf:resType' ~tlv:vtype)
          ->
          (* We can assign the result directly to lv *)
          addCall
            ~is_real_var
            (Some lv)
            (new_exp ~loc:e.expr_loc (Lval(lv)))
            vtype

        | _ -> begin
            let restype'' = match !pwhat with
              | AExp (Some t)
                when allow_return_collapse ~tf:resType' ~tlv:t -> t
              | _ -> resType'
            in
            let descr =
              Format.asprintf "%a(%a)"
                Cil_descriptive_printer.pp_exp !pf
                (Pretty_utils.pp_list ~sep:", "
                   Cil_descriptive_printer.pp_exp)
                !pargs
            in
            let tmp = newTempVar ~ghost loc descr false restype'' in
            locals:=tmp::!locals;
            (* Remember that this variable has been created for this
             * specific call. We will use this in collapseCallCast. *)
            IH.add callTempVars tmp.vid ();
            addCall
              ~is_real_var:false
              (Some (var tmp))
              (new_exp ~loc:e.expr_loc (Lval(var tmp)))
              restype'';
          end
      end;
      List.iter
        (fun v -> prechunk:= local_var_chunk !prechunk v) !locals;
      finishExp [] !prechunk !pres !prestype

    | Cabs.COMMA el ->
      if asconst = CConst then Kernel.warning ~current:true "COMMA in constant";
      (* We must ignore AExpLeaveArrayFun (a.k.a. 'do not decay pointers')
         if the expression at hand is a sequence with strictly more than
         one expression, because the exception for sizeof and typeof only
         apply when the expression is directly the argument of the operators.
         See C99 and C11 6.3.2.1§3.)
      *)
      let what =
        if what <> AExpLeaveArrayFun || List.length el = 1
        then what
        else (AExp None)
      in
      let rec loop sofar = function
        | [e] ->
          let (r, se, e', t') =
            doExp (no_paren_local_env local_env) CNoConst e what
          in
          (* Pass on the action *)
          (r, sofar @@ (se, ghost), e', t')
        | e :: rest ->
          let (_, se, _, _) =
            doExp (no_paren_local_env local_env) CNoConst e ADrop
          in
          loop (sofar @@ (se, ghost)) rest
        | [] -> Kernel.fatal ~current:true "empty COMMA expression"
      in
      loop empty el

    | Cabs.QUESTION (e1, e2, e3) -> begin
        (* Compile the conditional expression *)
        let ghost = local_env.is_ghost in
        let ce1 = doCondExp (no_paren_local_env local_env) asconst e1 in
        let what' = match what with
          | ADrop -> ADrop
          | _ -> AExp None
        in
        let is_true_cond = evaluate_cond_exp ce1 in
        (* Now we must find the type of both branches, in order to compute
         * the type of the result *)
        let r2, se2, e2'o (* is an option. None means use e1 *), t2 =
          match e2.expr_node with
          | Cabs.NOTHING -> begin (* The same as the type of e1 *)
              match ce1 with
              | CEExp (_, e1') ->
                [], unspecified_chunk empty, None, typeOf e1'
              (* Do not promote to bool *)
              | _ -> [], unspecified_chunk empty, None, intType
            end
          | _ ->
            (* if e1 is false, e2 is only interesting for its type, but
               we won't evaluate it. Hence, it can contain
               non-const constructions *)
            let asconst =
              if is_true_cond = `CFalse then CMayConst else asconst
            in
            let r2, se2, e2', t2 =
              doExp (no_paren_local_env local_env) asconst e2 what'
            in
            r2, se2, Some e2', t2
        in
        (* Do e3 for real. See above for the value of asconst *)
        let asconst' = if is_true_cond = `CTrue then CMayConst else asconst in
        let r3, se3, e3', t3 =
          doExp (no_paren_local_env local_env) asconst' e3 what'
        in
        let tresult = conditionalConversion t2 t3 in
        if asconst <> CNoConst && is_true_cond = `CTrue then begin
          clean_up_chunk_locals se2;
          clean_up_chunk_locals se3;
          let loc = e2.expr_loc in
          let e2' = match e2'o with None -> Cil.one ~loc | Some e -> e in
          let _,e2' = castTo t2 tresult e2' in
          finishExp [] empty e2' tresult;
        end else if asconst <> CNoConst && is_true_cond = `CFalse then begin
          clean_up_chunk_locals se2;
          clean_up_chunk_locals se3;
          let _,e3' = castTo t3 tresult e3' in
          finishExp [] empty e3' tresult
        end else begin
          if not (isEmpty se2) then
            ConditionalSideEffectHook.apply (e,e2);
          if not (isEmpty se3) then
            ConditionalSideEffectHook.apply (e,e3);
          match ce1 with
          | CEExp (se1, e1')
            when isExpTrueFalse e1' = `CFalse && canDrop se2 ->
            clean_up_chunk_locals se2;
            finishExp r3 ((empty @@ (se1, ghost)) @@ (se3, ghost))
              (snd (castTo t3 tresult e3')) tresult
          | CEExp (se1, e1')
            when isExpTrueFalse e1' = `CTrue && canDrop se3 ->
            begin
              clean_up_chunk_locals se3;
              match e2'o with
              | None -> (* use e1' *)
                finishExp r2
                  ((empty @@ (se1, ghost)) @@ (se2, ghost))
                  (snd (castTo t2 tresult e1')) tresult
              | Some e2' ->
                finishExp r2
                  ((empty @@ (se1, ghost)) @@ (se2, ghost))
                  (snd (castTo t2 tresult e2')) tresult
            end
          | _ when what = ADrop ->
            (* We are not interested by the result, but might want to
               evaluate e2 and e3 if they are dangerous expressions. *)
            (* dummy result, that will be ultimately be dropped *)
            let res = Cil.zero ~loc in
            (match e2'o with
             | None when is_dangerous e3' || not (isEmpty se3) ->
               let descr =
                 Format.asprintf "%a" Cprint.print_expression e1
               in
               let tmp = newTempVar ~ghost loc descr true tresult in
               let tmp_var = var tmp in
               let tmp_lval = new_exp ~loc:e.expr_loc (Lval (tmp_var)) in
               let (r1, se1, _, _) =
                 doExp
                   (no_paren_local_env local_env) asconst e1
                   (ASet(false, tmp_var, [], tresult))
               in
               let se1 = local_var_chunk se1 tmp in
               let dangerous =
                 if is_dangerous e3' then
                   keepPureExpr ~ghost e3' loc
                 else skipChunk
               in
               finishExp (r1@r3)
                 ((empty @@ (se1, ghost)) @@
                  (ifChunk ~ghost tmp_lval loc skipChunk
                     (se3 @@ (dangerous, ghost)), ghost))
                 res
                 tresult
             | None ->
               (* we can drop e3, just keep e1 in case it is dangerous *)
               let (r1,se1,e1,_) =
                 doExp (no_paren_local_env local_env) asconst e1 ADrop
               in
               let dangerous =
                 if is_dangerous e1 then
                   keepPureExpr ~ghost e1 loc
                 else skipChunk
               in
               finishExp
                 (r1@r3) (se1 @@ (dangerous, ghost)) res tresult
             | Some e2'
               when is_dangerous e2' || is_dangerous e3'
                    || not (isEmpty se2) || not (isEmpty se3) ->
               (* we have to keep e1 in order to know which
                  dangerous expression is to be evaluated *)
               let se2 =
                 if is_dangerous e2' then
                   se2 @@
                   (keepPureExpr ~ghost e2' loc, ghost)
                 else se2
               in
               let se3 =
                 if is_dangerous e3' then
                   se3 @@ (keepPureExpr ~ghost e3' loc, ghost)
                 else se3
               in
               let cond = compileCondExp ~ghost ce1 se2 se3 in
               finishExp (r2@r3) cond res tresult
             | Some _ ->
               (* we just keep e1 in case it is dangerous. everything
                  else can be dropped *)
               let (r1,se1,e1,_) =
                 doExp (no_paren_local_env local_env) asconst e1 ADrop
               in
               let dangerous =
                 if is_dangerous e1 then
                   keepPureExpr ~ghost e1 loc
                 else skipChunk
               in
               finishExp
                 (r1@r2@r3) (se1 @@ (dangerous, ghost)) res tresult)
          | _ -> (* Use a conditional *) begin
              match e2'o with
              | None -> (* has form "e1 ? : e3"  *)
                let descr =
                  Format.asprintf "%a" Cprint.print_expression e1
                in
                let tmp = newTempVar ~ghost loc descr true tresult in
                let tmp_var = var tmp in
                let tmp_lval = new_exp ~loc:e.expr_loc (Lval (tmp_var)) in
                let (r1,se1, _, _) =
                  doExp
                    (no_paren_local_env local_env)
                    asconst e1 (ASet(false, tmp_var, [], tresult))
                in
                let se1 = local_var_chunk se1 tmp in
                let newWhat = ASet(false,tmp_var, [], tresult) in
                let r3,se3,_,_ = finishExp ~newWhat r3 se3 e3' t3 in
                finishExp
                  (r1@r3)
                  ((empty @@ (se1, ghost)) @@
                   (ifChunk ~ghost tmp_lval loc skipChunk se3, ghost))
                  tmp_lval
                  tresult
              | Some e2' ->
                let is_real, lv, r, lvt, scope_chunk =
                  match what with
                  | ASet (is_real, lv, r, lvt) ->
                    is_real, lv, r, lvt, empty
                  | _ ->
                    let descr =
                      Format.asprintf "%a?%a:%a"
                        Cprint.print_expression e1
                        Cil_descriptive_printer.pp_exp e2'
                        Cil_descriptive_printer.pp_exp e3'
                    in
                    let tmp = newTempVar ~ghost loc descr true tresult in
                    false, var tmp, [], tresult,
                    local_var_chunk empty tmp
                in
                (* Now do e2 and e3 for real *)
                let (r2,se2, _, _) =
                  finishExp ~newWhat:(ASet(is_real,lv,r,lvt))
                    r2 se2 e2' t2
                in
                let (r3, se3, _, _) =
                  finishExp ~newWhat:(ASet(is_real,lv, r, lvt))
                    r3 se3 e3' t3
                in
                let cond = compileCondExp ~ghost ce1 se2 se3 in
                finishExp
                  (r2@r3)
                  (scope_chunk @@ (cond, ghost))
                  (new_exp ~loc (Lval lv)) tresult
            end
        end
      end
    | Cabs.GNU_BODY b -> begin
        (* Find the last Cabs.COMPUTATION and remember it. This one is invoked
         * on the reversed list of statements. *)
        let findLastComputation = function
            s :: _  ->
            let rec findLast st = match st.stmt_node with
              | Cabs.SEQUENCE (_, s, _) -> findLast s
              | CASE (_, s, _) -> findLast s
              | CASERANGE (_, _, s, _) -> findLast s
              | LABEL (_, s, _) -> findLast s
              | Cabs.COMPUTATION _ ->
                begin
                  match local_env.is_ghost,st.stmt_ghost with
                  | true,true | false, false -> st
                  | true, false -> assert false
                  | false, true -> raise Not_found
                end
              | _ -> raise Not_found
            in
            findLast s
          | [] -> raise Not_found
        in
        (* Save the previous data *)
        let old_gnu = ! gnu_body_result in
        let lastComp, isvoidbody =
          match what with
          | ADrop -> (* We are dropping the result *)
            {stmt_ghost = local_env.is_ghost; stmt_node = Cabs.NOP loc}, true
          | _ ->
            try findLastComputation (List.rev b.Cabs.bstmts), false
            with Not_found ->
              Kernel.fatal ~current:true "Cannot find COMPUTATION in GNU.body"
              (*                Cabs.NOP cabslu, true *)
        in
        let loc = Cabshelper.get_statementloc lastComp in
        (* Prepare some data to be filled by doExp ghost *)
        let data : (exp * typ) option ref = ref None in
        gnu_body_result := (lastComp, data);

        let se = doBodyScope local_env b in

        (*Kernel.debug "Body inside expression: %a@." d_chunk se;*)

        gnu_body_result := old_gnu;
        match !data with
        | None when isvoidbody ->
          finishExp [] se (zero ~loc:e.expr_loc) voidType
        | None -> abort_context "Cannot find COMPUTATION in GNU.body"
        | Some (e, t) ->
          let se, e =
            match se.stmts with
            | [ { skind = Block b},_, _, _, _ ] ->
              let vi = newTempVar ~ghost loc "GNU.body" true t in
              b.bstmts <-
                b.bstmts @
                [Cil.mkStmtOneInstr ~ghost:local_env.is_ghost ~valid_sid
                   (Set (Cil.var vi, e,loc))];
              (local_var_chunk se vi,Cil.new_exp ~loc (Lval (Cil.var vi)))
            | _ -> se,e
          in
          finishExp [] se e t
      end

    | Cabs.LABELADDR l -> begin (* GCC's taking the address of a label *)
        let l = lookupLabel ghost l in (* To support locally declared labels *)
        let addrval =
          try H.find gotoTargetHash l
          with Not_found -> begin
              let res = !gotoTargetNextAddr in
              incr gotoTargetNextAddr;
              H.add gotoTargetHash l res;
              res
            end
        in
        finishExp [] (unspecified_chunk empty)
          (makeCast ~e:(integer ~loc addrval) ~newt:voidPtrType) voidPtrType
      end

    | Cabs.EXPR_PATTERN _ -> abort_context "EXPR_PATTERN in cabs2cil input"

  in
  (*let (_a,b,_c,_d) = result in
    Format.eprintf "doExp ~const:%b ~e:" asconst ;
    Cprint.print_expression e;
    Format.eprintf "@.";
    Format.eprintf "Got: chunk:'%a'@." d_chunk b;*)
  CurrentLoc.set oldLoc;
  result

and normalize_unop unop action asconst local_env e what =
  match e.expr_node with
  | Cabs.COMMA el -> (* GCC extension *)
    doExp (no_inner_paren local_env) asconst
      { e with
        expr_node =
          Cabs.COMMA
            (replaceLastInList el
               (fun e -> { e with expr_node = Cabs.UNARY(unop, e)})) }
      what
  | Cabs.QUESTION (e1, e2, e3) -> (* GCC extension *)
    doExp (no_inner_paren local_env) asconst
      { e with
        expr_node =
          Cabs.QUESTION
            (e1,
             { e2 with expr_node = Cabs.UNARY(unop, e2)},
             { e3 with expr_node = Cabs.UNARY(unop, e3)})}
      what
  | Cabs.PAREN e1 ->
    doExp (inner_paren local_env) asconst
      { e with expr_node = Cabs.UNARY(unop, e1)} what
  | _ ->
    action
      { local_env with
        is_paren = local_env.inner_paren; inner_paren = false }
      e
      what

and normalize_binop binop action local_env asconst le re what =
  match le.expr_node with
  | Cabs.COMMA el -> (* GCC extension *)
    doExp (no_inner_paren local_env) asconst
      (cabs_exp le.expr_loc
         (Cabs.COMMA
            (replaceLastInList el
               (fun e -> cabs_exp e.expr_loc (Cabs.BINARY(binop, e, re))))))
      what
  | Cabs.QUESTION (e1, e2q, e3q) -> (* GCC extension *)
    (*TODO: prevent duplication of e2: this is incorrect
      if it contains labels *)
    (* let r2,se2,e2,t2 = doExp authorized_reads ghost asconst e2 in*)
    doExp (no_inner_paren local_env) asconst
      (cabs_exp le.expr_loc
         (Cabs.QUESTION
            (e1,
             cabs_exp e2q.expr_loc (Cabs.BINARY(binop, e2q, re)),
             cabs_exp e3q.expr_loc (Cabs.BINARY(binop, e3q, re)))))
      what
  | Cabs.CAST (t, Cabs.SINGLE_INIT e) when binop = Cabs.ASSIGN -> (* GCC extension *)
    doExp (no_inner_paren local_env) asconst
      (cabs_exp le.expr_loc
         (Cabs.CAST
            (t,
             Cabs.SINGLE_INIT
               (cabs_exp e.expr_loc
                  (Cabs.BINARY
                     (binop, e,
                      (cabs_exp re.expr_loc
                         (Cabs.CAST (t, Cabs.SINGLE_INIT re)))))))))
      what
  | Cabs.PAREN e1 ->
    doExp (inner_paren local_env) asconst
      (cabs_exp le.expr_loc (Cabs.BINARY(binop,e1,re))) what
  | _ ->
    action
      { local_env with is_paren = local_env.inner_paren; inner_paren = false }
      asconst le what

(* bop is always the arithmetic version. Change it to the appropriate pointer
 * version if necessary *)
and doBinOp loc (bop: binop) (e1: exp) (t1: typ) (e2: exp) (t2: typ) =
  let doArithmetic () =
    let tres = arithmeticConversion t1 t2 in
    (* Keep the operator since it is arithmetic *)
    tres,
    optConstFoldBinOp loc false bop
      (makeCastT ~e:e1 ~oldt:t1 ~newt:tres)
      (makeCastT ~e:e2 ~oldt:t2 ~newt:tres)
      tres
  in
  let doArithmeticComp () =
    let tres = arithmeticConversion t1 t2 in
    (* Keep the operator since it is arithmetic *)
    intType,
    optConstFoldBinOp loc false bop
      (makeCastT ~e:e1 ~oldt:t1 ~newt:tres)
      (makeCastT ~e:e2 ~oldt:t2 ~newt:tres)
      intType
  in
  let doIntegralArithmetic () =
    let tres = unrollType (arithmeticConversion t1 t2) in
    match tres with
    | TInt _ ->
      tres,
      optConstFoldBinOp loc false bop
        (makeCastT ~e:e1 ~oldt:t1 ~newt:tres)
        (makeCastT ~e:e2 ~oldt:t2 ~newt:tres)
        tres
    | _ ->
      Kernel.fatal ~current:true "%a operator on non-integer type %a"
        Cil_printer.pp_binop bop Cil_datatype.Typ.pretty tres
  in
  (* Invariant: t1 and t2 are pointers types *)
  let pointerComparison e1 t1 e2 t2 =
    if false then Kernel.debug "%a %a %a %a"
        Cil_printer.pp_exp e1 Cil_datatype.Typ.pretty t1
        Cil_printer.pp_exp e2 Cil_datatype.Typ.pretty t2;
    let t1p = Cil.(unrollType (typeOf_pointed t1)) in
    let t2p = Cil.(unrollType (typeOf_pointed t2)) in
    (* We are more lenient than the norm here (C99 6.5.8, 6.5.9), and cast
       arguments with incompatible types to a common type *)
    let e1', e2' =
      if not (areCompatibleTypes t1p t2p) then
        makeCastT ~e:e1 ~oldt:t1 ~newt:Cil.voidPtrType,
        makeCastT ~e:e2 ~oldt:t2 ~newt:Cil.voidPtrType
      else e1, e2
    in
    intType,
    optConstFoldBinOp loc false bop e1' e2' intType
  in
  let do_shift e1 t1 e2 t2 =
    match e1.enode with
    | StartOf lv ->
      { e1 with enode = AddrOf (addOffsetLval (Index (e2,NoOffset)) lv) }
    | _ ->
      optConstFoldBinOp loc false PlusPI e1
        (makeCastT ~e:e2 ~oldt:t2 ~newt:(integralPromotion t2)) t1
  in
  match bop with
  | (Mult|Div) -> doArithmetic ()
  | (Mod|BAnd|BOr|BXor) -> doIntegralArithmetic ()
  | (Shiftlt|Shiftrt) -> (* ISO 6.5.7. Only integral promotions. The result
                          * has the same type as the left hand side *)
    if Cil.msvcMode () then
      (* MSVC has a bug. We duplicate it here *)
      doIntegralArithmetic ()
    else
      let t1' = integralPromotion t1 in
      let t2' = integralPromotion t2 in
      t1',
      optConstFoldBinOp loc false bop
        (makeCastT ~e:e1 ~oldt:t1 ~newt:t1')
        (makeCastT ~e:e2 ~oldt:t2 ~newt:t2')
        t1'
  | (PlusA|MinusA)
    when isArithmeticType t1 && isArithmeticType t2 -> doArithmetic ()
  | (Eq|Ne|Lt|Le|Ge|Gt)
    when isArithmeticType t1 && isArithmeticType t2 ->
    doArithmeticComp ()
  | PlusA when isPointerType t1 && isIntegralType t2 ->
    t1, do_shift e1 t1 e2 t2
  | PlusA when isIntegralType t1 && isPointerType t2 ->
    t2, do_shift e2 t2 e1 t1
  | MinusA when isPointerType t1 && isIntegralType t2 ->
    t1,
    optConstFoldBinOp loc false MinusPI e1
      (makeCastT ~e:e2 ~oldt:t2 ~newt:(integralPromotion t2)) t1
  | MinusA when isPointerType t1 && isPointerType t2 ->
    if areCompatibleTypes (* C99 6.5.6:3 *)
        (Cil.type_remove_qualifier_attributes_deep t1)
        (Cil.type_remove_qualifier_attributes_deep t2)
    then
      theMachine.ptrdiffType,
      optConstFoldBinOp loc false MinusPP e1 e2 theMachine.ptrdiffType
    else abort_context "incompatible types in pointer subtraction"

  (* Two special cases for comparisons with the NULL pointer. We are a bit
     more permissive. *)
  | (Le|Lt|Ge|Gt|Eq|Ne) when isPointerType t1 && isZero e2 ->
    pointerComparison e1 t1 (makeCast ~e:e2 ~newt:t1) t1
  | (Le|Lt|Ge|Gt|Eq|Ne) when isPointerType t2 && isZero e1 ->
    pointerComparison (makeCast ~e:e1 ~newt:t2) t2 e2 t2

  | (Le|Lt|Ge|Gt|Eq|Ne) when isPointerType t1 && isPointerType t2 ->
    pointerComparison e1 t1 e2 t2

  | (Eq|Ne|Le|Lt|Ge|Gt) when (isPointerType t1 && isArithmeticType t2 ||
                              isArithmeticType t1 && isPointerType t2 ) ->
    Kernel.fatal ~current:true
      "comparison between pointer and non-pointer: %a"
      Cil_printer.pp_exp (dummy_exp(BinOp(bop,e1,e2,intType)))

  | _ ->
    Kernel.fatal ~current:true
      "doBinOp: %a"
      Cil_printer.pp_exp (dummy_exp(BinOp(bop,e1,e2,intType)))

(* Constant fold a conditional. This is because we want to avoid having
 * conditionals in the initializers. So, we try very hard to avoid creating
 * new statements.
*)
and doCondExp local_env asconst
    (* Try to evaluate the conditional expression
     * to TRUE or FALSE, because it occurs in a constant *)
    ?ctxt (* ctxt is used internally to determine if we should apply
             the conditional side effects hook (see above)
             and should not appear (i.e. be None) in toplevel calls. *)
    (e: Cabs.expression) : condExpRes =
  let ghost = local_env.is_ghost in
  let rec addChunkBeforeCE (c0: chunk) ce =
    let c0 = remove_effects c0 in
    match ce with
    | CEExp (c, e) -> CEExp ((empty @@ (c0, ghost)) @@ (c, ghost), e)
    | CEAnd (ce1, ce2) -> CEAnd (addChunkBeforeCE c0 ce1, ce2)
    | CEOr (ce1, ce2) -> CEOr (addChunkBeforeCE c0 ce1, ce2)
    | CENot ce1 -> CENot (addChunkBeforeCE c0 ce1)
  in
  let rec canDropCE = function
      CEExp (c, _e) -> canDrop c
    | CEAnd (ce1, ce2) | CEOr (ce1, ce2) -> canDropCE ce1 && canDropCE ce2
    | CENot (ce1) -> canDropCE ce1
  in
  let rec remove_effects_ce = function
    | CEExp(c,e) -> CEExp(remove_effects c,e)
    | CEAnd(ce1,ce2) -> CEAnd(remove_effects_ce ce1, remove_effects_ce ce2)
    | CEOr(ce1,ce2) -> CEOr(remove_effects_ce ce1, remove_effects_ce ce2)
    | CENot(ce) -> CENot(remove_effects_ce ce)
  in
  let loc = e.expr_loc in
  let result = match e.expr_node with
    | Cabs.BINARY (Cabs.AND, e1, e2) -> begin
        let ce1 = doCondExp (no_paren_local_env local_env) asconst ?ctxt e1 in
        let ce2 = doCondExp (no_paren_local_env local_env) asconst ~ctxt:e e2 in
        let ce1 = remove_effects_ce ce1 in
        match ce1, ce2 with
        | CEExp (se1, ({enode = Const ci1})), _ ->
          (match isConstTrueFalse ci1 with
           | `CTrue -> addChunkBeforeCE se1 ce2
           | `CFalse ->
             (* se2 might contain labels so we cannot always drop it *)
             if canDropCE ce2 then begin
               clean_up_cond_locals ce2; ce1
             end else CEAnd (ce1, ce2))
        | CEExp(se1, e1'), CEExp (se2, e2') when
            theMachine.useLogicalOperators && isEmpty se1 && isEmpty se2 ->
          CEExp (empty, new_exp ~loc (BinOp(LAnd, e1', e2', intType)))
        | _ -> CEAnd (ce1, ce2)
      end

    | Cabs.BINARY (Cabs.OR, e1, e2) -> begin
        let ce1 = doCondExp (no_paren_local_env local_env) asconst ?ctxt e1 in
        let ce2 = doCondExp (no_paren_local_env local_env) asconst ~ctxt:e e2 in
        let ce1 = remove_effects_ce ce1 in
        match ce1, ce2 with
        | CEExp (se1, ({enode = Const ci1})), _ ->
          (match isConstTrueFalse ci1 with
           | `CFalse -> addChunkBeforeCE se1 ce2
           | `CTrue ->
             (* se2 might contain labels so we cannot drop it *)
             if canDropCE ce2 then begin
               clean_up_cond_locals ce2; ce1
             end else CEOr (ce1, ce2))
        | CEExp (se1, e1'), CEExp (se2, e2') when
            theMachine.useLogicalOperators && isEmpty se1 && isEmpty se2 ->
          CEExp (empty, new_exp ~loc (BinOp(LOr, e1', e2', intType)))
        | _ -> CEOr (ce1, ce2)
      end

    | Cabs.UNARY(Cabs.NOT, e1) -> begin
        match doCondExp (no_paren_local_env local_env) asconst ?ctxt e1 with
        | CEExp (se1, e) when isEmpty se1 ->
          let t = typeOf e in
          if not ((isPointerType t) || (isArithmeticType t))then
            Kernel.error ~once:true ~current:true "Bad operand to !";
          CEExp (empty, new_exp ~loc (UnOp(LNot, e, intType)))
        | ce1 -> CENot ce1
      end

    | Cabs.PAREN e ->
      doCondExp (paren_local_env local_env) asconst ?ctxt e

    | _ ->
      let (r, se, e', t) =
        doExp local_env asconst e (AExp None)
      in
      (* No need to add reads here: we'll always have a sequence point,
         either because the expression is complete, or because of a logic
         operator. *)
      (match ctxt with
       | None -> ()
       | Some _ when isEmpty se -> ()
       | Some orig ->
         ConditionalSideEffectHook.apply (orig,e));
      ignore (checkBool t e');
      CEExp (add_reads ~ghost e.expr_loc r se,
             if asconst <> CNoConst || theMachine.lowerConstants then
               constFold true e'
             else e')
  in
  result

and compileCondExp ~ghost ce st sf =
  match ce with
  | CEAnd (ce1, ce2) ->
    let loc = CurrentLoc.get () in
    let (duplicable, sf1, sf2) =
      (* If sf is small then will copy it *)
      try (true, sf, duplicateChunk sf)
      with Failure _ ->
        let lab = newLabelName ghost "_LAND" in
        (false, gotoChunk ~ghost lab loc, consLabel ~ghost lab sf loc false)
    in
    let st' = compileCondExp ~ghost ce2 st sf1 in
    if not duplicable && !doAlternateConditional then
      let st_fall_through = chunkFallsThrough st' in
      (* if st does not fall through, we do not need to add a goto
         after the else part. This prevents spurious falls-through warning
         afterwards. *)
      let sf' = duplicateChunk sf1 in
      let lab = newLabelName ghost "_LAND" in
      let gotostmt =
        if st_fall_through then gotoChunk ~ghost lab loc else skipChunk
      in
      let labstmt =
        if st_fall_through then
          consLabel ~ghost lab empty loc false
        else skipChunk
      in
      let (@@) s1 s2 = s1 @@ (s2, ghost) in
      (compileCondExp ~ghost ce1 st' sf')
      @@ gotostmt @@ sf2 @@ labstmt
    else
      let sf' = sf2 in
      compileCondExp ~ghost ce1 st' sf'

  | CEOr (ce1, ce2) ->
    let loc = CurrentLoc.get () in
    let (duplicable, st1, st2) =
      (* If st is small then will copy it *)
      try (true, st, duplicateChunk st)
      with Failure _ ->
        let lab = newLabelName ghost "_LOR" in
        (false, gotoChunk ~ghost lab loc, consLabel ~ghost lab st loc false)
    in
    if not duplicable && !doAlternateConditional then
      let st' = duplicateChunk st1 in
      let sf' = compileCondExp ~ghost ce2 st1 sf in
      let sf_fall_through = chunkFallsThrough sf' in
      let lab = newLabelName ghost "_LOR" in
      let gotostmt =
        if sf_fall_through then
          gotoChunk ~ghost lab loc
        else skipChunk
      in
      let labstmt =
        if sf_fall_through then
          consLabel ~ghost lab empty (CurrentLoc.get ()) false
        else skipChunk
      in
      let (@@) s1 s2 = s1 @@ (s2, ghost) in
      (compileCondExp ~ghost ce1 st' sf')
      @@ gotostmt @@ st2 @@ labstmt
    else
      let st' = st1 in
      let sf' = compileCondExp ~ghost ce2 st2 sf in
      (*Format.eprintf
        "result:@\nchunk then:@\n  @[%a@]@\nchunk else:  @[%a@]@."
        d_chunk st d_chunk sf;*)
      compileCondExp ~ghost ce1 st' sf'

  | CENot ce1 -> compileCondExp ~ghost ce1 sf st

  | CEExp (se, e) -> begin
      match e.enode with
      | Const(CInt64(i,_,_))
        when (not (Integer.equal i Integer.zero)) && canDrop sf ->
        full_clean_up_chunk_locals sf;
        se @@ (st, ghost)
      | Const(CInt64(z,_,_))
        when (Integer.equal z Integer.zero) && canDrop st ->
        full_clean_up_chunk_locals st;
        se @@ (sf, ghost)
      | _ -> (empty @@ (se, ghost)) @@ (ifChunk ~ghost e e.eloc st sf, ghost)
    end


(* A special case for conditionals *)
and doCondition local_env asconst
    (* If we are in constants, we do our best to eliminate the conditional *)
    (e: Cabs.expression)
    (st: chunk)
    (sf: chunk) : chunk =
  if isEmpty st && isEmpty sf(*TODO: ignore attribute FRAMA_C_KEEP_BLOCK*) then
    begin
      let (_, se,e,_) = doExp local_env CNoConst e ADrop in
      if is_dangerous e then begin
        let ghost = local_env.is_ghost in
        se @@ (keepPureExpr ~ghost e e.eloc, ghost)
      end else begin
        if (isEmpty se) then begin
          let name = !currentFunctionFDEC.svar.vorig_name in
          IgnorePureExpHook.apply (name, e)
        end;
        se
      end
    end else begin
    let ce = doCondExp (no_paren_local_env local_env) asconst e in
    let chunk = compileCondExp ~ghost:local_env.is_ghost ce st sf in
    chunk
  end

and doPureExp local_env (e : Cabs.expression) : exp =
  let (_,se, e', _) = doExp local_env CConst e (AExp None) in
  if isNotEmpty se then
    Kernel.error
      ~once:true ~current:true "%a has side-effects" Cprint.print_expression e;
  e'

and doFullExp local_env const e what =
  let (r, se,e,t) = doExp local_env const e what in
  let se' = add_reads ~ghost:local_env.is_ghost e.eloc r se in
  (* there is a sequence point after a full exp *)
  empty @@ (se', local_env.is_ghost),e,t

and doInitializer local_env (vi: varinfo) (inite: Cabs.init_expression)
  (* Return the accumulated chunk, the initializer and the new type (might be
   * different for arrays), together with the lvals read during evaluation of
   * the initializer (for local intialization)
  *)
  : chunk * init * typ * Cil_datatype.Lval.Set.t =

  Kernel.debug ~dkey:Kernel.dkey_typing_init
    "@\nStarting a new initializer for %s : %a@\n"
    vi.vname Cil_datatype.Typ.pretty vi.vtype;
  let acc, preinit, restl =
    let so = makeSubobj vi vi.vtype NoOffset in
    let asconst = if vi.vglob then CConst else CNoConst in
    doInit local_env asconst Extlib.nop NoInitPre so
      (unspecified_chunk empty) [ (Cabs.NEXT_INIT, inite) ]
  in
  if restl <> [] then
    Kernel.warning ~current:true "Ignoring some initializers";
  (* sm: we used to do array-size fixups here, but they only worked
   * for toplevel array types; now, collectInitializer does the job,
   * including for nested array types *)
  let typ' = vi.vtype in
  Kernel.debug ~dkey:Kernel.dkey_typing_init
    "Collecting the initializer for %s@\n" vi.vname;
  let (init, typ'', reads) =
    collectInitializer Cil_datatype.Lval.Set.empty preinit typ'
      ~parenttype:typ'
  in
  Kernel.debug ~dkey:Kernel.dkey_typing_init
    "Finished the initializer for %s@\n  init=%a@\n  typ=%a@\n  acc=%a@\n"
    vi.vname Cil_printer.pp_init init Cil_datatype.Typ.pretty typ' d_chunk acc;
  empty @@ (acc, local_env.is_ghost), init, typ'', reads

(* Consume some initializers. This is used by both global and local variables
   initialization.
   – local_env is the current environment
   – asconst is used to indicate that expressions must be compile-time constant
     (i.e. we are in a global initializer)
   – add_implicit_ensures is a callback to add an ensures clause to contracts
     above current initialized part when it is partially initialized.
     Does nothing initially. Useful only for initialization of locals
   – preinit corresponds to the initializers seen previously (for globals)
   – so contains the information about the current subobject currently being
     initialized
   – acc is the chunk corresponding to initializations seen previously
     (for locals)
   – initl is the current list of initializers to be processed
   doInit returns a triple:
   – chunk performing initialization
   – preinit corresponding to the complete initialization
   – the list of unused initializers if any (should be empty most of the time)
*)
and doInit local_env asconst add_implicit_ensures preinit so acc initl =
  let ghost = local_env.is_ghost in
  let whoami fmt = Cil_printer.pp_lval fmt (Var so.host, so.soOff) in
  let initl1 =
    match initl with
    | (Cabs.NEXT_INIT,
       Cabs.SINGLE_INIT ({ expr_node = Cabs.CAST ((s, dt), ie)} as e)) :: rest ->
      let s', dt', ie' = preprocessCast ghost s dt ie in
      (Cabs.NEXT_INIT,
       Cabs.SINGLE_INIT
         ({expr_node = Cabs.CAST ((s', dt'), ie'); expr_loc = e.expr_loc}))
      :: rest
    | _ -> initl
  in
  (* Sometimes we have a cast in front of a compound (in GCC). This
   * appears as a single initializer. Ignore the cast  *)
  let initl2 =
    match initl1 with
    | (what,
       Cabs.SINGLE_INIT
         ({expr_node = Cabs.CAST ((specs, dt), Cabs.COMPOUND_INIT ci)})) :: rest ->
      let s', dt', _ie' = preprocessCast ghost specs dt (Cabs.COMPOUND_INIT ci) in
      let typ = doOnlyType ghost s' dt' in
      if Typ.equal
          (Cil.typeDeepDropAllAttributes typ)
          (Cil.typeDeepDropAllAttributes so.soTyp)
      then
        (* Drop the cast *)
        (what, Cabs.COMPOUND_INIT ci) :: rest
      else
        (* Keep the cast.  A new var will be created to hold
           the intermediate value.  *)
        initl1
    | _ -> initl1
  in
  let allinitl = initl2 in
  Kernel.debug ~dkey:Kernel.dkey_typing_init
    "doInit for %t %s (current %a). Looking at: %t" whoami
    (if so.eof then "(eof)" else "")
    Cil_printer.pp_lval (Var so.host, so.curOff)
    (fun fmt ->
       match allinitl with
       | [] -> Format.fprintf fmt "[]@."
       | (what, ie) :: _ ->
         Cprint.print_init_expression fmt (Cabs.COMPOUND_INIT [(what, ie)])
    );
  match unrollType so.soTyp, allinitl with
  (* No more initializers return *)
  | _, [] -> acc, preinit, []
  (* No more subobjects to initialize *)
  | _, (Cabs.NEXT_INIT, _) :: _ when so.eof -> acc, preinit, allinitl
  (* If we are at an array of characters and the initializer is a
   * string literal (optionally enclosed in braces) then explode the
   * string into characters *)
  | TArray(bt, leno, _ ),
    (Cabs.NEXT_INIT,
     (Cabs.SINGLE_INIT({ expr_node = Cabs.CONSTANT (Cabs.CONST_STRING s)} as e)|
      Cabs.COMPOUND_INIT
        [(Cabs.NEXT_INIT,
          Cabs.SINGLE_INIT(
            { expr_node =
                Cabs.CONSTANT
                  (Cabs.CONST_STRING s)} as e))]))
    :: restil
    when (match unrollType bt with
        | TInt((IChar|IUChar|ISChar), _) -> true
        | TInt _ ->
          (*Base type is a scalar other than char. Maybe a wchar_t?*)
          Kernel.fatal ~current:true
            "Using a string literal to initialize something other than \
             a character array"
        | _ ->  false (* OK, this is probably an array of strings. Handle *)
      )              (* it with the other arrays below.*)
    ->
    let charinits =
      let init c =
        Cabs.NEXT_INIT,
        Cabs.SINGLE_INIT
          { expr_node = Cabs.CONSTANT (Cabs.CONST_CHAR [c]);
            expr_loc = e.expr_loc }
      in
      let collector =
        (* ISO 6.7.8 para 14: final NUL added only if no size specified, or
         * if there is room for it; btw, we can't rely on zero-init of
         * globals, since this array might be a local variable *)
        if (Option.is_none leno ||
            ((String.length s) < (integerArrayLength leno)))
        then ref [init Int64.zero]
        else ref []
      in
      for pos = String.length s - 1 downto 0 do
        collector := init (Int64.of_int (Char.code (s.[pos]))) :: !collector
      done;
      !collector
    in
    (* Create a separate object for the array *)
    let so' = makeSubobj so.host so.soTyp so.soOff in
    (* Go inside the array *)
    let leno = integerArrayLength leno in
    so'.stack <- [InArray(so'.curOff, bt, leno, ref 0)];
    normalSubobj so';
    let acc', preinit', initl' =
      doInit local_env asconst add_implicit_ensures preinit so' acc charinits in
    if initl' <> [] then
      Kernel.warning ~current:true
        "Too many initializers for character array %t" whoami;
    (* Advance past the array *)
    advanceSubobj so;
    (* Continue *)
    doInit local_env asconst add_implicit_ensures preinit' so acc' restil
  (* If we are at an array of WIDE characters and the initializer is a
   * WIDE string literal (optionally enclosed in braces) then explore
   * the WIDE string into characters *)
  (* [weimer] Wed Jan 30 15:38:05 PST 2002
   * Despite what the compiler says, this match case is used and it is
   * important. *)
  | TArray(bt, leno, _),
    (Cabs.NEXT_INIT,
     (Cabs.SINGLE_INIT({expr_node = Cabs.CONSTANT (Cabs.CONST_WSTRING s)} as e)|
      Cabs.COMPOUND_INIT
        [(Cabs.NEXT_INIT,
          Cabs.SINGLE_INIT(
            {expr_node =
               Cabs.CONSTANT
                 (Cabs.CONST_WSTRING s)} as e))]))
    :: restil
    when
      (let bt' = unrollType bt in
       match bt' with
       (* compare bt to wchar_t, ignoring signed vs. unsigned *)
       | TInt _ when (bitsSizeOf bt') =
                     (bitsSizeOf theMachine.wcharType) ->
         true
       | TInt _ ->
         (*Base type is a scalar other than wchar_t.
           Maybe a char?*)
         Kernel.fatal ~current:true
           "Using a wide string literal to initialize \
            something other than a wchar_t array"
       | _ -> false
       (* OK, this is probably an array of strings. Handle
          it with the other arrays below.*)
      )
    ->
    let maxWChar =  (*  (2**(bitsSizeOf !wcharType)) - 1  *)
      Int64.sub (Int64.shift_left Int64.one (bitsSizeOf theMachine.wcharType))
        Int64.one in
    let charinits =
      let init c =
        if Int64.compare c maxWChar > 0 then (* if c > maxWChar *)
          Kernel.error ~once:true ~current:true
            "cab2cil:doInit:character 0x%Lx too big." c;
        Cabs.NEXT_INIT,
        Cabs.SINGLE_INIT
          { expr_node = Cabs.CONSTANT (Cabs.CONST_INT (Int64.to_string c));
            expr_loc = e.expr_loc
          }
      in
      (List.map init s) @
      (
        (* ISO 6.7.8 para 14: final NUL added only if no size specified, or
         * if there is room for it; btw, we can't rely on zero-init of
         * globals, since this array might be a local variable *)
        if (Option.is_none leno
            || ((List.length s) < (integerArrayLength leno)))
        then [init Int64.zero]
        else [])
    in
    (* Create a separate object for the array *)
    let so' = makeSubobj so.host so.soTyp so.soOff in
    (* Go inside the array *)
    let leno = integerArrayLength leno in
    so'.stack <- [InArray(so'.curOff, bt, leno, ref 0)];
    normalSubobj so';
    let acc', preinit', initl' =
      doInit local_env asconst add_implicit_ensures preinit so' acc charinits
    in
    if initl' <> [] then
      (* sm: see above regarding ISO 6.7.8 para 14, which is not implemented
       * for wchar_t because, as far as I can tell, we don't even put in
       * the automatic NUL (!) *)
      Kernel.warning ~current:true
        "Too many initializers for wchar_t array %t" whoami;
    (* Advance past the array *)
    advanceSubobj so;
    (* Continue *)
    doInit local_env asconst add_implicit_ensures preinit' so acc' restil
  (* If we are at an array and we see a single initializer then it must
   * be one for the first element *)
  | TArray(bt, leno, _), (Cabs.NEXT_INIT, Cabs.SINGLE_INIT _oneinit) :: _restil  ->
    (* Grab the length if there is one *)
    let leno = integerArrayLength leno in
    so.stack <- InArray(so.soOff, bt, leno, ref 0) :: so.stack;
    normalSubobj so;
    (* Start over with the fields *)
    doInit local_env asconst add_implicit_ensures preinit so acc allinitl
  (* An incomplete structure with any initializer is an error. *)
  | TComp (comp, _), _ :: restil when comp.cfields = None ->
    Kernel.error ~current:true ~once:true
      "variable `%s' has initializer but incomplete type" so.host.vname;
    doInit local_env asconst add_implicit_ensures preinit so acc restil
  (* If we are at a composite and we see a single initializer of the same
   * type as the composite then grab it all. If the type is not the same
   * then we must go on and try to initialize the fields *)
  | TComp (comp, _), (Cabs.NEXT_INIT, Cabs.SINGLE_INIT oneinit) :: restil ->
    let r,se, oneinit', t' =
      doExp (no_paren_local_env local_env) asconst oneinit (AExp None)
    in
    let r = Cil_datatype.Lval.Set.of_list r in
    if (match unrollType t' with
        | TComp (comp', _) when comp'.ckey = comp.ckey -> true
        | _ -> false)
    then begin
      (* Initialize the whole struct *)
      let preinit = setOneInit preinit so.soOff (SinglePre (oneinit', r)) in
      (* Advance to the next subobject *)
      advanceSubobj so;
      let se = acc @@ (se, ghost) in
      doInit local_env asconst add_implicit_ensures preinit so se restil
    end else begin (* Try to initialize fields *)
      let toinit = fieldsToInit comp None in
      so.stack <- InComp(so.soOff, comp, toinit) :: so.stack;
      normalSubobj so;
      doInit local_env asconst add_implicit_ensures preinit so acc allinitl
    end

  (* A scalar with a single initializer *)
  | _, (Cabs.NEXT_INIT, Cabs.SINGLE_INIT oneinit) :: restil ->
    let r, se, oneinit', t' =
      doExp (no_paren_local_env local_env) asconst oneinit (AExp(Some so.soTyp))
    in
    let r = Cil_datatype.Lval.Set.of_list r in
    Kernel.debug ~dkey:Kernel.dkey_typing_init "oneinit'=%a, t'=%a, so.soTyp=%a"
      Cil_printer.pp_exp oneinit' Cil_datatype.Typ.pretty t'
      Cil_datatype.Typ.pretty so.soTyp;
    let init_expr =
      if theMachine.insertImplicitCasts then snd (castTo t' so.soTyp oneinit')
      else oneinit'
    in
    let preinit' = setOneInit preinit so.soOff (SinglePre (init_expr,r)) in
    (* Move on *)
    advanceSubobj so;
    let se = acc @@ (se,ghost) in
    doInit local_env asconst add_implicit_ensures preinit' so se restil
  (* An array with a compound initializer. The initializer is for the
   * array elements *)
  | TArray (bt, leno, _), (Cabs.NEXT_INIT, Cabs.COMPOUND_INIT initl) :: restil ->
    (* Create a separate object for the array *)
    let so' = makeSubobj so.host so.soTyp so.soOff in
    (* Go inside the array *)
    let len = integerArrayLength leno in
    so'.stack <- [InArray(so'.curOff, bt, len, ref 0)];
    normalSubobj so';
    let acc', preinit', initl' =
      match initl with
      | [] ->
        (* we must actually indicate that there is some initializer, albeit
           empty, to our parent. This is in particular important if said
           parent is an array of indeterminate size, as the number of
           initializers of its children matters. *)
        let preinit' = setOneInit preinit so'.curOff (empty_preinit()) in
        (* zero initialization will be done anyway,
           no need to change the chunk.*)
        acc, preinit', []
      | _ ->
        doInit
          local_env asconst add_implicit_ensures preinit so' acc initl
    in
    if initl' <> [] then
      Kernel.warning ~current:true
        "Too many initializers for array %t" whoami;
    (* Advance past the array *)
    advanceSubobj so;
    (* Continue *)
    doInit local_env asconst add_implicit_ensures preinit' so acc' restil
  (* We have a designator that tells us to select the matching union field.
   * This is to support a GCC extension *)
  | TComp(ci, _) as targ,
    [(Cabs.NEXT_INIT,
      Cabs.COMPOUND_INIT
        [(Cabs.INFIELD_INIT ("___matching_field", Cabs.NEXT_INIT),
          Cabs.SINGLE_INIT oneinit)])]
    when not ci.cstruct ->
    (* Do the expression to find its type *)
    let _, c, _, t' =
      doExp (no_paren_local_env local_env) asconst oneinit (AExp None)
    in
    clean_up_chunk_locals c;
    let t'noattr = Cil.typeDeepDropAllAttributes t' in
    let rec findField = function
      | [] ->
        Kernel.fatal ~current:true "Cannot find matching union field in cast"
      | fi :: _rest when
          Typ.equal (Cil.typeDeepDropAllAttributes fi.ftype) t'noattr -> fi
      | _ :: rest -> findField rest
    in
    (* If this is a cast from union X to union X *)
    if Typ.equal t'noattr (Cil.typeDeepDropAllAttributes targ) then
      doInit
        local_env asconst add_implicit_ensures preinit so acc
        [(Cabs.NEXT_INIT, Cabs.SINGLE_INIT oneinit)]
    else
      (* If this is a GNU extension with field-to-union cast find the field *)
      let fi = findField (Option.value ~default:[] ci.cfields) in
      (* Change the designator and redo *)
      doInit
        local_env asconst add_implicit_ensures preinit so acc
        [Cabs.INFIELD_INIT (fi.fname, Cabs.NEXT_INIT), Cabs.SINGLE_INIT oneinit]

  (* A structure with a composite initializer. We initialize the fields*)
  | TComp (comp, _), (Cabs.NEXT_INIT, Cabs.COMPOUND_INIT initl) :: restil ->
    (* Create a separate subobject iterator *)
    let so' = makeSubobj so.host so.soTyp so.soOff in
    (* Go inside the comp *)
    so'.stack <- [InComp(so'.curOff, comp, fieldsToInit comp None)];
    normalSubobj so';
    let acc', preinit', initl' =
      match initl with
      | [] -> (* empty initializer, a GNU extension to indicate
                 0-initialization. We must indicate to our parent that we are
                 here, though. *)
        let preinit' = setOneInit preinit so'.curOff (empty_preinit()) in
        acc, preinit', []
      | _ ->
        doInit local_env asconst add_implicit_ensures preinit so' acc initl
    in
    if initl' <> [] then
      Kernel.warning ~current:true "Too many initializers for structure";
    (* Advance past the structure *)
    advanceSubobj so;
    (* Continue *)
    doInit local_env asconst add_implicit_ensures preinit' so acc' restil
  (* A scalar with a initializer surrounded by a number of braces *)
  | t, (Cabs.NEXT_INIT, next) :: restil ->
    begin
      let rec find_one_init c =
        match c with
        | Cabs.COMPOUND_INIT [Cabs.NEXT_INIT,next] -> find_one_init next
        | Cabs.SINGLE_INIT oneinit -> oneinit
        | _ -> raise Not_found
      in
      try
        let oneinit = find_one_init next in
        let r,se, oneinit', t' =
          doExp (no_paren_local_env local_env)
            asconst oneinit (AExp(Some so.soTyp))
        in
        let r = Cil_datatype.Lval.Set.of_list r in
        let init_expr = makeCastT ~e:oneinit' ~oldt:t' ~newt:so.soTyp in
        let preinit' = setOneInit preinit so.soOff (SinglePre (init_expr, r)) in
        (* Move on *)
        advanceSubobj so;
        let se = acc @@ (se, ghost) in
        doInit local_env asconst add_implicit_ensures preinit' so se restil
      with Not_found ->
        abort_context
          "scalar value (of type %a) initialized by compound initializer"
          Cil_datatype.Typ.pretty t
    end
  (* We have a designator *)
  | _, (what, ie) :: restil when what != Cabs.NEXT_INIT ->
    (* Process a designator and position to the designated subobject *)
    let addressSubobj
        (so: subobj)
        (what: Cabs.initwhat)
        (acc: chunk) : chunk =
      (* Always start from the current element *)
      so.stack <- []; so.eof <- false;
      normalSubobj so;
      let rec address (what: Cabs.initwhat) (acc: chunk)  : chunk =
        match what with
        | Cabs.NEXT_INIT -> acc
        | Cabs.INFIELD_INIT (fn, whatnext) -> begin
            match unrollType so.soTyp with
            | TComp (comp, _) ->
              let toinit = fieldsToInit comp (Some fn) in
              so.stack <- InComp(so.soOff, comp, toinit) :: so.stack;
              normalSubobj so;
              address whatnext acc
            | _ ->
              Kernel.fatal ~current:true
                "Field designator %s not in a struct " fn
          end

        | Cabs.ATINDEX_INIT(idx, whatnext) -> begin
            match unrollType so.soTyp with
            | TArray (bt, leno, _) ->
              let ilen = integerArrayLength leno in
              let nextidx', doidx =
                let (r,doidx, idxe', _) =
                  doExp
                    (no_paren_local_env local_env)
                    CConst idx (AExp(Some intType))
                in

                let doidx = add_reads ~ghost idxe'.eloc r doidx in
                match constFoldToInt idxe', isNotEmpty doidx with
                | Some x, false ->
                  begin
                    match Integer.to_int_opt x with
                    | Some x' -> x', doidx
                    | None -> abort_context
                                "INDEX initialization designator overflows"
                  end
                | _ ->
                  abort_context
                    "INDEX initialization designator is not a constant"
              in
              if nextidx' < 0 || nextidx' >= ilen then
                abort_context "INDEX designator is outside bounds";
              so.stack <-
                InArray(so.soOff, bt, ilen, ref nextidx') :: so.stack;
              normalSubobj so;
              address whatnext (acc @@ (doidx, ghost))

            | _ -> abort_context "INDEX designator for a non-array"
          end

        | Cabs.ATINDEXRANGE_INIT _ -> abort_context "addressSubobj: INDEXRANGE"
      in
      address what acc
    in
    (* First expand the INDEXRANGE by making copies *)
    let rec expandRange (top: Cabs.initwhat -> Cabs.initwhat) = function
      | Cabs.INFIELD_INIT (fn, whatnext) ->
        expandRange (fun what -> top (Cabs.INFIELD_INIT(fn, what))) whatnext
      | Cabs.ATINDEX_INIT (idx, whatnext) ->
        expandRange (fun what -> top (Cabs.ATINDEX_INIT(idx, what))) whatnext
      | Cabs.ATINDEXRANGE_INIT (idxs, idxe) ->
        let (rs, doidxs, idxs', _) =
          doExp (no_paren_local_env local_env) CConst idxs (AExp(Some intType))
        in
        let (re, doidxe, idxe', _) =
          doExp (no_paren_local_env local_env) CConst idxe (AExp(Some intType))
        in
        let doidxs = add_reads ~ghost idxs'.eloc rs doidxs in
        let doidxe = add_reads ~ghost idxe'.eloc re doidxe in
        if isNotEmpty doidxs || isNotEmpty doidxe then
          Kernel.fatal ~current:true "Range designators are not constants";
        let first, last =
          match constFoldToInteger idxs', constFoldToInteger idxe' with
          | Some s, Some e -> s, e
          | _ ->
            Kernel.fatal ~current:true
              "INDEX_RANGE initialization designator is not a valid constant"
        in
        if first < 0 || first > last then
          Kernel.error ~once:true ~current:true
            "start index larger than end index in range initializer";
        (* Arbitrary limit to avoid building an impractical AST. *)
        if last - first > 100_000 then
          Kernel.fatal ~current:true "INDEX_RANGE too large";
        let rec loop (i: int) =
          if i > last then restil
          else
            (top (Cabs.ATINDEX_INIT(
                 { expr_node = Cabs.CONSTANT(Cabs.CONST_INT(string_of_int i));
                   expr_loc = fst idxs.expr_loc, snd idxe.expr_loc},
                 Cabs.NEXT_INIT)), ie)
            :: loop (i + 1)
        in
        doInit
          local_env asconst add_implicit_ensures preinit so acc (loop first)
      | Cabs.NEXT_INIT -> (* We have not found any RANGE *)
        let acc' = addressSubobj so what acc in
        doInit
          local_env asconst add_implicit_ensures preinit so acc'
          ((Cabs.NEXT_INIT, ie) :: restil)
    in
    expandRange (fun x -> x) what
  | t, (_what, _ie) :: _ ->
    abort_context "doInit: cases for t=%a" Cil_datatype.Typ.pretty t

(* Create and add to the file (if not already added) a global. Return the
 * varinfo *)
and createGlobal ghost logic_spec ((t,s,b,attr_list) : (typ * storage * bool * Cabs.attribute list))
    (((n,ndt,a,cloc), inite) : Cabs.init_name) : varinfo =
  Kernel.debug ~dkey:Kernel.dkey_typing_global "createGlobal: %s" n;
  (* If the global is a Frama-C builtin, set the generated flag *)
  if is_stdlib_macro n && get_current_stdheader () = "" then begin
    Kernel.warning ~wkey:Kernel.wkey_cert_msc_38 ~current:true
      "Attempt to declare %s as external identifier outside of the stdlib. \
       It is supposed to be a macro name and cannot be declared. See CERT C \
       coding rule MSC38-C" n
  end;
  let is_fc_builtin {Cabs.expr_node=enode} =
    match enode with Cabs.VARIABLE "FC_BUILTIN" -> true | _ -> false
  in
  let is_fc_stdlib {Cabs.expr_node=enode} =
    match enode with Cabs.VARIABLE v when v = fc_stdlib -> true | _ -> false
  in
  let isgenerated =
    List.exists (fun (_,el) -> List.exists is_fc_builtin el) a
  in
  let islibc =
    List.exists (fun (_,el) -> List.exists is_fc_stdlib el) a
  in
  (* Make a first version of the varinfo *)
  let vi_loc = convLoc cloc in
  let vi = makeVarInfoCabs ~ghost ~isformal:false ~referenced:islibc
      ~isglobal:true ~isgenerated vi_loc (t,s,b,attr_list) (n,ndt,a)
  in
  (* Add the variable to the environment before doing the initializer
   * because it might refer to the variable itself *)
  if isFunctionType vi.vtype then begin
    FuncLocs.add_loc ?spec:logic_spec (CurrentLoc.get ()) vi_loc n;
    if inite != Cabs.NO_INIT  then
      Kernel.error ~once:true ~current:true
        "Function declaration with initializer (%s)\n" vi.vname;
  end else if Option.is_some logic_spec then begin
    Kernel.warning ~wkey:Kernel.wkey_annot_error ~current:true ~once:true
      "Global variable %s is not a function. It cannot have a contract."
      vi.vname
  end;
  let isadef =
    not (isFunctionType vi.vtype) &&
    (inite != Cabs.NO_INIT
     ||
     (* tentative definition, but definition nevertheless. *)
     vi.vstorage = NoStorage || vi.vstorage = Static)
  in
  let vi, alreadyInEnv = makeGlobalVarinfo isadef vi in
  (* Do the initializer and complete the array type if necessary *)
  let init : init option =
    if inite = Cabs.NO_INIT then
      None
    else
      let se, ie', et, _ = doInitializer (ghost_local_env ghost) vi inite in
      (* Maybe we now have a better type?  Use the type of the
       * initializer only if it really differs from the type of
       * the variable. *)
      if unrollType vi.vtype != unrollType et then
        Cil.update_var_type vi et;
      if isNotEmpty se then begin
        Kernel.error ~once:true ~current:true
          "invalid global initializer @[%a@]" d_chunk se;
      end;
      Some ie'
  in

  try
    let oldloc = H.find alreadyDefined vi.vname in
    if init != None then begin
      (* function redefinition is taken care of elsewhere. *)
      Kernel.error ~once:true ~current:true
        "Global %s was already defined at %a" vi.vname Cil_printer.pp_location oldloc;
    end;
    Kernel.debug ~dkey:Kernel.dkey_typing_global
      " global %s was already defined" vi.vname;
    (* Do not declare it again, but update the spec if any *)
    if isFunctionType vi.vtype then
      begin
        match logic_spec with
        | None -> ()
        | Some (spec,_) ->
          let l1 = get_formals vi in
          let l2 = Cil.getFormalsDecl vi in
          List.iter2
            (fun x y ->
               if x != y then
                 Kernel.fatal ~current:true
                   "Function %s: formals are not shared between AST and \
                    FormalDecls table" vi.vname)
            l1 l2;
          try
            let known_behaviors = find_existing_behaviors vi in
            let spec =
              Ltyping.funspec
                known_behaviors vi (Some(get_formals vi)) vi.vtype spec
            in
            update_funspec_in_theFile vi spec
          with LogicTypeError ((source,_),msg) ->
            Kernel.warning ~wkey:Kernel.wkey_annot_error ~source
              "%s. Ignoring specification of function %s" msg vi.vname
      end ;
    vi
  with Not_found -> begin
      (* Not already defined *)
      Kernel.debug ~dkey:Kernel.dkey_typing_global
        " first definition for %s(%d)\n" vi.vname vi.vid;
      if init != None then begin
        (* weimer: Sat Dec  8 17:43:34  2001
         * MSVC NT Kernel headers include this lovely line:
         * extern const GUID __declspec(selectany) \
         *  MOUNTDEV_MOUNTED_DEVICE_GUID = { 0x53f5630d, 0xb6bf, 0x11d0, { \
         *  0x94, 0xf2, 0x00, 0xa0, 0xc9, 0x1e, 0xfb, 0x8b } };
         * So we allow "extern" + "initializer" if "const" is
         * around. *)
        (* sm: As I read the ISO spec, in particular 6.9.2 and 6.7.8,
         * "extern int foo = 3" is exactly equivalent to "int foo = 3";
         * that is, if you put an initializer, then it is a definition,
         * and "extern" is redundantly giving the name external linkage.
         * gcc emits a warning, I guess because it is contrary to
         * usual practice, but I think CIL warnings should be about
         * semantic rather than stylistic issues, so I see no reason to
         * even emit a warning. *)
        if vi.vstorage = Extern then
          vi.vstorage <- NoStorage;     (* equivalent and canonical *)

        H.add alreadyDefined vi.vname (CurrentLoc.get ());
        IH.remove mustTurnIntoDef vi.vid;
        cabsPushGlobal (GVar(vi, {init = init}, CurrentLoc.get ()));
        vi
      end else begin
        if not (isFunctionType vi.vtype) &&
           (vi.vstorage = NoStorage || vi.vstorage = Static)
           && not (IH.mem mustTurnIntoDef vi.vid) then
          begin
            IH.add mustTurnIntoDef vi.vid true
          end;
        if not alreadyInEnv then begin (* Only one declaration *)
          (* If it has function type it is a prototype *)
          (* NB: We add the formal prms in the env*)
          if isFunctionType vi.vtype then begin
            if not vi.vdefined then
              setFormalsDecl vi vi.vtype;
            let spec =
              match logic_spec with
              | None -> empty_funspec ()
              | Some (spec,loc) ->
                begin
                  CurrentLoc.set loc;
                  try
                    (* it can not have old behavior names, since this is the
                       first time we see the declaration.
                    *)
                    Ltyping.funspec [] vi None vi.vtype spec
                  with LogicTypeError ((source,_),msg) ->
                    Kernel.warning ~wkey:Kernel.wkey_annot_error ~source
                      "%s. Ignoring specification of function %s" msg vi.vname;
                    empty_funspec ()
                end
            in
            cabsPushGlobal (GFunDecl (spec, vi, CurrentLoc.get ()));
          end
          else
            cabsPushGlobal (GVarDecl (vi, CurrentLoc.get ()));
          vi
        end else begin
          Kernel.debug ~dkey:Kernel.dkey_typing_global
            " already in env %s" vi.vname;
          (match logic_spec with
           | None -> ()
           | Some (spec,loc) ->
             CurrentLoc.set loc;
             let merge_spec = function
               | GFunDecl(old_spec, _, oldloc) ->
                 let behaviors =
                   List.map (fun b -> b.b_name) old_spec.spec_behavior
                 in
                 let spec =
                   try
                     Ltyping.funspec behaviors vi None vi.vtype spec
                   with LogicTypeError ((source,_),msg) ->
                     Kernel.warning ~wkey:Kernel.wkey_annot_error ~source
                       "%s. Ignoring specification of function %s"
                       msg vi.vname;
                     empty_funspec ()
                 in
                 Logic_utils.merge_funspec ~oldloc old_spec spec
               | _ -> assert false
             in
             update_fundec_in_theFile vi merge_spec
          );
          vi
        end
      end
    end
    (*
      ignore (E.log "Env after processing global %s is:@\n%t@\n"
      n docEnv);
      ignore (E.log "Alpha after processing global %s is:@\n%t@\n"
      n docAlphaTable)
    *)

(* it can happen that the variable to be initialized appears in the
   auxiliary statements that contribute to its initialization (and thus
   are meant to occur before the corresponding Local_init statement. In
   that case, this function creates an auxiliary variable that is never
   defined as a placeholder.
   Note that in any case, if the execution attempts to evaluate
   the variable (either original or placeholder), the behavior is undefined.
   There are some cases where the evaluation will succeed, though, e.g. with
   size_t x = sizeof(x) > 6 ? sizeof(x): 6;
*)
and cleanup_autoreference vi chunk =
  let temp = ref None in
  let calls = ref [] in
  let extract_calls () =
    let res = !calls in
    calls := [];
    res
  in
  let vis =
    object(self)
      inherit Cil.nopCilVisitor

      method! vinst = function
        | Call _ | Local_init(_,ConsInit _,_) ->
          calls := ref (Option.get self#current_stmt) :: !calls;
          DoChildren
        | _ -> DoChildren

      method! vvrbl v =
        if Cil_datatype.Varinfo.equal v vi then begin
          match !temp with
          | Some v' -> ChangeTo v'
          | None ->
            let ghost = v.vghost in
            let loc = v.vdecl in
            let v' =
              newTempVar ~ghost loc (vi.vname ^ " initialization") true vi.vtype
            in
            temp := Some v';
            ChangeTo v'
        end else SkipChildren
    end
  in
  let transform_lvals l = List.map (visitCilLval vis) l in
  let treat_one (s, m, w, r, _) =
    let s' = visitCilStmt vis s in
    let m' = transform_lvals m in
    let w' = transform_lvals w in
    let r' = transform_lvals r in
    let c' = extract_calls () in
    (s', m', w', r', c')
  in
  let stmts = List.map treat_one chunk.stmts in
  match !temp with
  | None -> chunk
  | Some v -> local_var_chunk { chunk with stmts } v

(* Must catch the Static local variables. Make them global *)
and createLocal ghost ((_, sto, _, _) as specs)
    ((((n, ndt, a, cloc) : Cabs.name),
      (inite: Cabs.init_expression)) as init_name)
  : chunk =
  let loc = convLoc cloc in
  (* Check if we are declaring a function *)
  let rec isProto (dt: decl_type) : bool =
    match dt with
    | PROTO (JUSTBASE, _,_, _) -> true
    | PROTO (x, _,_, _) -> isProto x
    | PARENTYPE (_, x, _) -> isProto x
    | ARRAY (x, _, _) -> isProto x
    | PTR (_, x) -> isProto x
    | _ -> false
  in
  match ndt with
  (* Maybe we have a function prototype in local scope. Make it global. We
   * do this even if the storage is Static *)
  | _ when isProto ndt ->
    let vi = createGlobal ghost None specs init_name in
    (* Add it to the environment to shadow previous decls *)
    addLocalToEnv ghost n (EnvVar vi);
    LocalFuncHook.apply vi;
    empty

  | _ when sto = Static ->
    Kernel.debug ~dkey:Kernel.dkey_typing_global
      "createGlobal (local static): %s" n;
    (* Now alpha convert it to make sure that it does not conflict with
     * existing globals or locals from this function. *)
    let full_name =
      (* Mangled symbols (that is, starting with '_Z') are unique by
         construction. No need to add current function name as prefix. *)
      if Extlib.string_prefix ~strict:true "_Z" n
      then n
      else !currentFunctionFDEC.svar.vname ^ "_" ^ n
    in
    let newname, _  = newAlphaName ghost true "" full_name in
    (* Make it global  *)
    let vi = makeVarInfoCabs ~ghost ~isformal:false
        ~isglobal:true
        loc specs (n, ndt, a) in
    vi.vname <- newname;
    let attrs = Cil.addAttribute (Attr (fc_local_static,[])) vi.vattr in
    vi.vattr <- fc_stdlib_attribute attrs;

    (* However, we have a problem if a real global appears later with the
     * name that we have happened to choose for this one. Remember these names
     * for later. *)
    H.add staticLocals vi.vname vi;
    (* Add it to the environment as a local so that the name goes out of
     * scope properly *)
    addLocalToEnv ghost n (EnvVar vi);

    (* Maybe this is an array whose length depends on something with local
       scope, e.g. "static char device[ sizeof(local) ]".
       Const-fold the type to fix this. *)
    Cil.update_var_type vi (constFoldType vi.vtype);

    let init : init option =
      if inite = Cabs.NO_INIT then
        None
      else begin
        let se, ie', et, _ = doInitializer (ghost_local_env ghost) vi inite in
        (* Maybe we now have a better type?  Use the type of the
         * initializer only if it really differs from the type of
         * the variable. *)
        if unrollType vi.vtype != unrollType et then
          Cil.update_var_type vi et;
        if isNotEmpty se then
          Kernel.error ~once:true ~current:true "global static initializer";
        (* Check that no locals are referred by the initializer *)
        check_no_locals_in_initializer ie';
        (* Maybe the initializer refers to the function itself.
           Push a prototype for the function, just in case. *)
        cabsPushGlobal
          (GFunDecl (empty_funspec (), !currentFunctionFDEC.svar,
                     CurrentLoc.get ()));
        Cil.setFormalsDecl
          !currentFunctionFDEC.svar !currentFunctionFDEC.svar.vtype;
        Some ie'
      end
    in
    cabsPushGlobal (GVar(vi, {init = init}, CurrentLoc.get ()));
    static_var_chunk empty vi

  (* Maybe we have an extern declaration. Make it a global *)
  | _ when sto = Extern ->
    let vi = createGlobal ghost None specs init_name in
    (* Add it to the local environment to ensure that it shadows previous
     * local variables *)
    addLocalToEnv ghost n (EnvVar vi);
    empty

  | _ ->
    (* Make a variable of potentially variable size. If se0 <> empty then
     * it is a variable size variable *)
    let vi,se0,len,isvarsize =
      makeVarSizeVarInfo ghost loc specs (n, ndt, a) in

    let vi = alphaConvertVarAndAddToEnv true vi in        (* Replace vi *)
    if isvarsize then begin
      let free = vla_free_fun () in
      let destructor = AStr free.vname in
      let attr = Attr (frama_c_destructor, [destructor]) in
      vi.vdefined <- true;
      vi.vattr <- Cil.addAttribute attr vi.vattr;
    end;
    let se1 =
      if isvarsize then begin (* Variable-sized array *)
        (* Make a local variable to keep the length *)
        let savelen =
          makeVarInfoCabs
            ~ghost
            ~isformal:false
            ~isglobal:false
            loc
            (theMachine.typeOfSizeOf, NoStorage, false, [])
            ("__lengthof_" ^ vi.vname,JUSTBASE, [])
        in
        (* Register it *)
        let savelen = alphaConvertVarAndAddToEnv true savelen in
        let se0 = local_var_chunk se0 savelen in
        (* Compute the allocation size *)
        let elt_size = new_exp ~loc (SizeOf (Cil.typeOf_pointed vi.vtype)) in
        let alloca_size =
          new_exp ~loc
            (BinOp(Mult,
                   elt_size,
                   new_exp ~loc (Lval (var savelen)),
                   theMachine.typeOfSizeOf))
        in
        (* Register the length *)
        IH.add varSizeArrays vi.vid alloca_size;
        (* There can be no initializer for this *)
        if inite != Cabs.NO_INIT then
          Kernel.error ~once:true ~current:true
            "Variable-sized array cannot have initializer";
        let se0 =
          (* add an assertion to ensure the given size is correctly bound:
             assert alloca_bounds: 0 < elt_size * array_size <= max_bounds
          *)
          (se0 +++ (
              let castloc = CurrentLoc.get () in
              let talloca_size =
                let size = Logic_utils.expr_to_term ~coerce:true elt_size in
                let tlen = Logic_utils.expr_to_term ~coerce:true len in
                Logic_const.term (TBinOp (Mult,size,tlen)) Linteger
              in
              let pos_size =
                let zero =  Logic_const.tinteger ~loc:castloc 0 in
                Logic_const.prel ~loc:castloc (Rlt, zero, talloca_size)
              in
              let max_size =
                let szTo = Cil.bitsSizeOf theMachine.typeOfSizeOf in
                let max_bound =  Logic_const.tint ~loc:castloc (Cil.max_unsigned_number szTo) in
                Logic_const.prel ~loc:castloc (Rle, talloca_size, max_bound)
              in
              let alloca_bounds = Logic_const.pand ~loc:castloc (pos_size, max_size) in
              let alloca_bounds =
                { alloca_bounds with pred_name = ["alloca_bounds"] }
              in
              let alloca_bounds =
                Logic_const.toplevel_predicate alloca_bounds
              in
              let annot =
                Logic_const.new_code_annotation (AAssert ([], alloca_bounds))
              in
              (mkStmtOneInstr ~ghost ~valid_sid
                 (Code_annot (annot, castloc)),
               [],[],[])))
        in
        let setlen =  se0 +++
                      (mkStmtOneInstr ~ghost ~valid_sid
                         (Set(var savelen, makeCast ~e:len ~newt:savelen.vtype,
                              CurrentLoc.get ())),
                       [],[],[])
        in
        (* Initialize the variable *)
        let alloca: varinfo = vla_alloc_fun () in
        if Kernel.DoCollapseCallCast.get () then
          (* do it in one step *)
          setlen +++
          (mkStmtOneInstr ~ghost ~valid_sid
             (Local_init (vi, ConsInit(alloca,[ alloca_size ],Plain_func),loc)),
           [],[var vi],[])
        else begin
          (* do it in two *)
          let rt, _, _, _ = splitFunctionType alloca.vtype in
          let tmp =
            newTempVar ~ghost loc
              (Format.asprintf "alloca(%a)" Cil_printer.pp_exp alloca_size)
              false rt
          in
          tmp.vdefined <- true;
          (local_var_chunk setlen tmp)
          +++ (mkStmtOneInstr ~ghost ~valid_sid
                 (Local_init
                    (tmp,ConsInit(alloca,[alloca_size],Plain_func),loc)),
               [],[],[])
          +++ (mkStmtOneInstr ~ghost ~valid_sid
                 (Local_init
                    (vi,AssignInit
                       (SingleInit
                          (makeCast ~e:(new_exp ~loc (Lval(var tmp)))
                             ~newt:vi.vtype)),
                     CurrentLoc.get ())),
               [],[var vi],[var tmp])
        end
      end else empty
    in
    let se1 = local_var_chunk se1 vi in
    if inite = Cabs.NO_INIT then
      se1 (* skipChunk *)
    else begin
      (* TODO: if vi occurs in se4, this is not a real initialization. *)
      vi.vdefined <- true;
      let se4, ie', et, r = doInitializer (ghost_local_env ghost) vi inite in
      let se4 = cleanup_autoreference vi se4 in
      (* Fix the length *)
      (match vi.vtype, ie', et with
       (* We have a length now *)
       | TArray(_,None, _), _, TArray(_, Some _, _) ->
         Cil.update_var_type vi et
       (* Initializing a local array *)
       | TArray(TInt((IChar|IUChar|ISChar), _) as bt, None, a),
         SingleInit({enode = Const(CStr s);eloc=loc}), _ ->
         Cil.update_var_type vi
           (TArray(bt,
                   Some (integer ~loc (String.length s + 1)),
                   a))
       | _, _, _ -> ());

      (* Now create assignments instead of the initialization *)
      (se1 @@ (se4, ghost))
      @@
      (i2c
         (Cil.mkStmtOneInstr
            ~ghost ~valid_sid (Local_init(vi,AssignInit ie',loc)),
          [], [(Var vi,NoOffset)], Cil_datatype.Lval.Set.elements r), ghost)
    end

and doAliasFun ghost vtype (thisname:string) (othername:string)
    (sname:single_name) (loc: cabsloc) : unit =
  (* This prototype declares that name is an alias for
     othername, which must be defined in this file *)
  (*   E.log "%s is alias for %s at %a\n" thisname othername  *)
  (*     Cil_printer.pp_location !currentLoc; *)
  let rt, formals, isva, _ = splitFunctionType vtype in
  if isva then Kernel.error ~once:true ~current:true "alias unsupported with varargs";
  let args = List.map
      (fun (n,_,_) -> { expr_loc = loc; expr_node = Cabs.VARIABLE n})
      (argsToList formals) in
  let call = Cabs.CALL ({expr_loc = loc; expr_node = Cabs.VARIABLE othername}, args,[])
  in
  let stmt = {stmt_ghost = false;
              stmt_node = if isVoidType rt then
                  Cabs.COMPUTATION({expr_loc = loc; expr_node = call}, loc)
                else Cabs.RETURN({expr_loc = loc; expr_node = call}, loc)}
  in
  let body = { Cabs.blabels = []; Cabs.battrs = []; Cabs.bstmts = [stmt] } in
  let fdef = Cabs.FUNDEF (None, sname, body, loc, loc) in
  ignore (doDecl empty_local_env true fdef);
  (* get the new function *)
  let v,_ =
    try lookupGlobalVar ghost thisname
    with Not_found -> abort_context "error in doDecl"
  in
  v.vattr <- dropAttribute "alias" v.vattr


(* Do one declaration *)
and doDecl local_env (isglobal: bool) : Cabs.definition -> chunk = function
  | Cabs.DECDEF (logic_spec, (s, nl), loc) ->
    CurrentLoc.set (convLoc loc);
    (* Do the specifiers exactly once *)
    let sugg =
      match nl with
      | [] -> ""
      | ((n, _, _, _), _) :: _ -> n
    in
    let ghost = local_env.is_ghost in
    let spec_res = doSpecList ghost sugg s in
    (* Do all the variables and concatenate the resulting statements *)
    let doOneDeclarator (acc: chunk) (name: init_name) =
      let (n,ndt,a,l),_ = name in
      if isglobal then begin
        let bt,_,_,attrs = spec_res in
        let vtype, nattr =
          doType local_env.is_ghost false
            (AttrName false) bt (Cabs.PARENTYPE(attrs, ndt, a)) in
        (match filterAttributes "alias" nattr with
         | [] -> (* ordinary prototype. *)
           ignore (createGlobal local_env.is_ghost logic_spec spec_res name)
         (*  E.log "%s is not aliased\n" name *)
         | [Attr("alias", [AStr othername])] ->
           if not (isFunctionType vtype) || local_env.is_ghost then begin
             Kernel.warning ~current:true
               "%a: CIL only supports attribute((alias)) for C functions."
               Cil_printer.pp_location (CurrentLoc.get ());
             ignore (createGlobal ghost logic_spec spec_res name)
           end else
             doAliasFun ghost vtype n othername (s, (n,ndt,a,l)) loc
         | _ ->
           Kernel.error ~once:true ~current:true
             "Bad alias attribute at %a" Cil_printer.pp_location (CurrentLoc.get()));
        acc
      end else
        acc @@ (createLocal ghost spec_res name, ghost)
    in
    let res = List.fold_left doOneDeclarator empty nl in
    if isglobal then res
    else begin
      match logic_spec with
      | None -> res
      | Some (spec,loc) ->
        let loc' = convLoc loc in
        begin
          try
            let spec =
              Ltyping.code_annot loc' local_env.known_behaviors
                (Ctype !currentReturnType) (Logic_ptree.AStmtSpec ([],spec))
            in
            append_chunk_to_annot ~ghost
              (s2c
                 (mkStmtOneInstr ~ghost ~valid_sid (Code_annot (spec,loc'))))
              res
          with LogicTypeError ((source,_),msg) ->
            Kernel.warning ~wkey:Kernel.wkey_annot_error ~source
              "%s. Ignoring code annotation" msg;
            res
        end
    end
  | Cabs.TYPEDEF (ng, loc) ->
    CurrentLoc.set (convLoc loc); doTypedef local_env.is_ghost ng; empty

  | Cabs.ONLYTYPEDEF (s, loc) ->
    CurrentLoc.set (convLoc loc); doOnlyTypedef local_env.is_ghost s; empty

  | Cabs.GLOBASM (s,loc) when isglobal ->
    CurrentLoc.set (convLoc loc);
    cabsPushGlobal (GAsm (s, CurrentLoc.get ())); empty

  | Cabs.PRAGMA (a, loc) when isglobal -> begin
      CurrentLoc.set (convLoc loc);
      match doAttr local_env.is_ghost ("dummy", [a]) with
      | [Attr("dummy", [a'])] ->
        let a'' =
          match a' with
          | ACons (s, args) ->
            process_align_pragma s args;
            process_stdlib_pragma s args >>?
            process_pack_pragma
          | _ -> (* Cil.fatal "Unexpected attribute in #pragma" *)
            Kernel.warning ~current:true "Unexpected attribute in #pragma";
            Some (Attr ("", [a']))
        in
        Option.iter
          (fun a'' ->
             cabsPushGlobal (GPragma (a'', CurrentLoc.get ())))
          a'';
        empty

      | _ -> Kernel.fatal ~current:true "Too many attributes in pragma"
    end

  | Cabs.STATIC_ASSERT (e, s, loc) -> begin
      CurrentLoc.set (convLoc loc);
      let (_, _, cond_exp, _) = doExp local_env CConst e ADrop in
      begin
        match Cil.constFoldToInt ~machdep:true cond_exp with
        | Some i ->
          if Integer.(equal i zero) then
            Kernel.error ~current:true "static assertion failed%s%s@."
              (if s <> "" then ": " else "") s
        | None ->
          Kernel.error ~current:true
            "failed to evaluate constant expression in static assertion:@ \
             @[%a@]"
            Cprint.print_expression e
      end;
      (* _Static_assert is not stored in the Cil AST *)
      empty
    end

  | Cabs.FUNDEF (spec,((specs,(n,dt,a, _)) : Cabs.single_name),
                 (body : Cabs.block), loc1, loc2) when isglobal ->
    begin
      let ghost = local_env.is_ghost in
      let idloc = loc1 in
      let funloc = fst loc1, snd loc2 in
      let endloc = loc2 in
      Kernel.debug ~dkey:Kernel.dkey_typing_global
        "Definition of %s at %a\n" n Cil_printer.pp_location idloc;
      CurrentLoc.set idloc;
      FuncLocs.add_loc ?spec loc1 endloc n;
      IH.clear callTempVars;

      (* Make the fundec right away, and we'll populate it later. We
       * need this throughout the code to create temporaries. *)
      currentFunctionFDEC :=
        { svar     = makeGlobalVar ~temp:false ~ghost n voidType;
          slocals  = []; (* For now we'll put here both the locals and
                          * the formals. Then "endFunction" will
                          * separate them *)
          sformals = []; (* Not final yet *)
          smaxid   = 0;
          sbody    = dummy_function.sbody; (* Not final yet *)
          smaxstmtid = None;
          sallstmts = [];
          sspec = empty_funspec ()
        };
      !currentFunctionFDEC.svar.vdecl <- idloc;

      (* Setup the environment. Add the formals to the locals. Maybe
       * they need alpha-conv  *)
      enterScope ();  (* Start the scope *)
      ignore (Cabsvisit.visitCabsBlock (new gatherLabelsClass) body);
      CurrentLoc.set idloc;
      IH.clear varSizeArrays;

      (* Enter all the function's labels into the alpha conversion table *)
      ignore (Cabsvisit.visitCabsBlock (new registerLabelsVisitor) body);
      CurrentLoc.set idloc;

      (* Do not process transparent unions in function definitions.
       * We'll do it later *)
      transparentUnionArgs := [];

      let bt,sto,inl,attrs = doSpecList local_env.is_ghost n specs in
      !currentFunctionFDEC.svar.vinline <- inl;
      let ftyp, funattr =
        doType local_env.is_ghost false
          (AttrName false) bt (Cabs.PARENTYPE(attrs, dt, a)) in
      if hasAttribute "thread" funattr then begin
        let wkey = Kernel.wkey_inconsistent_specifier in
        let source = fst funloc in
        Kernel.warning ~wkey ~source "only objects can be thread-local"
      end;
      (* Format.printf "Attrs are %a@." d_attrlist funattr; *)
      Cil.update_var_type !currentFunctionFDEC.svar ftyp;
      !currentFunctionFDEC.svar.vattr <- funattr;
      !currentFunctionFDEC.svar.vstorage <- sto;
      let vi,has_decl =
        makeGlobalVarinfo true !currentFunctionFDEC.svar in
      (* Add the function itself to the environment. Add it before
       * you do the body because the function might be recursive. Add
       * it also before you add the formals to the environment
       * because there might be a formal with the same name as the
       * function and we want it to take precedence. *)
      (* Make a variable out of it and put it in the environment *)
      !currentFunctionFDEC.svar <- vi;

      (* If it is extern inline then we add it to the global
       * environment for the original name as well. This will ensure
       * that all uses of this function will refer to the renamed
       * function *)
      addGlobalToEnv ghost n (EnvVar !currentFunctionFDEC.svar);
      if H.mem alreadyDefined !currentFunctionFDEC.svar.vname then
        Kernel.error ~once:true ~current:true "There is a definition already for %s" n;

      H.add alreadyDefined !currentFunctionFDEC.svar.vname idloc;


          (*
            ignore (E.log "makefunvar:%s@\n type=%a@\n vattr=%a@\n"
            n Cil_datatype.Typ.pretty thisFunctionVI.vtype
            d_attrlist thisFunctionVI.vattr);
          *)

      (* makeGlobalVarinfo might have changed the type of the function
       * (when combining it with the type of the prototype). So get the
       * type only now. *)

      (**** Process the TYPE and the FORMALS ***)
      let _ =
        let (returnType, formals_t, isvararg, funta) =
          splitFunctionTypeVI !currentFunctionFDEC.svar
        in
        (* Record the returnType for doStatement *)
        currentReturnType   := returnType;


        (* Create the formals and add them to the environment. *)
        (* sfg: extract tsets for the formals from dt *)
        let cnt = ref 0 in
        let doFormal (loc : location) ((fn, ft, fa) as fd) =
          let ghost = ghost || isGhostFormalVarDecl fd in
          let f = makeVarinfo ~ghost ~temp:false ~loc false true fn ft in
          f.vattr <- fa;
          if f.vname = "" then begin
            f.vname <- "__x" ^ (string_of_int !cnt);
            incr cnt;
            f.vattr <- addAttribute anonymous_attribute f.vattr;
          end;
          alphaConvertVarAndAddToEnv true f
        in
        let rec doFormals fl' ll' =
          begin
            match (fl', ll') with
            | [], _ -> []

            | fl, [] -> (* no more locs available *)
              List.map (doFormal (CurrentLoc.get ())) fl

            | f::fl, (_,(_,_,_,l))::ll ->
              (* sfg: these lets seem to be necessary to
               *  force the right order of evaluation *)
              let f' = doFormal (convLoc l) f in
              let fl' = doFormals fl ll in
              f' :: fl'
          end
        in
        let fmlocs = (match dt with PROTO(_, fml, _, _) -> fml | _ -> []) in
        let formals = doFormals (argsToList formals_t) fmlocs in
        (* in case of formals referred to in types of others, doType has
           put dummy varinfos. We need to fix them now that we have proper
           bindings.
           TODO: completely refactor the way formals' typechecking is done.
        *)
        let () = fixFormalsType formals in

        (* Recreate the type based on the formals. *)
        let ftype = TFun(returnType,
                         Some (List.map (fun f ->
                             (f.vname,
                              f.vtype,
                              f.vattr)) formals),
                         isvararg, funta) in

        (*log "Funtype of %s: %a\n" n Cil_datatype.Typ.pretty ftype;*)

        (* Now fix the names of the formals in the type of the function
         * as well *)
        Cil.update_var_type !currentFunctionFDEC.svar ftype;
        !currentFunctionFDEC.sformals <- formals;
        (* we will revisit the spec for the declaration in order
           to change the formals according to the new variables.
        *)
        if has_decl then begin
          try
            Hashtbl.add alpha_renaming
              vi.vid
              (Cil.create_alpha_renaming
                 (Cil.getFormalsDecl vi) formals)
          with Not_found ->
            (* the declaration comes from an
               implicit prototype. We do not have
               any spec anyway. However, we will have a declaration
               in the resulting AST, to which we must attach some
               formals.
            *)
            Cil.unsafeSetFormalsDecl vi formals
        end;
      in
      (* Now change the type of transparent union args back to what it
       * was so that the body type checks. We must do it this late
       * because makeGlobalVarinfo from above might choke if we give
       * the function a type containing transparent unions  *)
      let _ =
        let rec fixbackFormals (idx: int) (args: varinfo list) : unit=
          match args with
          | [] -> ()
          | a :: args' ->
            (* Fix the type back to a transparent union type *)
            (try
               let origtype = List.assq idx !transparentUnionArgs in
               Cil.update_var_type a origtype;
             with Not_found -> ());
            fixbackFormals (idx + 1) args'
        in
        fixbackFormals 0 !currentFunctionFDEC.sformals;
        transparentUnionArgs := [];
      in
      let behaviors = find_existing_behaviors !currentFunctionFDEC.svar in
      (******* Now do the spec *******)
      begin
        match spec with
        | Some (spec,loc) ->
          CurrentLoc.set loc;
          (try
             !currentFunctionFDEC.sspec <-
               Ltyping.funspec behaviors
                 !currentFunctionFDEC.svar
                 (Some !currentFunctionFDEC.sformals)
                 !currentFunctionFDEC.svar.vtype spec
           with LogicTypeError ((source,_),msg) ->
             Kernel.warning ~wkey:Kernel.wkey_annot_error ~source
               "%s. Ignoring logic specification of function %s"
               msg !currentFunctionFDEC.svar.vname)
        | None -> ()
      end;
      (* Merge pre-existing spec if needed. *)
      if has_decl then begin
        let merge_spec = function
          | GFunDecl(old_spec,_,oldloc) as g ->
            if not (Cil.is_empty_funspec old_spec) then begin
              rename_spec g;
              Logic_utils.merge_funspec ~oldloc
                !currentFunctionFDEC.sspec old_spec;
              Logic_utils.clear_funspec old_spec;
            end
          | _ -> assert false
        in
        update_fundec_in_theFile !currentFunctionFDEC.svar merge_spec
      end;
      (********** Now do the BODY *************)
      let _ =
        let stmts =
          doBody
            { empty_local_env with
              known_behaviors =
                (List.map (fun x -> x.b_name)
                   !currentFunctionFDEC.sspec.spec_behavior)
                @ behaviors;
              is_ghost = local_env.is_ghost
            }
            body
        in
        (* Finish everything *)
        exitScope ();
        (* Now fill in the computed goto statement with cases. Do this
         * before mkFunctionbody which resolves the gotos *)
        (match !gotoTargetData with
         | Some (_switchv, switch) ->
           let switche, loc =
             match switch.skind with
             | Switch (switche, _, _, l) -> switche, l
             | _ ->
               Kernel.fatal ~current:true
                 "the computed goto statement not a switch"
           in
           (* Build a default chunk that segfaults *)
           let default =
             defaultChunk ~ghost
               loc
               (i2c (mkStmtOneInstr ~ghost:local_env.is_ghost ~valid_sid
                       (Set ((Mem (makeCast ~e:(integer ~loc 0)
                                     ~newt:intPtrType),
                              NoOffset),
                             integer ~loc 0, loc)),[],[],[]))
           in
           let bodychunk = ref default in
           H.iter
             (fun lname laddr ->
                bodychunk :=
                  caseRangeChunk ~ghost
                    [integer ~loc laddr] loc
                    (gotoChunk ~ghost lname loc @@ (!bodychunk, ghost)))
             gotoTargetHash;
           (* Now recreate the switch *)
           let newswitch = switchChunk ~ghost switche !bodychunk loc in
           (* We must still share the old switch statement since we
            * have already inserted the goto's *)
           let newswitchkind =
             match newswitch.stmts with
             | [ s, _, _,_,_] when newswitch.cases == []-> s.skind
             | _ ->
               Kernel.fatal ~current:true
                 "Unexpected result from switchChunk"
           in
           switch.skind <- newswitchkind

         | None -> ());
        (* Now finish the body and store it *)
        let body = mkFunctionBody ~ghost stmts in
        !currentFunctionFDEC.sbody <- body;
        (* Reset the global parameters *)
        gotoTargetData := None;
        H.clear gotoTargetHash;
        gotoTargetNextAddr := 0;
      in
      !currentFunctionFDEC.slocals <- (List.rev !currentFunctionFDEC.slocals);
      setMaxId !currentFunctionFDEC;

      (* Now go over the types of the formals and pull out the formals
       * with transparent union type. Replace them with some shadow
       * parameters and then add assignments  *)
      let _ =
        let newformals, newbody =
          List.fold_right (* So that the formals come out in order *)
            (fun f (accform, accbody) ->
               match isTransparentUnion f.vtype with
               | None -> (f :: accform, accbody)
               | Some fstfield ->
                 (* A new shadow to be placed in the formals. Use
                  * makeTempVar to update smaxid and all others but
                    do not insert as a local variable of [f]. *)
                 let loc = CurrentLoc.get () in
                 let shadow =
                   makeTempVar
                     !currentFunctionFDEC ~insert:false
                     fstfield.ftype
                 in
                 (* Now replace it with the current formal. *)
                 (shadow :: accform,
                  mkStmtOneInstr ~ghost:local_env.is_ghost ~valid_sid
                    (Set ((Var f, Field(fstfield, NoOffset)),
                          new_exp ~loc (Lval (var shadow)), loc))
                  :: accbody))
            !currentFunctionFDEC.sformals
            ([], !currentFunctionFDEC.sbody.bstmts)
        in
        !currentFunctionFDEC.sbody.bstmts <- newbody;
        (* To make sure sharing with the type is proper *)
        setFormals !currentFunctionFDEC newformals;
      in

      (* Now see whether we can fall through to the end of the function *)
      if blockFallsThrough !currentFunctionFDEC.sbody then begin
        let loc = endloc in
        let protect_return,retval =
          (* Guard the [return] instructions we add with an
             [\assert \false]*)
          let pfalse = Logic_const.unamed ~loc Pfalse in
          let pfalse = { pfalse with pred_name = ["missing_return"] } in
          let pfalse = Logic_const.toplevel_predicate pfalse in
          let assert_false () =
            let annot =
              Logic_const.new_code_annotation (AAssert ([], pfalse))
            in
            Cil.mkStmt ~ghost ~valid_sid (Instr(Code_annot(annot,loc)))
          in
          match unrollType !currentReturnType with
          | TVoid _ -> [], None
          | (TInt _ | TEnum _ | TFloat _ | TPtr _) as rt ->
            let res = Some (makeCastT ~e:(zero ~loc) ~oldt:intType ~newt:rt) in
            if !currentFunctionFDEC.svar.vname = "main" then
              [],res
            else begin
              Kernel.warning ~current:true ~wkey:Kernel.wkey_cert_msc_37
                "Body of function %s falls-through. \
                 Adding a return statement"
                !currentFunctionFDEC.svar.vname;
              [assert_false ()], res
            end
          | rt ->
            (* 0 is not an admissible value for the return type.
               On the other hand, *( T* )0 is. We're not supposed
               to get there anyway. *)
            let null_ptr =
              makeCastT ~e:(zero ~loc) ~oldt:intType ~newt:(TPtr(rt,[]))
            in
            let res =
              Some (new_exp ~loc (Lval (mkMem ~addr:null_ptr ~off:NoOffset)))
            in
            Kernel.warning ~current:true ~wkey:Kernel.wkey_cert_msc_37
              "Body of function %s falls-through. \
               Adding a return statement"
              !currentFunctionFDEC.svar.vname;
            [assert_false ()], res
        in
        if not (hasAttribute "noreturn" !currentFunctionFDEC.svar.vattr)
        then
          !currentFunctionFDEC.sbody.bstmts <-
            !currentFunctionFDEC.sbody.bstmts
            @ protect_return @
            [mkStmt ~ghost ~valid_sid (Return(retval, endloc))]
      end;

      (* ignore (E.log "The env after finishing the body of %s:\n%t\n"
         n docEnv); *)
      cabsPushGlobal (GFun (!currentFunctionFDEC, funloc));
      currentFunctionFDEC := dummy_function;
      empty
    end (* FUNDEF *)

  | LINKAGE (n, loc, dl) ->
    CurrentLoc.set (convLoc loc);
    if n <> "C" then
      Kernel.warning ~current:true
        "Encountered linkage specification \"%s\"" n;
    if not isglobal then
      Kernel.error ~once:true ~current:true
        "Encountered linkage specification in local scope";
    (* For now drop the linkage on the floor !!! *)
    List.iter
      (fun d ->
         let s = doDecl local_env isglobal d in
         if isNotEmpty s then
           abort_context "doDecl returns non-empty statement for global")
      dl;
    empty

  | Cabs.GLOBANNOT (decl) when isglobal ->
    begin
      List.iter
        (fun decl  ->
           let loc = convLoc decl.Logic_ptree.decl_loc in
           CurrentLoc.set loc;
           try
             let tdecl = Ltyping.annot decl in
             let attr = fc_stdlib_attribute [] in
             let tdecl =
               List.fold_left
                 (Extlib.swap Logic_utils.add_attribute_glob_annot) tdecl attr
             in
             cabsPushGlobal (GAnnot(tdecl,CurrentLoc.get ()))
           with LogicTypeError ((source,_),msg) ->
             Kernel.warning
               ~wkey:Kernel.wkey_annot_error ~source
               "%s. Ignoring global annotation" msg)
        decl;
    end;
    empty

  | Cabs.GLOBANNOT _ | Cabs.PRAGMA _ | Cabs.GLOBASM _ | Cabs.FUNDEF _ ->
    Kernel.fatal ~current:true "this form of declaration must be global"

and doTypedef ghost ((specs, nl): Cabs.name_group) =
  (* Do the specifiers exactly once *)
  if !scopes <> [] then
    Kernel.warning
      ~once:true ~current:true ~wkey:Kernel.wkey_parser_unsupported
      "block-level typedefs currently unsupported;@ \
       trying to convert it to a global-level typedef.@ \
       Note that this may lead to incoherent error messages.";
  let bt, sto, inl, attrs = doSpecList ghost (suggestAnonName nl) specs in
  if sto <> NoStorage || inl then
    Kernel.error ~once:true ~current:true
      "Storage or inline specifier not allowed in typedef";
  let createTypedef ((n,ndt,a,_) : Cabs.name) =
    (*    E.s (error "doTypeDef") *)
    let newTyp, tattr =
      doType ghost false AttrType bt (Cabs.PARENTYPE(attrs, ndt, a))  in
    checkTypedefSize n newTyp;
    let tattr = fc_stdlib_attribute tattr in
    let newTyp' = cabsTypeAddAttributes tattr newTyp in
    checkRestrictQualifierDeep newTyp';
    let env = if ghost then ghost_env else env in
    if H.mem typedefs n && Datatype.String.Hashtbl.mem env n then
      (* check if type redefinition is allowed (C11 only);
         in all cases, do not create a new type.
         TODO: if local typedef redefinitions are to be supported, then the new type
         must be created if the definition is syntactically valid. *)
      begin
        if !scopes <> [] then
          Kernel.failure ~current:true
            "redefinition of a typedef in a non-global scope is currently unsupported";
        let typeinfo = H.find typedefs n in
        let _, oldloc = lookupType ghost "type" n in
        if areCompatibleTypes typeinfo.ttype newTyp' then
          begin
            let error_conflicting_types () =
              Kernel.error ~current:true
                "redefinition of type '%s' in the same scope with conflicting type.@ \
                 Previous declaration was at %a"
                n Cil_datatype.Location.pretty oldloc
            in
            let error_c11_redefinition () =
              Kernel.error ~current:true
                "redefinition of type '%s' in the same scope is only allowed in C11 \
                 (option %s).@ Previous declaration was at %a" n Kernel.C11.name
                Cil_datatype.Location.pretty oldloc
            in
            (* Tested with GCC+Clang: redefinition of compatible types in same scope:
               - enums are NOT allowed;
               - composite types are allowed only if the composite type itself is
                 not redefined (complex rules; with some extra tag checking performed
                 in compatibleTypesp, we use tags here to detect redefinitions,
                 which are invalid)
               - redefinition via a typedef of a struct/union/enum IS allowed;
               - other types are allowed. *)
            if declared_in_current_scope ~ghost n then
              begin
                match newTyp' with (* do NOT unroll type here,
                                      redefinitions of typedefs are ok *)
                | TComp (newci, _) ->
                  (* Composite types with different tags may be compatible, but here
                     we use the tags to try and detect if the type is being redefined,
                     which is NOT allowed. *)
                  begin
                    match unrollType typeinfo.ttype with
                    | TComp (ci, _) ->
                      if ci.cname <> newci.cname then
                        (* different tags => we consider that the type is being redefined *)
                        error_conflicting_types ()
                      else
                        (* redeclaration in same scope valid only in C11 *)
                      if not (Kernel.C11.get ()) then error_c11_redefinition ()
                    | _ -> (* because of the compatibility test, this should not happen *)
                      Kernel.fatal ~current:true "typeinfo.ttype (%a) should be TComp"
                        Cil_datatype.Typ.pretty typeinfo.ttype
                  end
                | TEnum _ -> (* GCC/Clang: "conflicting types" *)
                  error_conflicting_types ()
                | _ -> (* redeclaration in same scope valid only in C11 *)
                  if not (Kernel.C11.get ()) then error_c11_redefinition ()
              end
          end
        else if declared_in_current_scope ~ghost n then
          Kernel.error ~current:true
            "redefinition of type '%s' in the same scope with incompatible type.@ \
             Previous declaration was at %a" n Cil_datatype.Location.pretty oldloc;
      end
    else (* effectively create new type *) begin
      let n', _  = newAlphaName ghost true "type" n in
      let ti =
        { torig_name = n; tname = n';
          ttype = newTyp'; treferenced = false }
      in
      (* Since we use the same name space, we might later hit a global with
       * the same name and we would want to change the name of the global.
       * It is better to change the name of the type instead. So, remember
       * all types whose names have changed *)
      H.add typedefs n' ti;
      let namedTyp = TNamed(ti, []) in
      (* Register the type. register it as local because we might be in a
       * local context  *)
      addLocalToEnv ghost (kindPlusName "type" n) (EnvTyp namedTyp);
      cabsPushGlobal (GType (ti, CurrentLoc.get ()))
    end
  in
  List.iter createTypedef nl

and doOnlyTypedef ghost (specs: Cabs.spec_elem list) : unit =
  let bt, sto, inl, attrs = doSpecList ghost "" specs in
  if sto <> NoStorage || inl then
    Kernel.error ~once:true ~current:true
      "Storage or inline specifier not allowed in typedef";
  let restyp, nattr =
    doType ghost false AttrType bt (Cabs.PARENTYPE(attrs, Cabs.JUSTBASE, []))
  in
  if nattr <> [] then
    Kernel.warning ~current:true "Ignoring identifier attribute";
  (* doSpec will register the type. *)
  (* See if we are defining a composite or enumeration type, and in that
   * case move the attributes from the defined type into the composite type
   * *)
  let isadef =
    List.exists
      (function
          Cabs.SpecType(Cabs.Tstruct(_, Some _, _)) -> true
        | Cabs.SpecType(Cabs.Tunion(_, Some _, _)) -> true
        | Cabs.SpecType(Cabs.Tenum(_, Some _, _)) -> true
        | _ -> false) specs
  in
  match restyp with
  | TComp(ci, al) ->
    if isadef then begin
      ci.cattr <- cabsAddAttributes ci.cattr al;
      (* The GCompTag was already added *)
    end else (* Add a GCompTagDecl *)
      cabsPushGlobal (GCompTagDecl(ci, CurrentLoc.get ()))
  | TEnum(ei, al) ->
    if isadef then begin
      ei.eattr <- cabsAddAttributes ei.eattr al;
    end else
      cabsPushGlobal (GEnumTagDecl(ei, CurrentLoc.get ()))
  | _ ->
    Kernel.warning ~current:true ~wkey:Kernel.wkey_unnamed_typedef
      "Ignoring unnamed typedef that does not introduce a struct or \
       enumeration type"

(* Now define the processors for body and statement *)
and doBody local_env (blk: Cabs.block) : chunk =
  let ghost = local_env.is_ghost in
  (* Rename the labels and add them to the environment *)
  List.iter (fun l -> ignore (genNewLocalLabel ghost l)) blk.blabels;
  (* See if we have some attributes *)
  let battrs = doAttributes ghost blk.Cabs.battrs in

  let bodychunk =
    afterConversion ~ghost
      (snd
         (List.fold_left   (* !!! @ evaluates its arguments backwards *)
            (fun ((new_behaviors,keep_block),prev) s ->
               let local_env =
                 { local_env with
                   known_behaviors =
                     new_behaviors @ local_env.known_behaviors
                 }
               in
               (* Format.eprintf "Considering statement: %a@."
                  Cprint.print_statement s; *)
               let res = doStatement local_env s in
               (* Keeps stmts originating from the same source
                  statement in a single block when the statement
                  follows a code annotation, so that the annotation
                  will be attached to the whole result and
                  not to the first Cil statement. This is only needed
                  for statement contracts and pragmas. Other (non-loop, as
                  they have special treatment) annotations operate purely
                  at current point and do not care about what happens to the
                  next statement.
               *)
               let new_behaviors, keep_next =
                 match s.stmt_node with
                 | CODE_ANNOT(Logic_ptree.AStmtSpec (_,s),_)
                 | CODE_SPEC (s,_) ->
                   List.map
                     (fun x -> x.Logic_ptree.b_name)
                     s.Logic_ptree.spec_behavior,
                   true
                 | CODE_ANNOT(Logic_ptree.APragma _,_) -> [], true
                 | CODE_ANNOT
                     (Logic_ptree.AExtended(_,is_loop,(name,_)),loc) ->
                   let source = fst loc in
                   (match Logic_env.extension_category name, is_loop with
                    | exception Not_found ->
                      Kernel.(
                        warning
                          ~source ~wkey:wkey_acsl_extension
                          "%s is not a known extension" name);
                      [], false
                    | Ext_code_annot Ext_here, false -> [], false
                    | Ext_code_annot Ext_next_stmt, false -> [], true
                    | Ext_code_annot Ext_next_loop, true -> [], false
                    | Ext_code_annot Ext_next_both, _ -> [], not is_loop
                    | Ext_code_annot (Ext_here | Ext_next_stmt), true ->
                      Kernel.(
                        warning
                          ~source ~wkey:wkey_acsl_extension
                          "%s is a code annotation extension, \
                           but used here as a loop annotation" name);
                      [], false
                    | Ext_code_annot Ext_next_loop, false ->
                      Kernel.(
                        warning
                          ~source ~wkey:wkey_acsl_extension
                          "%s is a loop annotation extension, \
                           but used here as a code annotation" name);
                      [], false
                    | (Ext_global | Ext_contract), _ ->
                      Kernel.(
                        warning
                          ~source ~wkey:wkey_acsl_extension
                          "%s is not a code annotation extension" name);
                      [], false)
                 | _ -> [], false
               in
               (*               Format.eprintf "Done statement %a@." d_chunk res; *)
               let chunk =
                 if keep_block then
                   append_chunk_to_annot ~ghost prev res
                 else prev @@ (res, ghost)
               in ((new_behaviors, keep_next), chunk))
            (([],false),empty)
            blk.Cabs.bstmts))
  in
  if battrs == [] && bodychunk.locals == []
  then begin
    (* keep block marked with FRAMA_C_KEEP_BLOCK or that defines local
          variables as independent blocks whatever happens.
    *)
    bodychunk
  end
  else begin
    let b = c2block ~ghost bodychunk in
    b.battrs <- battrs;
    let res = s2c (mkStmt ~ghost ~valid_sid (Block b)) in
    { res with cases = bodychunk.cases }
  end

and doBodyScope local_env blk =
  enterScope (); let res = doBody local_env blk in exitScope (); res

and doStatement local_env (s : Cabs.statement) : chunk =
  let mk_loop_annot a loc =
    try
      List.map
        (Ltyping.code_annot
           loc local_env.known_behaviors (Ctype !currentReturnType)) a
    with LogicTypeError ((source,_),msg) ->
      Kernel.warning
        ~wkey:Kernel.wkey_annot_error ~source
        "%s. Ignoring loop annotation" msg;
      []
  in
  let ghost = s.stmt_ghost in
  let local_env = { local_env with is_ghost = ghost } in
  match s.stmt_node with
  | Cabs.NOP loc ->
    { empty
      with stmts = [mkEmptyStmt ~ghost ~valid_sid ~loc (), [],[],[],[]]}
  | Cabs.COMPUTATION (e, loc) ->
    CurrentLoc.set (convLoc loc);
    let (lasts, data) = !gnu_body_result in
    if lasts == s then begin      (* This is the last in a GNU_BODY *)
      let (s', e', t') = doFullExp local_env CNoConst e (AExp None) in
      data := Some (e', t');      (* Record the result *)
      s'
    end else
      let (s', e', _) = doFullExp local_env CNoConst e ADrop in
      (* drop the side-effect free expression unless the whole computation
         is pure and it contains potential threats (i.e. dereference)
      *)
      if isEmpty s' && is_dangerous e'
      then
        s' @@ (keepPureExpr ~ghost e' loc, ghost)
      else
        begin
          if (isEmpty s') then begin
            let name = !currentFunctionFDEC.svar.vorig_name in
            IgnorePureExpHook.apply (name, e');
          end;
          s'
        end

  | Cabs.BLOCK (b, loc,_) ->
    CurrentLoc.set (convLoc loc);
    let c = doBodyScope local_env b in
    let b = c2block ~ghost c in
    b.battrs <- addAttributes [Attr(frama_c_keep_block,[])] b.battrs;
    let res = s2c (mkStmt ~ghost ~valid_sid (Block b)) in
    { res with cases = c.cases }

  | Cabs.SEQUENCE (s1, s2, _) ->
    let c1 = doStatement local_env s1 in
    let c2 = doStatement local_env s2 in
    c1 @@ (c2, ghost)

  | Cabs.IF(e,st,sf,loc) ->
    let st' = doStatement local_env st in
    let sf' = doStatement local_env sf in
    CurrentLoc.set (convLoc loc);
    doCondition local_env CNoConst e st' sf'

  | Cabs.WHILE(a,e,s,loc) ->
    startLoop true;
    let a = mk_loop_annot a loc in
    let s' = doStatement local_env s in
    let s' =
      if !doTransformWhile then
        s' @@ (consLabContinue ~ghost skipChunk, ghost)
      else s'
    in
    let loc' = convLoc loc in
    let break_cond = breakChunk ~ghost loc' in
    exitLoop ();
    CurrentLoc.set loc';
    loopChunk ~ghost ~sattr:[Attr("while",[])] a
      ((doCondition local_env CNoConst e skipChunk break_cond)
       @@ (s', ghost))

  | Cabs.DOWHILE(a, e,s,loc) ->
    startLoop false;
    let a = mk_loop_annot a loc in
    let s' = doStatement local_env s in
    let loc' = convLoc loc in
    CurrentLoc.set loc';
    (* No 'break' instruction can exit the chunk *)
    let no_break chunk =
      List.for_all (fun (s, _, _, _, _) -> not (stmtCanBreak s)) chunk.stmts
    in
    (* Check if we are translating 'do { <s> } while (0)'. If so, translate
       it into '<s>' instead. Only active when -simplify-trivial-loops is
       set (default), as it impact plugins that compare the shape of the
       Cabs and of the Cil files. *)
    if Kernel.SimplifyTrivialLoops.get() &&
       isCabsZeroExp e (* exp is 0 or something equivalent *) &&
       a = [] (* No loop annot *) &&
       not (continueUsed ()) (* no 'continue' inside s *) &&
       no_break s' (* no break that exists s *)
    then (
      exitLoop ();
      s'
    )
    else
      let s'' =
        consLabContinue ~ghost
          (doCondition
             local_env
             CNoConst e skipChunk (breakChunk ~ghost loc'))
      in
      exitLoop ();
      loopChunk ~ghost ~sattr:[Attr("dowhile",[])] a (s' @@ (s'', ghost))

  | Cabs.FOR(a,fc1,e2,e3,s,loc) -> begin
      let loc' = convLoc loc in
      CurrentLoc.set loc';
      enterScope (); (* Just in case we have a declaration *)
      ForLoopHook.apply (fc1,e2,e3,s);
      let (se1, _, _) , has_decl =
        match fc1 with
        | FC_EXP e1 -> doFullExp local_env CNoConst e1 ADrop, false
        | FC_DECL d1 ->
          (doDecl local_env false d1, zero ~loc, voidType), true
      in
      let (se3, _, _) = doFullExp local_env CNoConst e3 ADrop in
      startLoop false;
      let a = mk_loop_annot a loc in
      let s' = doStatement local_env s in
      (*Kernel.debug "Loop body : %a" d_chunk s';*)
      CurrentLoc.set loc';
      let s'' = consLabContinue ~ghost se3 in
      let break_cond = breakChunk ~ghost loc' in
      exitLoop ();
      let c = s' @@ (s'', ghost) in
      let c =
        match e2.expr_node with
        | Cabs.NOTHING -> (* This means true *)
          c
        | _ ->
          doCondition local_env CNoConst e2 skipChunk break_cond @@ (c, ghost)
      in
      let res = se1 @@ (loopChunk ~sattr:[Attr("for",[])] ~ghost a c, ghost) in
      exitScope ();
      if has_decl then begin
        let chunk = s2c (mkStmt ~ghost ~valid_sid (Block (c2block ~ghost res)))
        in
        { chunk with cases = res.cases }
      end else res
    end

  | Cabs.BREAK loc ->
    let loc' = convLoc loc in
    CurrentLoc.set loc';
    breakChunk ~ghost loc'

  | Cabs.CONTINUE loc ->
    let loc' = convLoc loc in
    CurrentLoc.set loc';
    continueOrLabelChunk ~ghost loc'

  | Cabs.RETURN ({ expr_node = Cabs.NOTHING}, loc) ->
    let loc' = convLoc loc in
    CurrentLoc.set loc';
    if not (isVoidType !currentReturnType) then
      Kernel.error ~current:true
        "Return statement without a value in function returning %a\n"
        Cil_datatype.Typ.pretty !currentReturnType;
    returnChunk ~ghost None loc'

  | Cabs.RETURN (e, loc) ->
    let loc' = convLoc loc in
    CurrentLoc.set loc';
    (* Sometimes we return the result of a void function call *)
    if isVoidType !currentReturnType then begin
      Kernel.error ~current:true
        "Return statement with a value in function returning void";
      let (se, _, _) = doFullExp local_env CNoConst e ADrop in
      se @@ (returnChunk ~ghost None loc', ghost)
    end else begin
      let rt =
        typeRemoveAttributes ["warn_unused_result"] !currentReturnType
      in
      let (se, e', et) =
        doFullExp local_env CNoConst e (AExp (Some rt)) in
      let (_, e'') = castTo et rt e' in
      se @@ (returnChunk ~ghost (Some e'') loc', ghost)
    end

  | Cabs.SWITCH (e, s, loc) ->
    let loc' = convLoc loc in
    CurrentLoc.set loc';
    let (se, e', et) = doFullExp local_env CNoConst e (AExp None) in
    if not (Cil.isIntegralType et) then
      Kernel.error ~once:true ~current:true "Switch on a non-integer expression.";
    let et' = Cil.integralPromotion et in
    let e' = makeCastT ~e:e' ~oldt:et ~newt:et' in
    enter_break_env ();
    let s' = doStatement local_env s in
    exit_break_env ();
    se @@ (switchChunk ~ghost e' s' loc', ghost)

  | Cabs.CASE (e, s, loc) ->
    let loc' = convLoc loc in
    CurrentLoc.set loc';
    let (se, e', _) = doFullExp local_env CConst e (AExp None) in
    if isNotEmpty se || not (Cil.isIntegerConstant e') then
      Kernel.error ~once:true ~current:true
        "Case statement with a non-constant";
    let chunk =
      caseRangeChunk ~ghost
        [if theMachine.lowerConstants then constFold false e' else e']
        loc' (doStatement local_env s)
    in
    (* se has no statement, but can contain local variables, in
       particular in the case of a sizeof with side-effects. *)
    se @@ (chunk,ghost)

  | Cabs.CASERANGE (el, eh, s, loc) ->
    let loc' = convLoc loc in
    CurrentLoc.set loc;
    let (sel, el', _) = doFullExp local_env CNoConst el (AExp None) in
    let (seh, eh', _) = doFullExp local_env CNoConst eh (AExp None) in
    if isNotEmpty sel || isNotEmpty seh then
      Kernel.error ~once:true ~current:true
        "Case statement with a non-constant";
    let il, ih =
      match constFoldToInteger el', constFoldToInteger eh' with
      | Some il, Some ih -> il, ih
      | _ ->
        Kernel.fatal ~current:true
          "Cannot understand the constants in case range"
    in
    if il > ih then Kernel.error ~once:true ~current:true "Empty case range";
    (* Arbitrary limit to avoid building an impractical AST. *)
    if ih - il > 100_000 then Kernel.fatal ~current:true "Case range too large";
    let rec mkAll (i: int) =
      if i > ih then [] else integer ~loc i :: mkAll (i + 1)
    in
    (sel @@ (seh,ghost)) @@
    (caseRangeChunk ~ghost (mkAll il) loc' (doStatement local_env s),
     ghost)

  | Cabs.DEFAULT (s, loc) ->
    let loc' = convLoc loc in
    CurrentLoc.set loc';
    defaultChunk ~ghost loc' (doStatement local_env s)
  | Cabs.LABEL (l, s, loc) ->
    let loc' = convLoc loc in
    CurrentLoc.set loc';
    add_label_env l;
    C_logic_env.add_current_label l;
    (* Lookup the label because it might have been locally defined *)
    let chunk =
      consLabel ~ghost (lookupLabel ghost l) (doStatement local_env s) loc' true
    in
    C_logic_env.reset_current_label (); chunk

  | Cabs.GOTO (l, loc) ->
    let loc' = convLoc loc in
    CurrentLoc.set loc';
    (* Maybe we need to rename this label *)
    gotoChunk ~ghost (lookupLabel ghost l) loc'

  | Cabs.COMPGOTO (e, loc) -> begin
      let loc' = convLoc loc in
      CurrentLoc.set loc';
      (* Do the expression *)
      let se, e', _ =
        doFullExp local_env CNoConst e (AExp (Some voidPtrType))
      in
      match !gotoTargetData with
      | Some (switchv, switch) -> (* We have already generated this one  *)
        (se
         @@ (i2c(mkStmtOneInstr ~ghost ~valid_sid
                   (Set (var switchv, makeCast ~e:e' ~newt:intType, loc')),
                 [],[],[]), ghost))
        @@ (s2c(mkStmt ~ghost ~valid_sid (Goto (ref switch, loc'))), ghost)

      | None -> begin
          (* Make a temporary variable *)
          let vchunk = createLocal
              local_env.is_ghost
              (intType, NoStorage, false, [])
              (("__compgoto", Cabs.JUSTBASE, [], loc), Cabs.NO_INIT)
          in
          if not (isEmpty vchunk) then
            Kernel.fatal ~current:true
              "Non-empty chunk in creating temporary for goto *";
          let switchv, _ =
            try lookupVar ghost "__compgoto"
            with Not_found -> abort_context "Cannot find temporary for goto *";
          in
          (* Make a switch statement. We'll fill in the statements at the
           * end of the function *)
          let switch =
            mkStmt ~ghost ~valid_sid
              (Switch (new_exp ~loc (Lval(var switchv)),
                       mkBlock [], [], loc'))
          in
          (* And make a label for it since we'll goto it *)
          switch.labels <- [Label ("__docompgoto", loc', false)];
          gotoTargetData := Some (switchv, switch);
          (se @@
           (i2c
              (mkStmtOneInstr ~ghost ~valid_sid
                 (Set (var switchv, makeCast ~e:e' ~newt:intType, loc')),
               [],[],[]),
            ghost))
          @@ (s2c switch, ghost)
        end
    end

  | Cabs.DEFINITION d ->
    doDecl local_env false d

  | Cabs.ASM (asmattr, tmpls, details, loc) ->
    (* Make sure all the outs are variables *)
    let loc' = convLoc loc in
    let attr' = doAttributes local_env.is_ghost asmattr in
    CurrentLoc.set loc';
    let stmts : chunk ref = ref empty in
    let ext_asm =
      match details with
      | None -> None
      | Some { aoutputs; ainputs; aclobbers; alabels} ->
        let asm_outputs =
          List.map
            (fun (id, c, e) ->
               let (se, e', _) = doFullExp local_env CNoConst e (AExp None) in
               let lv =
                 match e'.enode with
                 | Lval lval
                 | StartOf lval -> lval
                 | _ ->
                   Kernel.fatal ~current:true
                     "Expected lval for ASM outputs"
               in
               if not (isEmpty se) then
                 stmts := !stmts @@ (se, ghost);
               (id, c, lv)) aoutputs
        in
        (* Get the side-effects out of expressions *)
        let asm_inputs =
          List.map
            (fun (id, c, e) ->
               let (r, se, e', _) =
                 doExp (no_paren_local_env local_env) CNoConst e (AExp None)
               in
               let se = add_reads ~ghost e'.eloc r se in
               if not (isEmpty se) then
                 stmts := !stmts @@ (se, ghost);
               (id, c, e'))
            ainputs
        in
        let asm_clobbers = aclobbers in
        let asm_gotos =
          List.map
            (fun label ->
               let label = lookupLabel ghost label in
               let gref = ref dummyStmt in
               addGoto label gref;
               gref)
            alabels
        in
        Some { asm_outputs; asm_inputs; asm_clobbers; asm_gotos }
    in
    !stmts @@
    (i2c(mkStmtOneInstr ~ghost:local_env.is_ghost ~valid_sid
           (Asm(attr', tmpls, ext_asm, loc')),[],[],[]),
     ghost)
  | THROW (e,loc) ->
    let loc' = convLoc loc in
    CurrentLoc.set loc';
    (match e with
     | None -> s2c (mkStmt ~ghost ~valid_sid (Throw (None,loc')))
     | Some e ->
       let se,e,t = doFullExp local_env CNoConst e (AExp None) in
       se @@
       (s2c (mkStmt ~ghost ~valid_sid (Throw (Some (e,t),loc'))),ghost))
  | TRY_CATCH(stry,l,loc) ->
    let loc' = convLoc loc in
    CurrentLoc.set loc';
    let chunk_try = doStatement local_env stry in
    let type_one_catch (var,scatch) =
      enterScope();
      let vi =
        match var with
        | None -> Catch_all
        | Some (t,(n,ndt,a,ldecl)) ->
          let spec = doSpecList ghost n t in
          let vi =
            makeVarInfoCabs
              ~ghost ~isformal:false ~isglobal:false ldecl spec (n,ndt,a)
          in
          addLocalToEnv ghost n (EnvVar vi);
          !currentFunctionFDEC.slocals <- vi :: !currentFunctionFDEC.slocals;
          Catch_exn(vi,[])
      in
      let chunk_catch = doStatement local_env scatch in
      exitScope();
      (vi,c2block ~ghost chunk_catch)
    in
    let catches = List.map type_one_catch l in
    s2c
      (mkStmt
         ~ghost ~valid_sid (TryCatch(c2block ~ghost chunk_try,catches,loc')))
  | TRY_FINALLY (b, h, loc) ->
    let loc' = convLoc loc in
    CurrentLoc.set loc';
    let b': chunk = doBodyScope local_env b in
    let h': chunk = doBodyScope local_env h in
    if b'.cases <> [] || h'.cases <> [] then
      Kernel.error ~once:true ~current:true
        "Try statements cannot contain switch cases";
    s2c (mkStmt ~ghost ~valid_sid
           (TryFinally (c2block ~ghost b', c2block ~ghost h', loc')))

  | TRY_EXCEPT (b, e, h, loc) ->
    let loc' = convLoc loc in
    CurrentLoc.set loc';
    let b': chunk = doBodyScope local_env b in
    (* Now do e *)
    let ((se: chunk), e', _) =
      doFullExp local_env CNoConst e (AExp None) in
    let h': chunk = doBodyScope local_env h in
    if b'.cases <> [] || h'.cases <> [] || se.cases <> [] then
      Kernel.error ~once:true ~current:true
        "Try statements cannot contain switch cases";
    (* Now take se and try to convert it to a list of instructions. This
     * might not be always possible *)
    let stmt_to_instrs s =
      List.rev_map
        (function (s,_,_,_,_) -> match s.skind with
            | Instr s -> s
            | _ ->
              Kernel.fatal ~current:true
                "Except expression contains unexpected statement")
        s
    in
    let il' = stmt_to_instrs se.stmts in
    s2c (mkStmt ~ghost ~valid_sid
           (TryExcept
              (c2block ~ghost b',(il', e'), c2block ~ghost h', loc')))
  | CODE_ANNOT (a, loc) ->
    let loc' = convLoc loc in
    begin
      try
        let typed_annot =
          Ltyping.code_annot
            loc' local_env.known_behaviors (Ctype !currentReturnType) a
        in
        s2c (mkStmtOneInstr ~ghost ~valid_sid (Code_annot (typed_annot,loc')))
      with LogicTypeError ((source,_),msg) ->
        Kernel.warning
          ~wkey:Kernel.wkey_annot_error ~source
          "%s. Ignoring code annotation" msg;
        BlockChunk.empty
    end

  | CODE_SPEC (a, loc) ->
    let loc' = convLoc loc in
    begin
      try
        let spec =
          Ltyping.code_annot loc' local_env.known_behaviors
            (Ctype !currentReturnType) (Logic_ptree.AStmtSpec ([],a))
        in
        s2c (mkStmtOneInstr ~ghost ~valid_sid (Code_annot (spec,loc')))
      with LogicTypeError ((source,_),msg) ->
        Kernel.warning
          ~wkey:Kernel.wkey_annot_error ~source
          "%s. Ignoring code annotation" msg;
        BlockChunk.empty
    end

let copy_spec (old_f,new_f) formals_map spec =
  let obj = object
    inherit Cil.genericCilVisitor (Visitor_behavior.refresh (Project.current()))
    method! vlogic_var_use lv =
      match lv.lv_origin with
      | None -> DoChildren
      | Some v ->
        if Cil_datatype.Varinfo.equal v old_f then
          ChangeTo (Cil.cvar_to_lvar new_f)
        else begin
          try
            let _,new_v =
              List.find
                (fun (x,_) -> Cil_datatype.Varinfo.equal v x) formals_map
            in
            ChangeTo (Cil.cvar_to_lvar new_v)
          with Not_found -> DoChildren
        end
  end
  in
  Cil.visitCilFunspec obj spec

let split_extern_inline_def acc g =
  match g with
  | GFun ( { svar; sformals; sspec }, loc)
    when svar.vinline && svar.vstorage = NoStorage ->
    (* we have an inline definition, which is also an implicit external
       _declaration_ (see C11 6.7.4§7). Just rename its uses in the current
       translation unit, and leave a new, unrelated, external declaration for
       the link phase. If a spec exists, the external declaration will inherit
       it.
    *)
    let new_v = Cil_const.copy_with_new_vid svar in
    svar.vname <- svar.vname ^ "__fc_inline";
    (* inline definition is restricted to this translation unit. *)
    svar.vstorage <- Static;
    let new_formals = List.map Cil_const.copy_with_new_vid sformals in
    Cil.unsafeSetFormalsDecl new_v new_formals;
    let formals_map = List.combine sformals new_formals in
    let new_spec = copy_spec (svar, new_v) formals_map sspec in
    GFunDecl (new_spec, new_v, loc) :: g :: acc
  | GFun ({ svar },_) when svar.vinline && svar.vstorage = Extern ->
    (* The definition is a real external definition. We may as well remove
       the inline specification. *)
    svar.vinline <- false;
    g :: acc
  | _ -> g::acc

(* Translate a file *)
let convFile (path, f) =
  Errorloc.clear_errors();
  (* Clean up the global types *)
  initGlobals();
  startFile ();
  H.clear compInfoNameEnv;
  H.clear enumInfoNameEnv;
  IH.clear mustTurnIntoDef;
  H.clear alreadyDefined;
  H.clear staticLocals;
  H.clear typedefs;
  H.clear alpha_renaming;
  Stack.clear packing_pragma_stack;
  current_packing_pragma := None;
  H.clear pragma_align_by_struct;
  current_pragma_align := None;
  Logic_env.prepare_tables ();
  anonCompFieldNameId := 0;
  Kernel.debug ~level:2 "Converting CABS->CIL" ;
  Cil_builtins.Builtin_functions.iter_sorted
    (fun name (resTyp, argTypes, isva) ->
       ignore (setupBuiltin name (resTyp, ArgTypes argTypes, isva)));
  let globalidx = ref 0 in
  let doOneGlobal (ghost,(d: Cabs.definition)) =
    let local_env = ghost_local_env ghost in
    let s = doDecl local_env true d in
    if isNotEmpty s then
      abort_context "doDecl returns non-empty statement for global";
  in
  List.iter doOneGlobal f;
  let globals = fileGlobals () in
  let globals = List.fold_left split_extern_inline_def [] globals in
  let globals = List.rev globals in
  List.iter rename_spec globals;
  Logic_env.prepare_tables ();
  IH.clear mustTurnIntoDef;
  H.clear alreadyDefined;
  H.clear compInfoNameEnv;
  H.clear enumInfoNameEnv;
  H.clear staticLocals;
  H.clear typedefs;
  Datatype.String.Hashtbl.clear env;
  Datatype.String.Hashtbl.clear global_env;
  Datatype.String.Hashtbl.clear ghost_env;
  Datatype.String.Hashtbl.clear ghost_global_env;
  IH.clear callTempVars;
  H.clear alpha_renaming;
  constrExprId := 0;

  if false then Kernel.debug "Cabs2cil converted %d globals" !globalidx;
  (* We are done *)
  { fileName = path;
    globals;
    globinit = None;
    globinitcalled = false;
  }

(* export function without internal `relaxed' argument. *)
let areCompatibleTypes t1 t2 = areCompatibleTypes t1 t2

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