3. Cil package

Start data section to licences/cil_licence.txt[1 /1 ]
     1: Copyright (c) 2001-2002,
     2:  George C. Necula    <necula@cs.berkeley.edu>
     3:  Scott McPeak        <smcpeak@cs.berkeley.edu>
     4:  Wes Weimer          <weimer@cs.berkeley.edu>
     5:  Ben Liblit          <liblit@cs.berkeley.edu>
     6: All rights reserved.
     7: 
     8: Redistribution and use in source and binary forms, with or without
     9: modification, are permitted provided that the following conditions are met:
    10: 
    11: 1. Redistributions of source code must retain the above copyright notice,
    12: this list of conditions and the following disclaimer.
    13: 
    14: 2. Redistributions in binary form must reproduce the above copyright notice,
    15: this list of conditions and the following disclaimer in the documentation
    16: and/or other materials provided with the distribution.
    17: 
    18: 3. The names of the contributors may not be used to endorse or promote
    19: products derived from this software without specific prior written
    20: permission.
    21: 
    22: THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
    23: AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
    24: IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
    25: ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
    26: LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
    27: CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
    28: SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
    29: INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
    30: CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
    31: ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
    32: POSSIBILITY OF SUCH DAMAGE.
    33: 
    34: (See http://www.opensource.org/licenses/bsd-license.php)
    35: 
End data section to licences/cil_licence.txt[1]
Start ocaml section to src/flx_cil_cilversion.mli[1 /1 ]
     1: # 40 "./lpsrc/flx_cil.ipk"
     2: val cilVersionMajor:int
     3: val cilVersionMinor:int
     4: val cilVersionRev:int
     5: val cilVersion:string
     6: 
     7: 
End ocaml section to src/flx_cil_cilversion.mli[1]
Start ocaml section to src/flx_cil_cilversion.ml[1 /1 ]
     1: # 48 "./lpsrc/flx_cil.ipk"
     2: let cilVersionMajor = 1
     3: let cilVersionMinor = 2
     4: let cilVersionRev   = 5
     5: let cilVersion      = "1.2.5"
     6: 
End ocaml section to src/flx_cil_cilversion.ml[1]
Start ocaml section to src/flx_cil_machdep_type.mli[1 /1 ]
     1: # 84 "./lpsrc/flx_cil.ipk"
     2: type mach = {
     3:   version_major: int;     (* Major version number *)
     4:   version_minor: int;     (* Minor version number *)
     5:   version: string;        (* version number *)
     6:   underscore_name: bool;  (* If assembly names have leading underscore *)
     7: 
     8:   sizeof_bool : int;
     9: # 90 "./lpsrc/flx_cil.ipk"
    10:   alignof_bool : int;
    11: # 90 "./lpsrc/flx_cil.ipk"
    12:   sizeof_cbool : int;
    13: # 90 "./lpsrc/flx_cil.ipk"
    14:   alignof_cbool : int;
    15: # 90 "./lpsrc/flx_cil.ipk"
    16:   sizeof_int : int;
    17: # 90 "./lpsrc/flx_cil.ipk"
    18:   alignof_int : int;
    19: # 90 "./lpsrc/flx_cil.ipk"
    20:   sizeof_short : int;
    21: # 90 "./lpsrc/flx_cil.ipk"
    22:   alignof_short : int;
    23: # 90 "./lpsrc/flx_cil.ipk"
    24:   sizeof_long : int;
    25: # 90 "./lpsrc/flx_cil.ipk"
    26:   alignof_long : int;
    27: # 90 "./lpsrc/flx_cil.ipk"
    28:   sizeof_longlong : int;
    29: # 90 "./lpsrc/flx_cil.ipk"
    30:   alignof_longlong : int;
    31: # 90 "./lpsrc/flx_cil.ipk"
    32:   sizeof_enum : int;
    33: # 90 "./lpsrc/flx_cil.ipk"
    34:   alignof_enum : int;
    35: # 90 "./lpsrc/flx_cil.ipk"
    36:   sizeof_wchar : int;
    37: # 90 "./lpsrc/flx_cil.ipk"
    38:   alignof_wchar : int;
    39: # 90 "./lpsrc/flx_cil.ipk"
    40:   sizeof_size : int;
    41: # 90 "./lpsrc/flx_cil.ipk"
    42:   alignof_size : int;
    43: # 90 "./lpsrc/flx_cil.ipk"
    44:   sizeof_float : int;
    45: # 90 "./lpsrc/flx_cil.ipk"
    46:   alignof_float : int;
    47: # 90 "./lpsrc/flx_cil.ipk"
    48:   sizeof_double : int;
    49: # 90 "./lpsrc/flx_cil.ipk"
    50:   alignof_double : int;
    51: # 90 "./lpsrc/flx_cil.ipk"
    52:   sizeof_longdouble : int;
    53: # 90 "./lpsrc/flx_cil.ipk"
    54:   alignof_longdouble : int;
    55: # 90 "./lpsrc/flx_cil.ipk"
    56:   sizeof_complex : int;
    57: # 90 "./lpsrc/flx_cil.ipk"
    58:   alignof_complex : int;
    59: # 90 "./lpsrc/flx_cil.ipk"
    60:   sizeof_doublecomplex : int;
    61: # 90 "./lpsrc/flx_cil.ipk"
    62:   alignof_doublecomplex : int;
    63: # 90 "./lpsrc/flx_cil.ipk"
    64:   sizeof_longdoublecomplex : int;
    65: # 90 "./lpsrc/flx_cil.ipk"
    66:   alignof_longdoublecomplex : int;
    67: # 90 "./lpsrc/flx_cil.ipk"
    68:   sizeof_imaginary : int;
    69: # 90 "./lpsrc/flx_cil.ipk"
    70:   alignof_imaginary : int;
    71: # 90 "./lpsrc/flx_cil.ipk"
    72:   sizeof_doubleimaginary : int;
    73: # 90 "./lpsrc/flx_cil.ipk"
    74:   alignof_doubleimaginary : int;
    75: # 90 "./lpsrc/flx_cil.ipk"
    76:   sizeof_longdoubleimaginary : int;
    77: # 90 "./lpsrc/flx_cil.ipk"
    78:   alignof_longdoubleimaginary : int;
    79: 
    80:   sizeof_ptr: int;        (* Size of pointers *)
    81:   sizeof_void: int;       (* Size of "void" *)
    82:   sizeof_fun: int;        (* Size of function *)
    83: 
    84:   alignof_str: int;       (* Alignment of strings *)
    85:   alignof_fun: int;       (* Alignment of function *)
    86:   char_is_unsigned: bool; (* Whether "char" is unsigned *)
    87:   const_string_literals: bool; (* Whether string literals have const chars *)
    88:   little_endian: bool; (* whether the machine is little endian *)
    89: }
    90: 
End ocaml section to src/flx_cil_machdep_type.mli[1]
Start ocaml section to src/flx_cil_machdep.mli[1 /1 ]
     1: # 105 "./lpsrc/flx_cil.ipk"
     2: open Flx_cil_machdep_type
     3: val gcc:mach
     4: val msvc:mach
     5: val hasMSVC:bool
     6: val gccHas__builtin_va_list:bool
     7: val __thread_is_keyword:bool
     8: 
End ocaml section to src/flx_cil_machdep.mli[1]
Start ocaml section to src/flx_cil_machdep.ml[1 /1 ]
     1: # 114 "./lpsrc/flx_cil.ipk"
     2: open Flx_cil_machdep_type
     3: 
     4: let gcc:mach = {
     5:   version_major    = 3;
     6:   version_minor    = 2;
     7:   version          = "3.2.2 20030222 (Red Hat Linux 3.2.2-5)";
     8:   underscore_name  = true;
     9: 
    10:   alignof_str = 1;
    11:   alignof_fun = 1;
    12:   sizeof_void      = 1;
    13:   sizeof_fun       = 1;
    14:   sizeof_ptr       = 4;
    15: 
    16: # 135 "./lpsrc/flx_cil.ipk"
    17:   sizeof_bool = 1;
    18: # 135 "./lpsrc/flx_cil.ipk"
    19:   alignof_bool = 1;
    20: # 135 "./lpsrc/flx_cil.ipk"
    21:   sizeof_cbool = 0;
    22: # 135 "./lpsrc/flx_cil.ipk"
    23:   alignof_cbool = 0;
    24: # 135 "./lpsrc/flx_cil.ipk"
    25:   sizeof_int = 4;
    26: # 135 "./lpsrc/flx_cil.ipk"
    27:   alignof_int = 4;
    28: # 135 "./lpsrc/flx_cil.ipk"
    29:   sizeof_short = 2;
    30: # 135 "./lpsrc/flx_cil.ipk"
    31:   alignof_short = 2;
    32: # 135 "./lpsrc/flx_cil.ipk"
    33:   sizeof_long = 4;
    34: # 135 "./lpsrc/flx_cil.ipk"
    35:   alignof_long = 4;
    36: # 135 "./lpsrc/flx_cil.ipk"
    37:   sizeof_longlong = 8;
    38: # 135 "./lpsrc/flx_cil.ipk"
    39:   alignof_longlong = 8;
    40: # 135 "./lpsrc/flx_cil.ipk"
    41:   sizeof_enum = 4;
    42: # 135 "./lpsrc/flx_cil.ipk"
    43:   alignof_enum = 4;
    44: # 135 "./lpsrc/flx_cil.ipk"
    45:   sizeof_wchar = 4;
    46: # 135 "./lpsrc/flx_cil.ipk"
    47:   alignof_wchar = 4;
    48: # 135 "./lpsrc/flx_cil.ipk"
    49:   sizeof_size = 4;
    50: # 135 "./lpsrc/flx_cil.ipk"
    51:   alignof_size = 4;
    52: # 135 "./lpsrc/flx_cil.ipk"
    53:   sizeof_float = 4;
    54: # 135 "./lpsrc/flx_cil.ipk"
    55:   alignof_float = 4;
    56: # 135 "./lpsrc/flx_cil.ipk"
    57:   sizeof_double = 8;
    58: # 135 "./lpsrc/flx_cil.ipk"
    59:   alignof_double = 8;
    60: # 135 "./lpsrc/flx_cil.ipk"
    61:   sizeof_longdouble = 16;
    62: # 135 "./lpsrc/flx_cil.ipk"
    63:   alignof_longdouble = 8;
    64: # 135 "./lpsrc/flx_cil.ipk"
    65:   sizeof_complex = 8;
    66: # 135 "./lpsrc/flx_cil.ipk"
    67:   alignof_complex = 4;
    68: # 135 "./lpsrc/flx_cil.ipk"
    69:   sizeof_doublecomplex = 16;
    70: # 135 "./lpsrc/flx_cil.ipk"
    71:   alignof_doublecomplex = 8;
    72: # 135 "./lpsrc/flx_cil.ipk"
    73:   sizeof_longdoublecomplex = 32;
    74: # 135 "./lpsrc/flx_cil.ipk"
    75:   alignof_longdoublecomplex = 8;
    76: # 135 "./lpsrc/flx_cil.ipk"
    77:   sizeof_imaginary = 0;
    78: # 135 "./lpsrc/flx_cil.ipk"
    79:   alignof_imaginary = 0;
    80: # 135 "./lpsrc/flx_cil.ipk"
    81:   sizeof_doubleimaginary = 0;
    82: # 135 "./lpsrc/flx_cil.ipk"
    83:   alignof_doubleimaginary = 0;
    84: # 135 "./lpsrc/flx_cil.ipk"
    85:   sizeof_longdoubleimaginary = 0;
    86: # 135 "./lpsrc/flx_cil.ipk"
    87:   alignof_longdoubleimaginary = 0;
    88: 
    89: # 141 "./lpsrc/flx_cil.ipk"
    90:   char_is_unsigned = false;
    91: # 141 "./lpsrc/flx_cil.ipk"
    92:   const_string_literals = true;
    93: # 146 "./lpsrc/flx_cil.ipk"
    94:   little_endian = false;
    95: # 146 "./lpsrc/flx_cil.ipk"
    96: }
    97: # 152 "./lpsrc/flx_cil.ipk"
    98: let hasMSVC = false
    99: # 152 "./lpsrc/flx_cil.ipk"
   100: let msvc = gcc (* hackery .. *)
   101: let gccHas__builtin_va_list = true
   102: let __thread_is_keyword = true
   103: 
   104: 
End ocaml section to src/flx_cil_machdep.ml[1]
Start ocaml section to src/flx_cil_check.ml[1 /1 ]
     1: # 159 "./lpsrc/flx_cil.ipk"
     2: 
     3: (* A consistency checker for CIL *)
     4: open Flx_cil_cil
     5: module E = Flx_cil_errormsg
     6: module H = Hashtbl
     7: open Flx_cil_pretty
     8: 
     9: 
    10: (* A few parameters to customize the checking *)
    11: type checkFlags =
    12:     NoFlx_cil_checkGlobalIds   (* Do not check that the global ids have the proper
    13:                         * hash value *)
    14: 
    15: let checkGlobalIds = ref true
    16: 
    17:   (* Attributes must be sorted *)
    18: type ctxAttr =
    19:     CALocal                             (* Attribute of a local variable *)
    20:   | CAGlobal                            (* Attribute of a global variable *)
    21:   | CAType                              (* Attribute of a type *)
    22: 
    23: let valid = ref true
    24: 
    25: let warn fmt =
    26:   valid := false;
    27:   Flx_cil_cil.warn fmt
    28: 
    29: let warnContext fmt =
    30:   valid := false;
    31:   Flx_cil_cil.warnContext fmt
    32: 
    33: let checkAttributes (attrs: attribute list) : unit =
    34:   let rec loop lastname = function
    35:       [] -> ()
    36:     | (Attr(an, _) as a) :: resta ->
    37:         if an < lastname then
    38:           ignore (warn "Attributes not sorted");
    39:         loop an resta
    40:   in
    41:   loop "" attrs
    42: 
    43: 
    44:   (* Keep track of defined types *)
    45: let typeDefs : (string, typ) H.t = H.create 117
    46: 
    47: 
    48:   (* Keep track of all variables names, enum tags and type names *)
    49: let varNamesEnv : (string, unit) H.t = H.create 117
    50: 
    51:   (* We also keep a map of variables indexed by id, to ensure that only one
    52:    * varinfo has a given id *)
    53: let varIdsEnv: (int, varinfo) H.t = H.create 117
    54: 
    55:   (* And keep track of all varinfo's to check the uniqueness of the
    56:    * identifiers *)
    57: let allVarIds: (int, varinfo) H.t = H.create 117
    58: 
    59:  (* Also keep a list of environments. We place an empty string in the list to
    60:   * mark the start of a local environment (i.e. a function) *)
    61: let varNamesList : (string * int) list ref = ref []
    62: let defineName s =
    63:   if s = "" then
    64:     E.s (bug "Empty name\n");
    65:   if H.mem varNamesEnv s then
    66:     ignore (warn "Multiple definitions for %s\n" s);
    67:   H.add varNamesEnv s ()
    68: 
    69: let defineVariable vi =
    70:   defineName vi.vname;
    71:   varNamesList := (vi.vname, vi.vid) :: !varNamesList;
    72:   (* Flx_cil_check the id *)
    73:   if H.mem allVarIds vi.vid then
    74:     ignore (warn "Id %d is already defined (%s)\n" vi.vid vi.vname);
    75:   H.add allVarIds vi.vid vi;
    76:   (* And register it in the current scope also *)
    77:   H.add varIdsEnv vi.vid vi
    78: 
    79: (* Flx_cil_check that a varinfo has already been registered *)
    80: let checkVariable vi =
    81:   try
    82:     (* Flx_cil_check in the current scope only *)
    83:     if vi != H.find varIdsEnv vi.vid then
    84:       ignore (warnContext "varinfos for %s not shared\n" vi.vname);
    85:   with Not_found ->
    86:     ignore (warn "Unknown id (%d) for %s\n" vi.vid vi.vname)
    87: 
    88: 
    89: let startEnv () =
    90:   varNamesList := ("", -1) :: !varNamesList
    91: 
    92: let endEnv () =
    93:   let rec loop = function
    94:       [] -> E.s (bug "Cannot find start of env")
    95:     | ("", _) :: rest -> varNamesList := rest
    96:     | (s, id) :: rest -> begin
    97:         H.remove varNamesEnv s;
    98:         H.remove varIdsEnv id;
    99:         loop rest
   100:     end
   101:   in
   102:   loop !varNamesList
   103: 
   104: 
   105: 
   106: (* The current function being checked *)
   107: let currentReturnType : typ ref = ref voidType
   108: 
   109: (* A map of labels in the current function *)
   110: let labels: (string, unit) H.t = H.create 17
   111: 
   112: (* A list of statements seen in the current function *)
   113: let statements: stmt list ref = ref []
   114: 
   115: (* A list of the targets of Gotos *)
   116: let gotoTargets: (string * stmt) list ref = ref []
   117: 
   118: (*** TYPES ***)
   119: (* Cetain types can only occur in some contexts, so keep a list of context *)
   120: type ctxType =
   121:     CTStruct                            (* In a composite type *)
   122:   | CTUnion
   123:   | CTFArg                              (* In a function argument type *)
   124:   | CTFRes                              (* In a function result type *)
   125:   | CTArray                             (* In an array type *)
   126:   | CTPtr                               (* In a pointer type *)
   127:   | CTExp                               (* In an expression, as the type of
   128:                                          * the result of binary operators, or
   129:                                          * in a cast *)
   130:   | CTSizeof                            (* In a sizeof *)
   131:   | CTDecl                              (* In a typedef, or a declaration *)
   132: 
   133: let d_context () = function
   134:     CTStruct -> text "CTStruct"
   135:   | CTUnion -> text "CTUnion"
   136:   | CTFArg -> text "CTFArg"
   137:   | CTFRes -> text "CTFRes"
   138:   | CTArray -> text "CTArray"
   139:   | CTPtr -> text "CTPtr"
   140:   | CTExp -> text "CTExp"
   141:   | CTSizeof -> text "CTSizeof"
   142:   | CTDecl -> text "CTDecl"
   143: 
   144: 
   145: (* Keep track of all tags that we use. For each tag remember also the info
   146:  * structure and a flag whether it was actually defined or just used. A
   147:  * forward declaration acts as a definition. *)
   148: type defuse =
   149:     Defined (* We actually have seen a definition of this tag *)
   150:   | Forward (* We have seen a forward declaration for it. This is done using
   151:              * a GType with an empty type name *)
   152:   | Used    (* Only uses *)
   153: let compUsed : (int, compinfo * defuse ref) H.t = H.create 117
   154: let enumUsed : (string, enuminfo * defuse ref) H.t = H.create 117
   155: let typUsed  : (string, typeinfo * defuse ref) H.t = H.create 117
   156: 
   157: (* For composite types we also check that the names are unique *)
   158: let compNames : (string, unit) H.t = H.create 17
   159: 
   160: 
   161:   (* Flx_cil_check a type *)
   162: let rec checkType (t: typ) (ctx: ctxType) =
   163:   (* Flx_cil_check that it appears in the right context *)
   164:   let rec checkContext = function
   165:       TVoid _ -> ctx = CTPtr || ctx = CTFRes || ctx = CTDecl
   166:     | TNamed (ti, a) -> checkContext ti.ttype
   167:     | TArray _ ->
   168:         (ctx = CTStruct || ctx = CTUnion
   169:          || ctx = CTSizeof || ctx = CTDecl || ctx = CTArray || ctx = CTPtr)
   170:     | TComp _ -> ctx <> CTExp
   171:     | _ -> true
   172:   in
   173:   if not (checkContext t) then
   174:     ignore (warn "Type (%a) used in wrong context. Expected context: %a"
   175:               d_plaintype t d_context ctx);
   176:   match t with
   177:     (TVoid a | TBuiltin_va_list a) -> checkAttributes a
   178:   | TInt (ik, a) -> checkAttributes a
   179:   | TFloat (_, a) -> checkAttributes a
   180:   | TPtr (t, a) -> checkAttributes a;  checkType t CTPtr
   181: 
   182:   | TNamed (ti, a) ->
   183:       checkAttributes a;
   184:       if ti.tname = "" then
   185:         ignore (warnContext "Using a typeinfo for an empty-named type\n");
   186:       checkTypeInfo Used ti
   187: 
   188:   | TComp (comp, a) ->
   189:       checkAttributes a;
   190:       (* Mark it as a forward. We'll check it later. If we try to check it
   191:        * now we might encounter undefined types *)
   192:       checkCompInfo Used comp
   193: 
   194: 
   195:   | TEnum (enum, a) -> begin
   196:       checkAttributes a;
   197:       checkEnumInfo Used enum
   198:   end
   199: 
   200:   | TArray(bt, len, a) ->
   201:       checkAttributes a;
   202:       checkType bt CTArray;
   203:       (match len with
   204:         None -> ()
   205:       | Some l -> begin
   206:           let t = checkExp true l in
   207:           match t with
   208:             TInt((IInt|IUInt), _) -> ()
   209:           | _ -> E.s (bug "Type of array length is not integer")
   210:       end)
   211: 
   212:   | TFun (rt, targs, isva, a) ->
   213:       checkAttributes a;
   214:       checkType rt CTFRes;
   215:       List.iter
   216:         (fun (an, at, aa) ->
   217:           checkType at CTFArg;
   218:           checkAttributes aa) (argsToList targs)
   219: 
   220: (* Flx_cil_check that a type is a promoted integral type *)
   221: and checkIntegralType (t: typ) =
   222:   checkType t CTExp;
   223:   match unrollType t with
   224:     TInt _ -> ()
   225:   | _ -> ignore (warn "Non-integral type")
   226: 
   227: (* Flx_cil_check that a type is a promoted arithmetic type *)
   228: and checkArithmeticType (t: typ) =
   229:   checkType t CTExp;
   230:   match unrollType t with
   231:     TInt _ | TFloat _ -> ()
   232:   | _ -> ignore (warn "Non-arithmetic type")
   233: 
   234: (* Flx_cil_check that a type is a promoted boolean type *)
   235: and checkBooleanType (t: typ) =
   236:   checkType t CTExp;
   237:   match unrollType t with
   238:     TInt _ | TFloat _ | TPtr _ -> ()
   239:   | _ -> ignore (warn "Non-boolean type")
   240: 
   241: 
   242: (* Flx_cil_check that a type is a pointer type *)
   243: and checkPointerType (t: typ) =
   244:   checkType t CTExp;
   245:   match unrollType t with
   246:     TPtr _ -> ()
   247:   | _ -> ignore (warn "Non-pointer type")
   248: 
   249: 
   250: and typeMatch (t1: typ) (t2: typ) =
   251:   if typeSig t1 <> typeSig t2 then
   252:     match unrollType t1, unrollType t2 with
   253:     (* Allow free interchange of TInt and TEnum *)
   254:       TInt (IInt, _), TEnum _ -> ()
   255:     | TEnum _, TInt (IInt, _) -> ()
   256: 
   257:     | _, _ -> ignore (warn "Type mismatch:@!    %a@!and %a@!"
   258:                         d_type t1 d_type t2)
   259: 
   260: and checkCompInfo (isadef: defuse) comp =
   261:   let fullname = compFullName comp in
   262:   try
   263:     let oldci, olddef = H.find compUsed comp.ckey in
   264:     (* Flx_cil_check that it is the same *)
   265:     if oldci != comp then
   266:       ignore (warnContext "compinfo for %s not shared\n" fullname);
   267:     (match !olddef, isadef with
   268:     | Defined, Defined ->
   269:         ignore (warnContext "Multiple definition of %s\n" fullname)
   270:     | _, Defined -> olddef := Defined
   271:     | Defined, _ -> ()
   272:     | _, Forward -> olddef := Forward
   273:     | _, _ -> ())
   274:   with Not_found -> begin (* This is the first time we see it *)
   275:     (* Flx_cil_check that the name is not empty *)
   276:     if comp.cname = "" then
   277:       E.s (bug "Compinfo with empty name");
   278:     (* Flx_cil_check that the name is unique *)
   279:     if H.mem compNames fullname then
   280:       ignore (warn "Duplicate name %s" fullname);
   281:     (* Add it to the map before we go on *)
   282:     H.add compUsed comp.ckey (comp, ref isadef);
   283:     H.add compNames fullname ();
   284:     (* Do not check the compinfo unless this is a definition. Otherwise you
   285:      * might run into undefined types. *)
   286:     if isadef = Defined then begin
   287:       checkAttributes comp.cattr;
   288:       let fctx = if comp.cstruct then CTStruct else CTUnion in
   289:       let rec checkField f =
   290:         if not
   291:             (f.fcomp == comp &&  (* Each field must share the self cell of
   292:              * the host *)
   293:              f.fname <> "") then
   294:           ignore (warn "Self pointer not set in field %s of %s"
   295:                     f.fname fullname);
   296:         checkType f.ftype fctx;
   297:         (* Flx_cil_check the bitfields *)
   298:         (match unrollType f.ftype, f.fbitfield with
   299:         | TInt (ik, a), Some w ->
   300:             checkAttributes a;
   301:             if w < 0 || w >= bitsSizeOf (TInt(ik, a)) then
   302:               ignore (warn "Wrong width (%d) in bitfield" w)
   303:         | _, Some w ->
   304:             ignore (E.error "Bitfield on a non integer type\n")
   305:         | _ -> ());
   306:         checkAttributes f.fattr
   307:       in
   308:       List.iter checkField comp.cfields
   309:     end
   310:   end
   311: 
   312: 
   313: and checkEnumInfo (isadef: defuse) enum =
   314:   if enum.ename = "" then
   315:     E.s (bug "Enuminfo with empty name");
   316:   try
   317:     let oldei, olddef = H.find enumUsed enum.ename in
   318:     (* Flx_cil_check that it is the same *)
   319:     if oldei != enum then
   320:       ignore (warnContext "enuminfo for %s not shared\n" enum.ename);
   321:     (match !olddef, isadef with
   322:       Defined, Defined ->
   323:         ignore (warnContext "Multiple definition of enum %s\n" enum.ename)
   324:     | _, Defined -> olddef := Defined
   325:     | Defined, _ -> ()
   326:     | _, Forward -> olddef := Forward
   327:     | _, _ -> ())
   328:   with Not_found -> begin (* This is the first time we see it *)
   329:     (* Add it to the map before we go on *)
   330:     H.add enumUsed enum.ename (enum, ref isadef);
   331:     checkAttributes enum.eattr;
   332:     List.iter (fun (tn, _, _) -> defineName tn) enum.eitems;
   333:   end
   334: 
   335: and checkTypeInfo (isadef: defuse) ti =
   336:   try
   337:     let oldti, olddef = H.find typUsed ti.tname in
   338:     (* Flx_cil_check that it is the same *)
   339:     if oldti != ti then
   340:       ignore (warnContext "typeinfo for %s not shared\n" ti.tname);
   341:     (match !olddef, isadef with
   342:       Defined, Defined ->
   343:         ignore (warnContext "Multiple definition of type %s\n" ti.tname)
   344:     | Defined, Used -> ()
   345:     | Used, Defined ->
   346:         ignore (warnContext "Use of type %s before its definition\n" ti.tname)
   347:     | _, _ ->
   348:         ignore (warnContext "Bug in checkTypeInfo for %s\n" ti.tname))
   349:   with Not_found -> begin (* This is the first time we see it *)
   350:     if ti.tname = "" then
   351:       ignore (warnContext "typeinfo with empty name");
   352:     checkType ti.ttype CTDecl;
   353:     (* Add it to the map before we go on *)
   354:     H.add typUsed ti.tname (ti, ref isadef);
   355:   end
   356: 
   357: (* Flx_cil_check an lvalue. If isconst then the lvalue appears in a context where
   358:  * only a compile-time constant can appear. Return the type of the lvalue.
   359:  * See the typing rule from cil.mli *)
   360: and checkLval (isconst: bool) (lv: lval) : typ =
   361:   match lv with
   362:     Var vi, off ->
   363:       checkVariable vi;
   364:       checkOffset vi.vtype off
   365: 
   366:   | Mem addr, off -> begin
   367:       if isconst then
   368:         ignore (warn "Memory operation in constant");
   369:       let ta = checkExp false addr in
   370:       match unrollType ta with
   371:         TPtr (t, _) -> checkOffset t off
   372:       | _ -> E.s (bug "Mem on a non-pointer")
   373:   end
   374: 
   375: (* Flx_cil_check an offset. The basetype is the type of the object referenced by the
   376:  * base. Return the type of the lvalue constructed from a base value of right
   377:  * type and the offset. See the typing rules from cil.mli *)
   378: and checkOffset basetyp : offset -> typ = function
   379:     NoOffset -> basetyp
   380:   | Index (ei, o) ->
   381:       checkExpType false ei intType;
   382:       begin
   383:         match unrollType basetyp with
   384:           TArray (t, _, _) -> checkOffset t o
   385:         | t -> E.s (bug "typeOffset: Index on a non-array: %a" d_plaintype t)
   386:       end
   387: 
   388:   | Field (fi, o) ->
   389:       (* Now check that the host is shared propertly *)
   390:       checkCompInfo Used fi.fcomp;
   391:       (* Flx_cil_check that this exact field is part of the host *)
   392:       if not (List.exists (fun f -> f == fi) fi.fcomp.cfields) then
   393:         ignore (warn "Field %s not part of %s"
   394:                   fi.fname (compFullName fi.fcomp));
   395:       checkOffset fi.ftype o
   396: 
   397: and checkExpType (isconst: bool) (e: exp) (t: typ) =
   398:   let t' = checkExp isconst e in (* compute the type *)
   399:   if isconst then begin (* For initializers allow a string to initialize an
   400:                          * array of characters  *)
   401:     if typeSig t' <> typeSig t then
   402:       match e, t with
   403:       | _ -> typeMatch t' t
   404:   end else
   405:     typeMatch t' t
   406: 
   407: (* Flx_cil_check an expression. isconst specifies if the expression occurs in a
   408:  * context where only a compile-time constant can occur. Return the computed
   409:  * type of the expression *)
   410: and checkExp (isconst: bool) (e: exp) : typ =
   411:   E.withContext
   412:     (fun _ -> dprintf "check%s: %a"
   413:         (if isconst then "Const" else "Exp") d_exp e)
   414:     (fun _ ->
   415:       match e with
   416:       | Const(CInt64 (_, ik, _)) -> TInt(ik, [])
   417:       | Const(CChr _) -> charType
   418:       | Const(CStr s) -> charPtrType
   419:       | Const(CWStr s) -> TPtr(!wcharType,[])
   420:       | Const(CReal (_, fk, _)) -> TFloat(fk, [])
   421:       | Lval(lv) ->
   422:           if isconst then
   423:             ignore (warn "Lval in constant");
   424:           checkLval isconst lv
   425: 
   426:       | SizeOf(t) -> begin
   427:           (* Sizeof cannot be applied to certain types *)
   428:           checkType t CTSizeof;
   429:           (match unrollType t with
   430:             (TFun _ | TVoid _) ->
   431:               ignore (warn "Invalid operand for sizeof")
   432:           | _ ->());
   433:           uintType
   434:       end
   435:       | SizeOfE(e) ->
   436:           (* The expression in a sizeof can be anything *)
   437:           let te = checkExp false e in
   438:           checkExp isconst (SizeOf(te))
   439: 
   440:       | SizeOfStr s -> uintType
   441: 
   442:       | AlignOf(t) -> begin
   443:           (* Sizeof cannot be applied to certain types *)
   444:           checkType t CTSizeof;
   445:           (match unrollType t with
   446:             (TFun _ | TVoid _) ->
   447:               ignore (warn "Invalid operand for sizeof")
   448:           | _ ->());
   449:           uintType
   450:       end
   451:       | AlignOfE(e) ->
   452:           (* The expression in an AlignOfE can be anything *)
   453:           let te = checkExp false e in
   454:           checkExp isconst (AlignOf(te))
   455: 
   456:       | UnOp (Neg, e, tres) ->
   457:           checkArithmeticType tres; checkExpType isconst e tres; tres
   458: 
   459:       | UnOp (BNot, e, tres) ->
   460:           checkIntegralType tres; checkExpType isconst e tres; tres
   461: 
   462:       | UnOp (LNot, e, tres) ->
   463:           let te = checkExp isconst e in
   464:           checkBooleanType te;
   465:           checkIntegralType tres; (* Must check that t is well-formed *)
   466:           typeMatch tres intType;
   467:           tres
   468: 
   469:       | BinOp (bop, e1, e2, tres) -> begin
   470:           let t1 = checkExp isconst e1 in
   471:           let t2 = checkExp isconst e2 in
   472:           match bop with
   473:             (Mult | Div) ->
   474:               typeMatch t1 t2; checkArithmeticType tres;
   475:               typeMatch t1 tres; tres
   476:           | (Eq|Ne|Lt|Le|Ge|Gt) ->
   477:               typeMatch t1 t2; checkArithmeticType t1;
   478:               typeMatch tres intType; tres
   479:           | Mod|BAnd|BOr|BXor ->
   480:               typeMatch t1 t2; checkIntegralType tres;
   481:               typeMatch t1 tres; tres
   482:           | LAnd | LOr ->
   483:               typeMatch t1 t2; checkBooleanType tres;
   484:               typeMatch t1 tres; tres
   485:           | Shiftlt | Shiftrt ->
   486:               typeMatch t1 tres; checkIntegralType t1;
   487:               checkIntegralType t2; tres
   488:           | (PlusA | MinusA) ->
   489:                 typeMatch t1 t2; typeMatch t1 tres;
   490:                 checkArithmeticType tres; tres
   491:           | (PlusPI | MinusPI | IndexPI) ->
   492:               checkPointerType tres;
   493:               typeMatch t1 tres;
   494:               checkIntegralType t2;
   495:               tres
   496:           | MinusPP  ->
   497:               checkPointerType t1; checkPointerType t2;
   498:               typeMatch t1 t2;
   499:               typeMatch tres intType;
   500:               tres
   501:       end
   502:       | AddrOf (lv) -> begin
   503:           let tlv = checkLval isconst lv in
   504:           (* Only certain types can be in AddrOf *)
   505:           match unrollType tlv with
   506:           | TVoid _ ->
   507:               E.s (bug "AddrOf on improper type");
   508: 
   509:           | (TInt _ | TFloat _ | TPtr _ | TComp _ | TFun _ | TArray _ ) ->
   510:               TPtr(tlv, [])
   511: 
   512:           | TEnum _ -> intPtrType
   513:           | _ -> E.s (bug "AddrOf on unknown type")
   514:       end
   515: 
   516:       | StartOf lv -> begin
   517:           let tlv = checkLval isconst lv in
   518:           match unrollType tlv with
   519:             TArray (t,_, _) -> TPtr(t, [])
   520:           | _ -> E.s (bug "StartOf on a non-array")
   521:       end
   522: 
   523:       | CastE (tres, e) -> begin
   524:           let et = checkExp isconst e in
   525:           checkType tres CTExp;
   526:           (* Not all types can be cast *)
   527:           match unrollType et with
   528:             TArray _ -> E.s (bug "Cast of an array type")
   529:           | TFun _ -> E.s (bug "Cast of a function type")
   530:           | TComp _ -> E.s (bug "Cast of a composite type")
   531:           | TVoid _ -> E.s (bug "Cast of a void type")
   532:           | _ -> tres
   533:       end)
   534:     () (* The argument of withContext *)
   535: 
   536: and checkInit  (i: init) : typ =
   537:   E.withContext
   538:     (fun _ -> dprintf "checkInit: %a" d_init i)
   539:     (fun _ ->
   540:       match i with
   541:         SingleInit e -> checkExp true e
   542: (*
   543:       | ArrayInit (bt, len, initl) -> begin
   544:           checkType bt CTSizeof;
   545:           if List.length initl > len then
   546:             ignore (warn "Too many initializers in array");
   547:           List.iter (fun i -> checkInitType i bt) initl;
   548:           TArray(bt, Some (integer len), [])
   549:       end
   550: *)
   551:       | CompoundInit (ct, initl) -> begin
   552:           checkType ct CTSizeof;
   553:           (match unrollType ct with
   554:             TArray(bt, Some (Const(CInt64(len, _, _))), _) ->
   555:               let rec loopIndex i = function
   556:                   [] ->
   557:                     if i <> len then
   558:                       ignore (warn "Wrong number of initializers in array")
   559: 
   560:                 | (Index(Const(CInt64(i', _, _)), NoOffset), ei) :: rest ->
   561:                     if i' <> i then
   562:                       ignore (warn "Initializer for index %s when %s was expected\n"
   563:                                 (Int64.format "%d" i') (Int64.format "%d" i));
   564:                     checkInitType ei bt;
   565:                     loopIndex (Int64.succ i) rest
   566:                 | _ :: rest ->
   567:                     ignore (warn "Malformed initializer for array element")
   568:               in
   569:               loopIndex Int64.zero initl
   570:           | TArray(_, _, _) ->
   571:               ignore (warn "Malformed initializer for array")
   572:           | TComp (comp, _) ->
   573:               if comp.cstruct then
   574:                 let rec loopFields
   575:                     (nextflds: fieldinfo list)
   576:                     (initl: (offset * init) list) : unit =
   577:                   match nextflds, initl with
   578:                     [], [] -> ()   (* We are done *)
   579:                   | f :: restf, (Field(f', NoOffset), i) :: resti ->
   580:                       if f.fname <> f'.fname then
   581:                         ignore (warn "Expected initializer for field %s and found one for %s\n" f.fname f'.fname);
   582:                       checkInitType i f.ftype;
   583:                       loopFields restf resti
   584:                   | [], _ :: _ ->
   585:                       ignore (warn "Too many initializers for struct")
   586:                   | _ :: _, [] ->
   587:                       ignore (warn "Too few initializers for struct")
   588:                   | _, _ ->
   589:                       ignore (warn "Malformed initializer for struct")
   590:                 in
   591:                 loopFields
   592:                   (List.filter (fun f -> f.fname <> missingFieldName)
   593:                      comp.cfields)
   594:                   initl
   595: 
   596:               else (* UNION *)
   597:                 if comp.cfields == [] then begin
   598:                   if initl != [] then
   599:                     ignore (warn "Initializer for empty union not empty");
   600:                 end else begin
   601:                   match initl with
   602:                     [(Field(f, NoOffset), ei)] ->
   603:                       if f.fcomp != comp then
   604:                         ignore (bug "Wrong designator for union initializer");
   605:                       if !msvcMode && f != List.hd comp.cfields then
   606:                         ignore (warn "On MSVC you can only initialize the first field of a union");
   607:                       checkInitType ei f.ftype
   608: 
   609:                   | _ ->
   610:                       ignore (warn "Malformed initializer for union")
   611:                 end
   612:           | _ ->
   613:               E.s (warn "Type of Compound is not array or struct or union"));
   614:           ct
   615:       end)
   616:     () (* The arguments of withContext *)
   617: 
   618: 
   619: and checkInitType (i: init) (t: typ) : unit =
   620:   let it = checkInit i in
   621:   typeMatch it t
   622: 
   623: and checkStmt (s: stmt) =
   624:   E.withContext
   625:     (fun _ ->
   626:       (* Print context only for certain small statements *)
   627:       match s.skind with
   628:         Loop _ | If _ | Switch _  -> nil
   629:       | _ -> dprintf "checkStmt: %a" d_stmt s)
   630:     (fun _ ->
   631:       (* Flx_cil_check the labels *)
   632:       let checkLabel = function
   633:           Label (ln, l, _) ->
   634:             if H.mem labels ln then
   635:               ignore (warn "Multiply defined label %s" ln);
   636:             H.add labels ln ()
   637:         | Case (e, _) -> checkExpType true e intType
   638:         | _ -> () (* Not yet implemented *)
   639:       in
   640:       List.iter checkLabel s.labels;
   641:       (* See if we have seen this statement before *)
   642:       if List.memq s !statements then
   643:         ignore (warn "Statement is shared");
   644:       (* Remember that we have seen this one *)
   645:       statements := s :: !statements;
   646:       match s.skind with
   647:         Break _ | Continue _ -> ()
   648:       | Goto (gref, l) ->
   649:           currentLoc := l;
   650:           (* Find a label *)
   651:           let lab =
   652:             match List.filter (function Label _ -> true | _ -> false)
   653:                   !gref.labels with
   654:               Label (lab, _, _) :: _ -> lab
   655:             | _ ->
   656:                 ignore (warn "Goto to block without a label\n");
   657:                 "<missing label>"
   658:           in
   659:           (* Remember it as a target *)
   660:           gotoTargets := (lab, !gref) :: !gotoTargets
   661: 
   662: 
   663:       | Return (re,l) -> begin
   664:           currentLoc := l;
   665:           match re, !currentReturnType with
   666:             None, TVoid _  -> ()
   667:           | _, TVoid _ -> ignore (warn "Invalid return value")
   668:           | None, _ -> ignore (warn "Invalid return value")
   669:           | Some re', rt' -> checkExpType false re' rt'
   670:         end
   671:       | Loop (b, l, _, _) -> checkBlock b
   672:       | Block b -> checkBlock b
   673:       | If (e, bt, bf, l) ->
   674:           currentLoc := l;
   675:           let te = checkExp false e in
   676:           checkBooleanType te;
   677:           checkBlock bt;
   678:           checkBlock bf
   679:       | Switch (e, b, cases, l) ->
   680:           currentLoc := l;
   681:           checkExpType false e intType;
   682:           (* Remember the statements so far *)
   683:           let prevStatements = !statements in
   684:           checkBlock b;
   685:           (* Now make sure that all the cases do occur in that block *)
   686:           List.iter
   687:             (fun c ->
   688:               if not (List.exists (function Case _ -> true | _ -> false)
   689:                         c.labels) then
   690:                 ignore (warn "Case in switch statment without a \"case\"\n");
   691:               (* Make sure it is in there *)
   692:               let rec findCase = function
   693:                 | l when l == prevStatements -> (* Not found *)
   694:                     ignore (warnContext
   695:                               "Cannot find target of switch statement")
   696:                 | [] -> E.s (E.bug "Flx_cil_check: findCase")
   697:                 | c' :: rest when c == c' -> () (* Found *)
   698:                 | _ :: rest -> findCase rest
   699:               in
   700:               findCase !statements)
   701:             cases;
   702:       | TryFinally (b, h, l) ->
   703:           currentLoc := l;
   704:           checkBlock b;
   705:           checkBlock h
   706: 
   707:       | TryExcept (b, (il, e), h, l) ->
   708:           currentLoc := l;
   709:           checkBlock b;
   710:           List.iter checkInstr il;
   711:           checkExpType false e intType;
   712:           checkBlock h
   713: 
   714:       | Instr il -> List.iter checkInstr il)
   715:     () (* argument of withContext *)
   716: 
   717: and checkBlock (b: block) : unit =
   718:   List.iter checkStmt b.bstmts
   719: 
   720: 
   721: and checkInstr (i: instr) =
   722:   match i with
   723:   | Set (dest, e, l) ->
   724:       currentLoc := l;
   725:       let t = checkLval false dest in
   726:       (* Not all types can be assigned to *)
   727:       (match unrollType t with
   728:         TFun _ -> ignore (warn "Assignment to a function type")
   729:       | TArray _ -> ignore (warn "Assignment to an array type")
   730:       | TVoid _ -> ignore (warn "Assignment to a void type")
   731:       | _ -> ());
   732:       checkExpType false e t
   733: 
   734:   | Call(dest, what, args, l) ->
   735:       currentLoc := l;
   736:       let (rt, formals, isva) =
   737:         match checkExp false what with
   738:           TFun(rt, formals, isva, _) -> rt, formals, isva
   739:         | _ -> E.s (bug "Call to a non-function")
   740:       in
   741:           (* Now check the return value*)
   742:       (match dest, unrollType rt with
   743:         None, TVoid _ -> ()
   744:       | Some _, TVoid _ -> ignore (warn "void value is assigned")
   745:       | None, _ -> () (* "Call of function is not assigned" *)
   746:       | Some destlv, rt' ->
   747:           let desttyp = checkLval false destlv in
   748:           if typeSig desttyp <> typeSig rt then begin
   749:             (* Not all types can be assigned to *)
   750:             (match unrollType desttyp with
   751:               TFun _ -> ignore (warn "Assignment to a function type")
   752:             | TArray _ -> ignore (warn "Assignment to an array type")
   753:             | TVoid _ -> ignore (warn "Assignment to a void type")
   754:             | _ -> ());
   755:             (* Not all types can be cast *)
   756:             (match rt' with
   757:               TArray _ -> ignore (warn "Cast of an array type")
   758:             | TFun _ -> ignore (warn "Cast of a function type")
   759:             | TComp _ -> ignore (warn "Cast of a composite type")
   760:             | TVoid _ -> ignore (warn "Cast of a void type")
   761: 
   762:             | _ -> ())
   763:           end);
   764:           (* Now check the arguments *)
   765:       let rec loopArgs formals args =
   766:         match formals, args with
   767:           [], _ when (isva || args = []) -> ()
   768:         | (fn,ft,_) :: formals, a :: args ->
   769:             checkExpType false a ft;
   770:             loopArgs formals args
   771:         | _, _ -> ignore (warn "Not enough arguments")
   772:       in
   773:       if formals = None then
   774:         ignore (warn "Call to function without prototype\n")
   775:       else
   776:         loopArgs (argsToList formals) args
   777: 
   778:   | Asm _ -> ()  (* Not yet implemented *)
   779: 
   780: let rec checkGlobal = function
   781:     GAsm _ -> ()
   782:   | GPragma _ -> ()
   783:   | GText _ -> ()
   784:   | GType (ti, l) ->
   785:       currentLoc := l;
   786:       E.withContext (fun _ -> dprintf "GType(%s)" ti.tname)
   787:         (fun _ ->
   788:           checkTypeInfo Defined ti;
   789:           if ti.tname <> "" then defineName ti.tname)
   790:         ()
   791: 
   792:   | GCompTag (comp, l) ->
   793:       currentLoc := l;
   794:       checkCompInfo Defined comp;
   795: 
   796:   | GCompTagDecl (comp, l) ->
   797:       currentLoc := l;
   798:       checkCompInfo Forward comp;
   799: 
   800:   | GEnumTag (enum, l) ->
   801:       currentLoc := l;
   802:       checkEnumInfo Defined enum
   803: 
   804:   | GEnumTagDecl (enum, l) ->
   805:       currentLoc := l;
   806:       checkEnumInfo Forward enum
   807: 
   808:   | GVarDecl (vi, l) ->
   809:       currentLoc := l;
   810:       (* We might have seen it already *)
   811:       E.withContext (fun _ -> dprintf "GVarDecl(%s)" vi.vname)
   812:         (fun _ ->
   813:           (* If we have seen this vid already then it must be for the exact
   814:            * same varinfo *)
   815:           if H.mem varIdsEnv vi.vid then
   816:             checkVariable vi
   817:           else begin
   818:             defineVariable vi;
   819:             checkAttributes vi.vattr;
   820:             checkType vi.vtype CTDecl;
   821:             if not (vi.vglob &&
   822:                     vi.vstorage <> Register) then
   823:               E.s (bug "Invalid declaration of %s" vi.vname)
   824:           end)
   825:         ()
   826: 
   827:   | GVar (vi, init, l) ->
   828:       currentLoc := l;
   829:       (* Maybe this is the first occurrence *)
   830:       E.withContext (fun _ -> dprintf "GVar(%s)" vi.vname)
   831:         (fun _ ->
   832:           checkGlobal (GVarDecl (vi, l));
   833:           (* Flx_cil_check the initializer *)
   834:           begin match init.init with
   835:             None -> ()
   836:           | Some i -> ignore (checkInitType i vi.vtype)
   837:           end;
   838:           (* Cannot be a function *)
   839:           if isFunctionType vi.vtype then
   840:             E.s (bug "GVar for a function (%s)\n" vi.vname);
   841:           )
   842:         ()
   843: 
   844: 
   845:   | GFun (fd, l) -> begin
   846:       currentLoc := l;
   847:       (* Flx_cil_check if this is the first occurrence *)
   848:       let vi = fd.svar in
   849:       let fname = vi.vname in
   850:       E.withContext (fun _ -> dprintf "GFun(%s)" fname)
   851:         (fun _ ->
   852:           checkGlobal (GVarDecl (vi, l));
   853:           (* Flx_cil_check that the argument types in the type are identical to the
   854:            * formals *)
   855:           let rec loopArgs targs formals =
   856:             match targs, formals with
   857:               [], [] -> ()
   858:             | (fn, ft, fa) :: targs, fo :: formals ->
   859:                 if fn <> fo.vname || ft != fo.vtype || fa != fo.vattr then
   860:                   ignore (warnContext
   861:                             "Formal %s not shared (type + locals) in %s"
   862:                             fo.vname fname);
   863:                 loopArgs targs formals
   864: 
   865:             | _ ->
   866:                 E.s (bug "Type has different number of formals for %s"
   867:                        fname)
   868:           in
   869:           begin match vi.vtype with
   870:             TFun (rt, args, isva, a) -> begin
   871:               currentReturnType := rt;
   872:               loopArgs (argsToList args) fd.sformals
   873:             end
   874:           | _ -> E.s (bug "Function %s does not have a function type"
   875:                         fname)
   876:           end;
   877:           ignore (fd.smaxid >= 0 || E.s (bug "smaxid < 0 for %s" fname));
   878:           (* Now start a new environment, in a finally clause *)
   879:           begin try
   880:             startEnv ();
   881:             (* Do the locals *)
   882:             let doLocal tctx v =
   883:               if v.vglob then
   884:                 ignore (warnContext
   885:                           "Local %s has the vglob flag set" v.vname);
   886:               if v.vstorage <> NoStorage && v.vstorage <> Register then
   887:                 ignore (warnContext
   888:                           "Local %s has storage %a\n" v.vname
   889:                           d_storage v.vstorage);
   890:               checkType v.vtype tctx;
   891:               checkAttributes v.vattr;
   892:               defineVariable v
   893:             in
   894:             List.iter (doLocal CTFArg) fd.sformals;
   895:             List.iter (doLocal CTDecl) fd.slocals;
   896:             statements := [];
   897:             gotoTargets := [];
   898:             checkBlock fd.sbody;
   899:             H.clear labels;
   900:             (* Now verify that we have scanned all targets *)
   901:             List.iter
   902:               (fun (lab, t) -> if not (List.memq t !statements) then
   903:                 ignore (warnContext
   904:                           "Target of \"goto %s\" statement does not appear in function body" lab))
   905:               !gotoTargets;
   906:             statements := [];
   907:             gotoTargets := [];
   908:             (* Done *)
   909:             endEnv ()
   910:           with e ->
   911:             endEnv ();
   912:             raise e
   913:           end;
   914:           ())
   915:         () (* final argument of withContext *)
   916:   end
   917: 
   918: 
   919: let checkFile flags fl =
   920:   if !E.verboseFlag then ignore (E.log "Flx_cil_checking file %s\n" fl.fileName);
   921:   valid := true;
   922:   List.iter
   923:     (function
   924:         NoFlx_cil_checkGlobalIds -> checkGlobalIds := false)
   925:     flags;
   926:   iterGlobals fl (fun g -> try checkGlobal g with _ -> ());
   927:   (* Flx_cil_check that for all struct/union tags there is a definition *)
   928:   H.iter
   929:     (fun k (comp, isadef) ->
   930:       if !isadef = Used then
   931:         begin
   932:           valid := false;
   933:           ignore (E.warn "Compinfo %s is referenced but not defined"
   934:                     (compFullName comp))
   935:         end)
   936:     compUsed;
   937:   (* Flx_cil_check that for all enum tags there is a definition *)
   938:   H.iter
   939:     (fun k (enum, isadef) ->
   940:       if !isadef = Used then
   941:         begin
   942:           valid := false;
   943:           ignore (E.warn "Enuminfo %s is referenced but not defined"
   944:                     enum.ename)
   945:         end)
   946:     enumUsed;
   947:   (* Clean the hashes to let the GC do its job *)
   948:   H.clear typeDefs;
   949:   H.clear varNamesEnv;
   950:   H.clear varIdsEnv;
   951:   H.clear allVarIds;
   952:   H.clear compNames;
   953:   H.clear compUsed;
   954:   H.clear enumUsed;
   955:   H.clear typUsed;
   956:   varNamesList := [];
   957:   if !E.verboseFlag then
   958:     ignore (E.log "Finished checking file %s\n" fl.fileName);
   959:   !valid
   960: 
End ocaml section to src/flx_cil_check.ml[1]
Start ocaml section to src/flx_cil_check.mli[1 /1 ]
     1: # 1120 "./lpsrc/flx_cil.ipk"
     2: 
     3:     (* Flx_cil_checks the well-formedness of the file. Prints warnings and
     4:      * returns false if errors are found *)
     5: 
     6: type checkFlags =
     7:     NoFlx_cil_checkGlobalIds   (* Do not check that the global ids have the proper
     8:                         * hash value *)
     9: 
    10: val checkFile: checkFlags list -> Flx_cil_cil.file -> bool
End ocaml section to src/flx_cil_check.mli[1]
Start ocaml section to src/flx_cil_cil.ml[1 /1 ]
     1: # 1131 "./lpsrc/flx_cil.ipk"
     2: 
     3: open Flx_cil_escape
     4: open Flx_cil_pretty
     5: open Flx_cil_trace      (* sm: 'trace' function *)
     6: open Flx_cil_machdep_type
     7: module E = Flx_cil_errormsg
     8: module H = Hashtbl
     9: 
    10: (*
    11:  * CIL: An intermediate language for analyzing C progams.
    12:  *
    13:  * Version Tue Dec 12 15:21:52 PST 2000
    14:  * Scott McPeak, George Necula, Wes Weimer
    15:  *
    16:  *)
    17: 
    18: 
    19: module M = Flx_cil_machdep
    20: 
    21: (* The module Flx_cil_cilversion is generated automatically by Makefile from
    22:  * information in configure.in *)
    23: let cilVersion         = Flx_cil_cilversion.cilVersion
    24: let cilVersionMajor    = Flx_cil_cilversion.cilVersionMajor
    25: let cilVersionMinor    = Flx_cil_cilversion.cilVersionMinor
    26: let cilVersionRevision = Flx_cil_cilversion.cilVersionRev
    27: 
    28: (* A few globals that control the interpretation of C source *)
    29: let msvcMode = ref false              (* Whether the pretty printer should
    30:                                        * print output for the MS VC
    31:                                        * compiler. Default is GCC *)
    32: 
    33: let useLogicalOperators = ref false
    34: 
    35: (* Flx_cil_cil.initFlx_cil_cil will set this to the current machine description *)
    36: let theMachine : Flx_cil_machdep_type.mach ref = ref M.gcc
    37: 
    38: let little_endian = ref true
    39: let char_is_unsigned = ref false
    40: 
    41: type lineDirectiveStyle =
    42:   | LineComment
    43:   | LinePreprocessorInput
    44:   | LinePreprocessorOutput
    45: 
    46: let lineDirectiveStyle = ref (Some LinePreprocessorInput)
    47: 
    48: let print_CIL_Input = ref false
    49: 
    50: let printCilAsIs = ref false
    51: 
    52: (* sm: return the string 's' if we're printing output for gcc, suppres
    53:  * it if we're printing for CIL to parse back in.  the purpose is to
    54:  * hide things from gcc that it complains about, but still be able
    55:  * to do lossless transformations when CIL is the consumer *)
    56: let forgcc (s: string) : string =
    57:   if (!print_CIL_Input) then "" else s
    58: 
    59: 
    60: let debugConstFold = false
    61: 
    62: (** The Abstract Syntax of CIL *)
    63: 
    64: 
    65: (** The top-level representation of a CIL source file. Its main contents is
    66:     the list of global declarations and definitions. *)
    67: type file =
    68:     { mutable fileName: string;   (** The complete file name *)
    69:       mutable globals: global list; (** List of globals as they will appear
    70:                                         in the printed file *)
    71:       mutable globinit: fundec option;
    72:       (** An optional global initializer function. This is a function where
    73:        * you can put stuff that must be executed before the program is
    74:        * started. This function, is conceptually at the end of the file,
    75:        * although it is not part of the globals list. Use {!Flx_cil_cil.getGlobInit}
    76:        * to create/get one. *)
    77:       mutable globinitcalled: bool;
    78:       (** Whether the global initialization function is called in main. This
    79:           should always be false if there is no global initializer. When
    80:           you create a global initialization CIL will try to insert code in
    81:           main to call it. *)
    82:     }
    83: 
    84: 
    85: (** The main type for representing global declarations and definitions. A list
    86:     of these form a CIL file. The order of globals in the file is generally
    87:     important. *)
    88: and global =
    89:   | GType of typeinfo * location
    90:     (** A typedef. All uses of type names (through the [TNamed] constructor)
    91:         must be preceeded in the file by a definition of the name. The string
    92:         is the defined name and always not-empty. *)
    93: 
    94:   | GCompTag of compinfo * location
    95:     (** Defines a struct/union tag with some fields. There must be one of
    96:         these for each struct/union tag that you use (through the [TComp]
    97:         constructor) since this is the only context in which the fields are
    98:         printed. Consequently nested structure tag definitions must be
    99:         broken into individual definitions with the innermost structure
   100:         defined first. *)
   101: 
   102:   | GCompTagDecl of compinfo * location
   103:     (** Declares a struct/union tag. Use as a forward declaration. This is
   104:       * printed without the fields.  *)
   105: 
   106:   | GEnumTag of enuminfo * location
   107:    (** Declares an enumeration tag with some fields. There must be one of
   108:       these for each enumeration tag that you use (through the [TEnum]
   109:       constructor) since this is the only context in which the items are
   110:       printed. *)
   111: 
   112:   | GEnumTagDecl of enuminfo * location
   113:     (** Declares an enumeration tag. Use as a forward declaration. This is
   114:       * printed without the items.  *)
   115: 
   116:   | GVarDecl of varinfo * location
   117:    (** A variable declaration (not a definition). If the variable has a
   118:        function type then this is a prototype. There can be several
   119:        declarations and at most one definition for a given variable. If both
   120:        forms appear then they must share the same varinfo structure. A
   121:        prototype shares the varinfo with the fundec of the definition. Either
   122:        has storage Extern or there must be a definition in this file *)
   123: 
   124:   | GVar  of varinfo * initinfo * location
   125:      (** A variable definition. Can have an initializer. The initializer is
   126:       * updateable so that you can change it without requiring to recreate
   127:       * the list of globals. There can be at most one definition for a
   128:       * variable in an entire program. Cannot have storage Extern or function
   129:       * type. *)
   130: 
   131: 
   132:   | GFun of fundec * location
   133:      (** A function definition. *)
   134: 
   135:   | GAsm of string * location           (** Global asm statement. These ones
   136:                                             can contain only a template *)
   137:   | GPragma of attribute * location     (** Pragmas at top level. Use the same
   138:                                             syntax as attributes *)
   139:   | GText of string                     (** Some text (printed verbatim) at
   140:                                             top level. E.g., this way you can
   141:                                             put comments in the output.  *)
   142: 
   143: 
   144: (** The various types available. Every type is associated with a list of
   145:  * attributes, which are always kept in sorted order. Use {!Flx_cil_cil.addAttribute}
   146:  * and {!Flx_cil_cil.addAttributes} to construct list of attributes. If you want to
   147:  * inspect a type, you should use {!Flx_cil_cil.unrollType} to see through the uses
   148:  * of named types. *)
   149: and typ =
   150:     TVoid of attributes   (** Void type *)
   151:   | TInt of ikind * attributes (** An integer type. The kind specifies
   152:                                        the sign and width. *)
   153:   | TFloat of fkind * attributes (** A floating-point type. The kind
   154:                                          specifies the precision. *)
   155: 
   156:   | TPtr of typ * attributes
   157:            (** Pointer type. *)
   158: 
   159:   | TArray of typ * exp option * attributes
   160:            (** Array type. It indicates the base type and the array length. *)
   161: 
   162:   | TFun of typ * (string * typ * attributes) list option * bool * attributes
   163:           (** Function type. Indicates the type of the result, the name, type
   164:            * and name attributes of the formal arguments ([None] if no
   165:            * arguments were specified, as in a function whose definition or
   166:            * prototype we have not seen; [Some \[\]] means void). Use
   167:            * {!Flx_cil_cil.argsToList} to obtain a list of arguments. The boolean
   168:            * indicates if it is a variable-argument function. If this is the
   169:            * type of a varinfo for which we have a function declaration then
   170:            * the information for the formals must match that in the
   171:            * function's sformals. *)
   172: 
   173:   | TNamed of typeinfo * attributes
   174:           (* The use of a named type. All uses of the same type name must
   175:            * share the typeinfo. Each such type name must be preceeded
   176:            * in the file by a [GType] global. This is printed as just the
   177:            * type name. The actual referred type is not printed here and is
   178:            * carried only to simplify processing. To see through a sequence
   179:            * of named type references, use {!Flx_cil_cil.unrollType}. The attributes
   180:            * are in addition to those given when the type name was defined. *)
   181: 
   182:   | TComp of compinfo * attributes
   183:           (** A reference to a struct or a union type. All references to the
   184:              same struct or union must share the same compinfo among them and
   185:              with a [GCompTag] global that preceeds all uses (except maybe
   186:              those that are pointers to the composite type). The attributes
   187:              given are those pertaining to this use of the type and are in
   188:              addition to the attributes that were given at the definition of
   189:              the type and which are stored in the compinfo.  *)
   190: 
   191:   | TEnum of enuminfo * attributes
   192:            (** A reference to an enumeration type. All such references must
   193:                share the enuminfo among them and with a [GEnumTag] global that
   194:                preceeds all uses. The attributes refer to this use of the
   195:                enumeration and are in addition to the attributes of the
   196:                enumeration itself, which are stored inside the enuminfo  *)
   197: 
   198: 
   199: 
   200:   | TBuiltin_va_list of attributes
   201:             (** This is the same as the gcc's type with the same name *)
   202: 
   203: (** Various kinds of integers *)
   204: and ikind =
   205:   | IBool       (** [_Bool] *)
   206:   | IChar       (** [char] *)
   207:   | ISChar      (** [signed char] *)
   208:   | IUChar      (** [unsigned char] *)
   209:   | IInt        (** [int] *)
   210:   | IUInt       (** [unsigned int] *)
   211:   | IShort      (** [short] *)
   212:   | IUShort     (** [unsigned short] *)
   213:   | ILong       (** [long] *)
   214:   | IULong      (** [unsigned long] *)
   215:   | ILongLong   (** [long long] (or [_int64] on Microsoft Visual C) *)
   216:   | IULongLong  (** [unsigned long long] (or [unsigned _int64] on Microsoft
   217:                     Visual C) *)
   218: 
   219: (** Various kinds of floating-point numbers*)
   220: and fkind =
   221:     FFloat      (** [float] *)
   222:   | FDouble     (** [double] *)
   223:   | FLongDouble (** [long double] *)
   224: 
   225:   | CFloat      (** [_Complex] *)
   226:   | CDouble     (** [double _Complex] *)
   227:   | CLongDouble (** [long double _Complex] *)
   228: 
   229:   | IFloat      (** [_Imaginary] *)
   230:   | IDouble     (** [double _Imaginary] *)
   231:   | ILongDouble (** [long double _Imaginary] *)
   232: 
   233: (** An attribute has a name and some optional parameters *)
   234: and attribute = Attr of string * attrparam list
   235: 
   236: (** Attributes are lists sorted by the attribute name *)
   237: and attributes = attribute list
   238: 
   239: (** The type of parameters in attributes *)
   240: and attrparam =
   241:   | AInt of int                          (** An integer constant *)
   242:   | AStr of string                       (** A string constant *)
   243:   | ACons of string * attrparam list       (** Constructed attributes. These
   244:                                              are printed [foo(a1,a2,...,an)].
   245:                                              The list of parameters can be
   246:                                              empty and in that case the
   247:                                              parentheses are not printed. *)
   248:   | ASizeOf of typ                       (** A way to talk about types *)
   249:   | ASizeOfE of attrparam
   250:   | AAlignOf of typ
   251:   | AAlignOfE of attrparam
   252:   | AUnOp of unop * attrparam
   253:   | ABinOp of binop * attrparam * attrparam
   254:   | ADot of attrparam * string           (** a.foo **)
   255: 
   256: 
   257: (** Information about a composite type (a struct or a union). Use
   258:     {!Flx_cil_cil.mkCompInfo}
   259:     to create non-recursive or (potentially) recursive versions of this. Make
   260:     sure you have a [GCompTag] for each one of these.  *)
   261: and compinfo = {
   262:     mutable cstruct: bool;              (** True if struct, False if union *)
   263:     mutable cname: string;              (** The name. Always non-empty. Use
   264:                                          * {!Flx_cil_cil.compFullName} to get the
   265:                                          * full name of a comp (along with
   266:                                          * the struct or union) *)
   267:     mutable ckey: int;                  (** A unique integer constructed from
   268:                                          * the name. Use {!Hashtbl.hash} on
   269:                                          * the string returned by
   270:                                          * {!Flx_cil_cil.compFullName}. All compinfo
   271:                                          * for a given key are shared. *)
   272:     mutable cfields: fieldinfo list;    (** Information about the fields *)
   273:     mutable cattr:   attributes;        (** The attributes that are defined at
   274:                                             the same time as the composite
   275:                                             type *)
   276:     mutable cdefined: bool;             (** Whether this is a defined
   277:                                          * compinfo. *)
   278:     mutable creferenced: bool;          (** True if used. Initially set to
   279:                                          * false *)
   280:   }
   281: 
   282: (** Information about a struct/union field *)
   283: and fieldinfo = {
   284:     mutable fcomp: compinfo;            (** The compinfo of the host. Note
   285:                                             that this must be shared with the
   286:                                             host since there can be only one
   287:                                             compinfo for a given id *)
   288:     mutable fname: string;              (** The name of the field. Might be
   289:                                          * the value of
   290:                                          * {!Flx_cil_cil.missingFieldName} in which
   291:                                          * case it must be a bitfield and is
   292:                                          * not printed and it does not
   293:                                          * participate in initialization *)
   294:     mutable ftype: typ;                 (** The type *)
   295:     mutable fbitfield: int option;      (** If a bitfield then ftype should be
   296:                                             an integer type *)
   297:     mutable fattr: attributes;          (** The attributes for this field
   298:                                           * (not for its type) *)
   299:     mutable floc: location;             (** The location where this field
   300:                                           * is defined *)
   301:     mutable fstorage: storage;          (** Must be NoStorage or Static,
   302:                                           * indicates nonstatic or static member *)
   303: }
   304: 
   305: 
   306: 
   307: (** Information about an enumeration. This is shared by all references to an
   308:     enumeration. Make sure you have a [GEnumTag] for each of of these.   *)
   309: and enuminfo = {
   310:     mutable ename: string;              (** The name. Always non-empty *)
   311:     mutable eitems: (string * exp * location) list; (** Items with names
   312:                                                       and values. This list
   313:                                                       should be
   314:                                                       non-empty. The item
   315:                                                       values must be
   316:                                                       compile-time
   317:                                                       constants. *)
   318:     mutable eattr: attributes;         (** Attributes *)
   319:     mutable ereferenced: bool;         (** True if used. Initially set to false*)
   320: }
   321: 
   322: (** Information about a defined type *)
   323: and typeinfo = {
   324:     mutable tname: string;
   325:     (** The name. Can be empty only in a [GType] when introducing a composite
   326:      * or enumeration tag. If empty cannot be refered to from the file *)
   327:     mutable ttype: typ;
   328:     (** The actual type. *)
   329:     mutable treferenced: bool;
   330:     (** True if used. Initially set to false*)
   331: }
   332: 
   333: 
   334: (** Information about a variable. These structures are shared by all
   335:  * references to the variable. So, you can change the name easily, for
   336:  * example. Use one of the {!Flx_cil_cil.makeLocalVar}, {!Flx_cil_cil.makeTempVar} or
   337:  * {!Flx_cil_cil.makeGlobalVar} to create instances of this data structure. *)
   338: and varinfo = {
   339:     mutable vname: string;              (** The name of the variable. Cannot
   340:                                           * be empty. *)
   341:     mutable vtype: typ;                 (** The declared type of the
   342:                                           * variable. *)
   343:     mutable vattr: attributes;          (** A list of attributes associated
   344:                                           * with the variable. *)
   345:     mutable vstorage: storage;          (** The storage-class *)
   346:     (* The other fields are not used in varinfo when they appear in the formal
   347:      * argument list in a [TFun] type *)
   348: 
   349: 
   350:     mutable vglob: bool;                (** True if this is a global variable*)
   351: 
   352:     (** Whether this varinfo is for an inline function. *)
   353:     mutable vinline: bool;
   354: 
   355:     mutable vdecl: location;            (** Location of variable declaration *)
   356: 
   357:     mutable vid: int;  (** A unique integer identifier.  *)
   358:     mutable vaddrof: bool;              (** True if the address of this
   359:                                             variable is taken. CIL will set
   360:                                          * these flags when it parses C, but
   361:                                          * you should make sure to set the
   362:                                          * flag whenever your transformation
   363:                                          * create [AddrOf] expression. *)
   364: 
   365:     mutable vreferenced: bool;          (** True if this variable is ever
   366:                                             referenced. This is computed by
   367:                                             [removeUnusedVars]. It is safe to
   368:                                             just initialize this to False *)
   369: }
   370: 
   371: (** Storage-class information *)
   372: and storage =
   373:     | NoStorage                          (** The default storage. Nothing is
   374:                                          * printed  *)
   375:     | Static
   376:     | Register
   377:     | Extern
   378: 
   379: 
   380: (** Expressions (Side-effect free)*)
   381: and exp =
   382:   | Const      of constant              (** Constant *)
   383:   | Lval       of lval                  (** Lvalue *)
   384:   | SizeOf     of typ                   (** sizeof(<type>). Has [unsigned
   385:                                          * int] type (ISO 6.5.3.4). This is
   386:                                          * not turned into a constant because
   387:                                          * some transformations might want to
   388:                                          * change types *)
   389: 
   390:   | SizeOfE    of exp                   (** sizeof(<expression>) *)
   391:   | SizeOfStr  of string
   392:     (** sizeof(string_literal). We separate this case out because this is the
   393:       * only instance in which a string literal should not be treated as
   394:       * having type pointer to character. *)
   395: 
   396:   | AlignOf    of typ                   (** Has [unsigned int] type *)
   397:   | AlignOfE   of exp
   398: 
   399: 
   400:   | UnOp       of unop * exp * typ      (** Unary operation. Includes
   401:                                             the type of the result *)
   402: 
   403:   | BinOp      of binop * exp * exp * typ
   404:                                         (** Binary operation. Includes the
   405:                                             type of the result. The arithemtic
   406:                                             conversions are made  explicit
   407:                                             for the arguments *)
   408:   | CastE      of typ * exp            (** Use {!Flx_cil_cil.mkCast} to make casts *)
   409: 
   410:   | AddrOf     of lval                 (** Always use {!Flx_cil_cil.mkAddrOf} to
   411:                                         * construct one of these. Apply to an
   412:                                         * lvalue of type [T] yields an
   413:                                         * expression of type [TPtr(T)] *)
   414: 
   415:   | StartOf    of lval   (** There is no C correspondent for this. C has
   416:                           * implicit coercions from an array to the address
   417:                           * of the first element. [StartOf] is used in CIL to
   418:                           * simplify type checking and is just an explicit
   419:                           * form of the above mentioned implicit conversion.
   420:                           * It is not printed. Given an lval of type
   421:                           * [TArray(T)] produces an expression of type
   422:                           * [TPtr(T)]. *)
   423: 
   424: 
   425: (** Literal constants *)
   426: and constant =
   427:   | CInt64 of int64 * ikind * string option
   428:                  (** Integer constant. Give the ikind (see ISO9899 6.1.3.2)
   429:                   * and the textual representation, if available. Use
   430:                   * {!Flx_cil_cil.integer} or {!Flx_cil_cil.kinteger} to create these. Watch
   431:                   * out for integers that cannot be represented on 64 bits.
   432:                   * OCAML does not give Overflow exceptions. *)
   433:   | CStr of string (** String constant (of pointer type) *)
   434:   | CWStr of int64 list (** Wide string constant (of type "wchar_t *") *)
   435:   | CChr of char   (** Character constant *)
   436:   | CReal of float * fkind * string option (** Floating point constant. Give
   437:                                                the fkind (see ISO 6.4.4.2) and
   438:                                                also the textual representation,
   439:                                                if available *)
   440: 
   441: (** Unary operators *)
   442: and unop =
   443:     Neg                                 (** Unary minus *)
   444:   | BNot                                (** Bitwise complement (~) *)
   445:   | LNot                                (** Logical Not (!) *)
   446: 
   447: (** Binary operations *)
   448: and binop =
   449:     PlusA                               (** arithmetic + *)
   450:   | PlusPI                              (** pointer + integer *)
   451:   | IndexPI                             (** pointer + integer but only when
   452:                                          * it arises from an expression
   453:                                          * [e\[i\]] when [e] is a pointer and
   454:                                          * not an array. This is semantically
   455:                                          * the same as PlusPI but CCured uses
   456:                                          * this as a hint that the integer is
   457:                                          * probably positive. *)
   458:   | MinusA                              (** arithmetic - *)
   459:   | MinusPI                             (** pointer - integer *)
   460:   | MinusPP                             (** pointer - pointer *)
   461:   | Mult                                (** * *)
   462:   | Div                                 (** / *)
   463:   | Mod                                 (** % *)
   464:   | Shiftlt                             (** shift left *)
   465:   | Shiftrt                             (** shift right *)
   466: 
   467:   | Lt                                  (** <  (arithmetic comparison) *)
   468:   | Gt                                  (** >  (arithmetic comparison) *)
   469:   | Le                                  (** <= (arithmetic comparison) *)
   470:   | Ge                                  (** >  (arithmetic comparison) *)
   471:   | Eq                                  (** == (arithmetic comparison) *)
   472:   | Ne                                  (** != (arithmetic comparison) *)
   473:   | BAnd                                (** bitwise and *)
   474:   | BXor                                (** exclusive-or *)
   475:   | BOr                                 (** inclusive-or *)
   476: 
   477:   | LAnd                                (** logical and *)
   478:   | LOr                                 (** logical or *)
   479: 
   480: 
   481: 
   482: 
   483: (** An lvalue denotes the contents of a range of memory addresses. This range
   484:  * is denoted as a host object along with an offset within the object. The
   485:  * host object can be of two kinds: a local or global variable, or an object
   486:  * whose address is in a pointer expression. We distinguish the two cases so
   487:  * that we can tell quickly whether we are accessing some component of a
   488:  * variable directly or we are accessing a memory location through a pointer.*)
   489: and lval =
   490:     lhost * offset
   491: 
   492: (** The host part of an {!Flx_cil_cil.lval}. *)
   493: and lhost =
   494:   | Var        of varinfo
   495:     (** The host is a variable. *)
   496: 
   497:   | Mem        of exp
   498:     (** The host is an object of type [T] when the expression has pointer
   499:      * [TPtr(T)]. *)
   500: 
   501: 
   502: (** The offset part of an {!Flx_cil_cil.lval}. Each offset can be applied to certain
   503:   * kinds of lvalues and its effect is that it advances the starting address
   504:   * of the lvalue and changes the denoted type, essentially focussing to some
   505:   * smaller lvalue that is contained in the original one. *)
   506: and offset =
   507:   | NoOffset          (** No offset. Can be applied to any lvalue and does
   508:                         * not change either the starting address or the type.
   509:                         * This is used when the lval consists of just a host
   510:                         * or as a terminator in a list of other kinds of
   511:                         * offsets. *)
   512: 
   513:   | Field      of fieldinfo * offset
   514:                       (** A field offset. Can be applied only to an lvalue
   515:                        * that denotes a structure or a union that contains
   516:                        * the mentioned field. This advances the offset to the
   517:                        * beginning of the mentioned field and changes the
   518:                        * type to the type of the mentioned field. *)
   519: 
   520:   | Index    of exp * offset
   521:                      (** An array index offset. Can be applied only to an
   522:                        * lvalue that denotes an array. This advances the
   523:                        * starting address of the lval to the beginning of the
   524:                        * mentioned array element and changes the denoted type
   525:                        * to be the type of the array element *)
   526: 
   527: 
   528: 
   529: (* The following equivalences hold *)
   530: (* Mem(AddrOf(Mem a, aoff)), off   = Mem a, aoff + off                *)
   531: (* Mem(AddrOf(Var v, aoff)), off   = Var v, aoff + off                *)
   532: (* AddrOf (Mem a, NoOffset)        = a                                *)
   533: 
   534: (** Initializers for global variables.  You can create an initializer with
   535:  * {!Flx_cil_cil.makeZeroInit}. *)
   536: and init =
   537:   | SingleInit   of exp   (** A single initializer *)
   538:   | CompoundInit   of typ * (offset * init) list
   539:             (** Used only for initializers of structures, unions and arrays.
   540:              * The offsets are all of the form [Field(f, NoOffset)] or
   541:              * [Index(i, NoOffset)] and specify the field or the index being
   542:              * initialized. For structures all fields
   543:              * must have an initializer (except the unnamed bitfields), in
   544:              * the proper order. This is necessary since the offsets are not
   545:              * printed. For arrays the list must contain a prefix of the
   546:              * initializers; the rest are 0-initialized.
   547:              * For unions there must be exactly one initializer. If
   548:              * the initializer is not for the first field then a field
   549:              * designator is printed, so you better be on GCC since MSVC does
   550:              * not understand this. You can scan an initializer list with
   551:              * {!Flx_cil_cil.foldLeftCompound}. *)
   552: 
   553: (** We want to be able to update an initializer in a global variable, so we
   554:  * define it as a mutable field *)
   555: and initinfo = {
   556:     mutable init : init option;
   557:   }
   558: 
   559: 
   560: (** Function definitions. *)
   561: and fundec =
   562:     { mutable svar:     varinfo;
   563:          (** Holds the name and type as a variable, so we can refer to it
   564:           * easily from the program. All references to this function either
   565:           * in a function call or in a prototype must point to the same
   566:           * varinfo. *)
   567:       mutable sformals: varinfo list;
   568:         (** Formals. These must be shared with the formals that appear in the
   569:          * type of the function. Use {!Flx_cil_cil.setFormals} or
   570:          * {!Flx_cil_cil.setFunctionType} to set these
   571:          * formals and ensure that they are reflected in the function type.
   572:          * Do not make copies of these because the body refers to them. *)
   573:       mutable slocals: varinfo list;
   574:         (** Locals. Does not include the sformals. Do not make copies of
   575:          * these because the body refers to them. *)
   576:       mutable smaxid: int;           (** Max local id. Starts at 0. *)
   577:       mutable sbody: block;          (** The function body. *)
   578:       mutable smaxstmtid: int option;  (** max id of a (reachable) statement
   579:                                         * in this function, if we have
   580:                                         * computed it. range = 0 ...
   581:                                         * (smaxstmtid-1) *)
   582:     }
   583: 
   584: 
   585: (** A block is a sequence of statements with the control falling through from
   586:     one element to the next *)
   587: and block =
   588:    { mutable battrs: attributes;      (** Attributes for the block *)
   589:      mutable bstmts: stmt list;       (** The statements comprising the block*)
   590:    }
   591: 
   592: 
   593: (** Statements.
   594:     The statement is the structural unit in the control flow graph. Use mkStmt
   595:     to make a statement and then fill in the fields. *)
   596: and stmt = {
   597:     mutable labels: label list;        (** Whether the statement starts with
   598:                                            some labels, case statements or
   599:                                            default statement *)
   600:     mutable skind: stmtkind;           (** The kind of statement *)
   601: 
   602:     (* Now some additional control flow information. Initially this is not
   603:      * filled in. *)
   604:     mutable sid: int;                  (** A number (>= 0) that is unique
   605:                                            in a function. *)
   606:     mutable succs: stmt list;          (** The successor statements. They can
   607:                                            always be computed from the skind
   608:                                            and the context in which this
   609:                                            statement appears *)
   610:     mutable preds: stmt list;          (** The inverse of the succs function*)
   611:   }
   612: 
   613: (** Labels *)
   614: and label =
   615:     Label of string * location * bool
   616:           (** A real label. If the bool is "true", the label is from the
   617:            * input source program. If the bool is "false", the label was
   618:            * created by CIL or some other transformation *)
   619:   | Case of exp * location              (** A case statement *)
   620:   | Default of location                 (** A default statement *)
   621: 
   622: 
   623: 
   624: (* The various kinds of statements *)
   625: and stmtkind =
   626:   | Instr  of instr list               (** A group of instructions that do not
   627:                                            contain control flow. Control
   628:                                            implicitly falls through. *)
   629:   | Return of exp option * location     (** The return statement. This is a
   630:                                             leaf in the CFG. *)
   631: 
   632:   | Goto of stmt ref * location         (** A goto statement. Appears from
   633:                                             actual goto's in the code. *)
   634:   | Break of location                   (** A break to the end of the nearest
   635:                                              enclosing Loop or Switch *)
   636:   | Continue of location                (** A continue to the start of the
   637:                                             nearest enclosing [Loop] *)
   638:   | If of exp * block * block * location (** A conditional.
   639:                                              Two successors, the "then" and
   640:                                              the "else" branches. Both
   641:                                              branches  fall-through to the
   642:                                              successor of the If statement *)
   643:   | Switch of exp * block * (stmt list) * location
   644:                                        (** A switch statement. The block
   645:                                            contains within all of the cases.
   646:                                            We also have direct pointers to the
   647:                                            statements that implement the
   648:                                            cases. Which cases they implement
   649:                                            you can get from the labels of the
   650:                                            statement *)
   651: 
   652:   | Loop of block * location * (stmt option) * (stmt option)
   653:                                         (** A [while(1)] loop *)
   654: 
   655:   | Block of block                      (** Just a block of statements. Use it
   656:                                             as a way to keep some attributes
   657:                                             local *)
   658:     (** On MSVC we support structured exception handling. This is what you
   659:      * might expect. Control can get into the finally block either from the
   660:      * end of the body block, or if an exception is thrown. The location
   661:      * corresponds to the try keyword. *)
   662:   | TryFinally of block * block * location
   663: 
   664:     (** On MSVC we support structured exception handling. The try/except
   665:      * statement is a bit tricky:
   666:          __try { blk }
   667:          __except (e) {
   668:             handler
   669:          }
   670: 
   671:          The argument to __except  must be an expression. However, we keep a
   672:          list of instructions AND an expression in case you need to make
   673:          function calls. We'll print those as a comma expression. The control
   674:          can get to the __except expression only if an exception is thrown.
   675:          After that, depending on the value of the expression the control
   676:          goes to the handler, propagates the exception, or retries the
   677:          exception !!! The location corresponds to the try keyword.
   678:      *)
   679:   | TryExcept of block * (instr list * exp) * block * location
   680: 
   681: 
   682: (** Instructions. They may cause effects directly but may not have control
   683:     flow.*)
   684: and instr =
   685:     Set        of lval * exp * location  (** An assignment. A cast is present
   686:                                              if the exp has different type
   687:                                              from lval *)
   688:   | Call       of lval option * exp * exp list * location
   689:                          (** optional: result is an lval. A cast might be
   690:                              necessary if the declared result type of the
   691:                              function is not the same as that of the
   692:                              destination. If the function is declared then
   693:                              casts are inserted for those arguments that
   694:                              correspond to declared formals. (The actual
   695:                              number of arguments might be smaller or larger
   696:                              than the declared number of arguments. C allows
   697:                              this.) If the type of the result variable is not
   698:                              the same as the declared type of the function
   699:                              result then an implicit cast exists. *)
   700: 
   701:                          (* See the GCC specification for the meaning of ASM.
   702:                           * If the source is MS VC then only the templates
   703:                           * are used *)
   704:                          (* sm: I've added a notes.txt file which contains more
   705:                           * information on interpreting Asm instructions *)
   706:   | Asm        of attributes * (* Really only const and volatile can appear
   707:                                * here *)
   708:                   string list *         (* templates (CR-separated) *)
   709:                   (string * lval) list * (* outputs must be lvals with
   710:                                           * constraints. I would like these
   711:                                           * to be actually variables, but I
   712:                                           * run into some trouble with ASMs
   713:                                           * in the Linux sources  *)
   714:                   (string * exp) list * (* inputs with constraints *)
   715:                   string list *         (* register clobbers *)
   716:                   location
   717:         (** An inline assembly instruction. The arguments are (1) a list of
   718:             attributes (only const and volatile can appear here and only for
   719:             GCC), (2) templates (CR-separated), (3) a list of
   720:             outputs, each of which is an lvalue with a constraint, (4) a list
   721:             of input expressions along with constraints, (5) clobbered
   722:             registers, and (5) location information *)
   723: 
   724: 
   725: 
   726: (** Describes a location in a source file *)
   727: and location = {
   728:     line: int;             (** The line number. -1 means "do not know" *)
   729:     file: string;          (** The name of the source file*)
   730:     byte: int;             (** The byte position in the source file *)
   731: }
   732: 
   733: 
   734: 
   735: (** To be able to add/remove features easily, each feature should be package
   736:    * as an interface with the following interface. These features should be *)
   737: type featureDescr = {
   738:     fd_enabled: bool ref;
   739:     (** The enable flag. Set to default value  *)
   740: 
   741:     fd_name: string;
   742:     (** This is used to construct an option "--doxxx" and "--dontxxx" that
   743:      * enable and disable the feature  *)
   744: 
   745:     fd_description: string;
   746:     (* A longer name that can be used to document the new options  *)
   747: 
   748:     fd_extraopt: (string * Arg.spec * string) list;
   749:     (** Additional command line options *)
   750: 
   751:     fd_doit: (file -> unit);
   752:     (** This performs the transformation *)
   753: 
   754:     fd_post_check: bool;
   755:     (* Whether to perform a CIL consistency checking after this stage, if
   756:      * checking is enabled (--check is passed to cilly) *)
   757: }
   758: 
   759: let locUnknown = { line = -1; file = ""; byte = -1; }
   760: (* A reference to the current location *)
   761: let currentLoc : location ref = ref locUnknown
   762: 
   763: let compareLoc (a: location) (b: location) : int =
   764:   let namecmp = compare a.file b.file in
   765:   if namecmp != 0
   766:   then namecmp
   767:   else
   768:     let linecmp = a.line - b.line in
   769:     if linecmp != 0
   770:     then linecmp
   771:     else a.byte - b.byte
   772: 
   773: let argsToList : (string * typ * attributes) list option
   774:                   -> (string * typ * attributes) list
   775:     = function
   776:     None -> []
   777:   | Some al -> al
   778: 
   779: 
   780: 
   781: (** Different visiting actions. 'a will be instantiated with [exp], [instr],
   782:     etc. *)
   783: type 'a visitAction =
   784:     SkipChildren                        (** Do not visit the children. Return
   785:                                             the node as it is. *)
   786:   | DoChildren                          (** Continue with the children of this
   787:                                             node. Rebuild the node on return
   788:                                             if any of the children changes
   789:                                             (use == test) *)
   790:   | ChangeTo of 'a                      (** Replace the expression with the
   791:                                             given one *)
   792:   | ChangeDoChildrenPost of 'a * ('a -> 'a) (** First consider that the entire
   793:                                            exp is replaced by the first
   794:                                            parameter. Then continue with
   795:                                            the children. On return rebuild
   796:                                            the node if any of the children
   797:                                            has changed and then apply the
   798:                                            function on the node *)
   799: 
   800: 
   801: 
   802: (* sm/gn: cil visitor interface for traversing Flx_cil_cil trees. *)
   803: (* Use visitCilStmt and/or visitCilFile to use this. *)
   804: (* Some of the nodes are changed in place if the children are changed. Use
   805:  * one of Change... actions if you want to copy the node *)
   806: 
   807: (** A visitor interface for traversing CIL trees. Create instantiations of
   808:  * this type by specializing the class {!Flx_cil_cil.nopCilVisitor}. *)
   809: class type cilVisitor = object
   810: 
   811:   method vvdec: varinfo -> varinfo visitAction
   812:     (** Invoked for each variable declaration. The subtrees to be traversed
   813:      * are those corresponding to the type and attributes of the variable.
   814:      * Note that variable declarations are all the [GVar], [GVarDecl], [GFun],
   815:      * all the [varinfo] in formals of function types, and the formals and
   816:      * locals for function definitions. This means that the list of formals
   817:      * in a function definition will be traversed twice, once as part of the
   818:      * function type and second as part of the formals in a function
   819:      * definition. *)
   820: 
   821:   method vvrbl: varinfo -> varinfo visitAction
   822:     (** Invoked on each variable use. Here only the [SkipChildren] and
   823:      * [ChangeTo] actions make sense since there are no subtrees. Note that
   824:      * the type and attributes of the variable are not traversed for a
   825:      * variable use *)
   826: 
   827:   method vexpr: exp -> exp visitAction
   828:     (** Invoked on each expression occurence. The subtrees are the
   829:      * subexpressions, the types (for a [Cast] or [SizeOf] expression) or the
   830:      * variable use. *)
   831: 
   832:   method vlval: lval -> lval visitAction
   833:     (** Invoked on each lvalue occurence *)
   834: 
   835:   method voffs: offset -> offset visitAction
   836:     (** Invoked on each offset occurrence that is *not* as part
   837:       * of an initializer list specification, i.e. in an lval or
   838:       * recursively inside an offset. *)
   839: 
   840:   method vinitoffs: offset -> offset visitAction
   841:     (** Invoked on each offset appearing in the list of a
   842:       * CompoundInit initializer.  *)
   843: 
   844:   method vinst: instr -> instr list visitAction
   845:     (** Invoked on each instruction occurrence. The [ChangeTo] action can
   846:      * replace this instruction with a list of instructions *)
   847: 
   848:   method vstmt: stmt -> stmt visitAction
   849:     (** Control-flow statement. *)
   850: 
   851:   method vblock: block -> block visitAction     (** Block. Replaced in
   852:                                                     place. *)
   853:   method vfunc: fundec -> fundec visitAction    (** Function definition.
   854:                                                     Replaced in place. *)
   855:   method vglob: global -> global list visitAction (** Global (vars, types,
   856:                                                       etc.)  *)
   857:   method vinit: init -> init visitAction        (** Initializers for globals *)
   858:   method vtype: typ -> typ visitAction          (** Use of some type. Note
   859:                                                  * that for structure/union
   860:                                                  * and enumeration types the
   861:                                                  * definition of the
   862:                                                  * composite type is not
   863:                                                  * visited. Use [vglob] to
   864:                                                  * visit it.  *)
   865:   method vattr: attribute -> attribute list visitAction
   866:     (** Attribute. Each attribute can be replaced by a list *)
   867: 
   868:     (** Add here instructions while visiting to queue them to
   869:      * preceede the current statement or instruction being processed *)
   870:   method queueInstr: instr list -> unit
   871: 
   872:     (** Gets the queue of instructions and resets the queue *)
   873:   method unqueueInstr: unit -> instr list
   874: 
   875: end
   876: 
   877: (* the default visitor does nothing at each node, but does *)
   878: (* not stop; hence they return true *)
   879: class nopCilVisitor : cilVisitor = object
   880:   method vvrbl (v:varinfo) = DoChildren (* variable *)
   881:   method vvdec (v:varinfo) = DoChildren (* variable
   882:                                                                * declaration *)
   883:   method vexpr (e:exp) = DoChildren   (* expression *)
   884:   method vlval (l:lval) = DoChildren  (* lval (base is 1st
   885:                                                          * field)  *)
   886:   method voffs (o:offset) = DoChildren      (* lval or recursive offset *)
   887:   method vinitoffs (o:offset) = DoChildren  (* initializer offset *)
   888:   method vinst (i:instr) = DoChildren       (* imperative instruction *)
   889:   method vstmt (s:stmt) = DoChildren        (* constrol-flow statement *)
   890:   method vblock (b: block) = DoChildren
   891:   method vfunc (f:fundec) = DoChildren      (* function definition *)
   892:   method vglob (g:global) = DoChildren      (* global (vars, types, etc.) *)
   893:   method vinit (i:init) = DoChildren        (* global initializers *)
   894:   method vtype (t:typ) = DoChildren         (* use of some type *)
   895:   method vattr (a: attribute) = DoChildren
   896: 
   897:   val mutable instrQueue = []
   898: 
   899:   method queueInstr (il: instr list) =
   900:     List.iter (fun i -> instrQueue <- i :: instrQueue) il
   901: 
   902:   method unqueueInstr () =
   903:     let res = List.rev instrQueue in
   904:     instrQueue <- [];
   905:     res
   906: 
   907: end
   908: 
   909: let assertEmptyQueue vis =
   910:   if vis#unqueueInstr () <> [] then
   911:     (* Either a visitor inserted an instruction somewhere that it shouldn't
   912:        have (i.e. at the top level rather than inside of a statement), or
   913:        there's a bug in the visitor engine. *)
   914:     E.s (E.bug "Visitor's instruction queue is not empty\n. You should only use queueInstr inside a function body!");
   915:   ()
   916: 
   917: 
   918: let lu = locUnknown
   919: 
   920: (* sm: utility *)
   921: let startsWith (prefix: string) (s: string) : bool =
   922: (
   923:   let prefixLen = (String.length prefix) in
   924:   (String.length s) >= prefixLen &&
   925:   (String.sub s 0 prefixLen) = prefix
   926: )
   927: 
   928: 
   929: let get_instrLoc (inst : instr) =
   930:   match inst with
   931:       Set(_, _, loc) -> loc
   932:     | Call(_, _, _, loc) -> loc
   933:     | Asm(_, _, _, _, _, loc) -> loc
   934: let get_globalLoc (g : global) =
   935:   match g with
   936:   | GFun(_,l) -> (l)
   937:   | GType(_,l) -> (l)
   938:   | GEnumTag(_,l) -> (l)
   939:   | GEnumTagDecl(_,l) -> (l)
   940:   | GCompTag(_,l) -> (l)
   941:   | GCompTagDecl(_,l) -> (l)
   942:   | GVarDecl(_,l) -> (l)
   943:   | GVar(_,_,l) -> (l)
   944:   | GAsm(_,l) -> (l)
   945:   | GPragma(_,l) -> (l)
   946:   | GText(_) -> locUnknown
   947: 
   948: let rec get_stmtLoc (statement : stmtkind) =
   949:   match statement with
   950:       Instr([]) -> lu
   951:     | Instr(hd::tl) -> get_instrLoc(hd)
   952:     | Return(_, loc) -> loc
   953:     | Goto(_, loc) -> loc
   954:     | Break(loc) -> loc
   955:     | Continue(loc) -> loc
   956:     | If(_, _, _, loc) -> loc
   957:     | Switch (_, _, _, loc) -> loc
   958:     | Loop (_, loc, _, _) -> loc
   959:     | Block b -> if b.bstmts = [] then lu
   960:                  else get_stmtLoc ((List.hd b.bstmts).skind)
   961:     | TryFinally (_, _, l) -> l
   962:     | TryExcept (_, _, _, l) -> l
   963: 
   964: 
   965: (* The next variable identifier to use. Counts up *)
   966: let nextGlobalVID = ref 1
   967: 
   968: (* The next compindo identifier to use. Counts up. *)
   969: let nextCompinfoKey = ref 1
   970: 
   971: (* Some error reporting functions *)
   972: let d_loc (_: unit) (loc: location) : doc =
   973:   text loc.file ++ chr ':' ++ num loc.line
   974: 
   975: let d_thisloc (_: unit) : doc = d_loc () !currentLoc
   976: 
   977: let error (fmt : ('a,unit,doc) format) : 'a =
   978:   let f d =
   979:     E.hadErrors := true;
   980:     ignore (eprintf "@!%t: Error: %a@!"
   981:               d_thisloc insert d);
   982:     nil
   983:   in
   984:   Flx_cil_pretty.gprintf f fmt
   985: 
   986: let unimp (fmt : ('a,unit,doc) format) : 'a =
   987:   let f d =
   988:     E.hadErrors := true;
   989:     ignore (eprintf "@!%t: Unimplemented: %a@!"
   990:               d_thisloc insert d);
   991:     nil
   992:   in
   993:   Flx_cil_pretty.gprintf f fmt
   994: 
   995: let bug (fmt : ('a,unit,doc) format) : 'a =
   996:   let f d =
   997:     E.hadErrors := true;
   998:     ignore (eprintf "@!%t: Bug: %a@!"
   999:               d_thisloc insert d);
  1000:     E.showContext ();
  1001:     nil
  1002:   in
  1003:   Flx_cil_pretty.gprintf f fmt
  1004: 
  1005: let errorLoc (loc: location) (fmt : ('a,unit,doc) format) : 'a =
  1006:   let f d =
  1007:     E.hadErrors := true;
  1008:     ignore (eprintf "@!%a: Error: %a@!"
  1009:               d_loc loc insert d);
  1010:     E.showContext ();
  1011:     nil
  1012:   in
  1013:   Flx_cil_pretty.gprintf f fmt
  1014: 
  1015: let warn (fmt : ('a,unit,doc) format) : 'a =
  1016:   let f d =
  1017:     ignore (eprintf "@!%t: Warning: %a@!"
  1018:               d_thisloc insert d);
  1019:     nil
  1020:   in
  1021:   Flx_cil_pretty.gprintf f fmt
  1022: 
  1023: 
  1024: let warnOpt (fmt : ('a,unit,doc) format) : 'a =
  1025:   let f d =
  1026:     if !E.warnFlag then
  1027:       ignore (eprintf "@!%t: Warning: %a@!"
  1028:                 d_thisloc insert d);
  1029:     nil
  1030:   in
  1031:   Flx_cil_pretty.gprintf f fmt
  1032: 
  1033: let warnContext (fmt : ('a,unit,doc) format) : 'a =
  1034:   let f d =
  1035:     ignore (eprintf "@!%t: Warning: %a@!"
  1036:               d_thisloc insert d);
  1037:     E.showContext ();
  1038:     nil
  1039:   in
  1040:   Flx_cil_pretty.gprintf f fmt
  1041: 
  1042: let warnContextOpt (fmt : ('a,unit,doc) format) : 'a =
  1043:   let f d =
  1044:     if !E.warnFlag then
  1045:       ignore (eprintf "@!%t: Warning: %a@!"
  1046:                 d_thisloc insert d);
  1047:     E.showContext ();
  1048:     nil
  1049:   in
  1050:   Flx_cil_pretty.gprintf f fmt
  1051: 
  1052: let warnLoc (loc: location) (fmt : ('a,unit,doc) format) : 'a =
  1053:   let f d =
  1054:     ignore (eprintf "@!%a: Warning: %a@!"
  1055:               d_loc loc insert d);
  1056:     E.showContext ();
  1057:     nil
  1058:   in
  1059:   Flx_cil_pretty.gprintf f fmt
  1060: 
  1061: 
  1062: 
  1063: (* Represents an integer as for a given kind. Some truncation might be
  1064:  * necessary *)
  1065: let truncateInteger64 (k: ikind) (i: int64) =
  1066:   let nrBits, signed =
  1067:     match k with
  1068:     | IBool -> 8, true
  1069:     | IChar|ISChar -> 8, true
  1070:     | IUChar -> 8, false
  1071:     | IShort -> 16, true
  1072:     | IUShort -> 16, false
  1073:     | IInt | ILong -> 32, true
  1074:     | IUInt | IULong -> 32, false
  1075:     | ILongLong -> 64, true
  1076:     | IULongLong -> 64, false
  1077:   in
  1078:   if nrBits = 64 then
  1079:     i
  1080:   else begin
  1081:     let i1 = Int64.shift_left i (64 - nrBits) in
  1082:     let i2 =
  1083:       if signed then Int64.shift_right i1 (64 - nrBits)
  1084:       else Int64.shift_right_logical i1 (64 - nrBits)
  1085:     in
  1086:     i2
  1087:   end
  1088: 
  1089: (* Construct an integer constant with possible truncation *)
  1090: let kinteger64 (k: ikind) (i: int64) : exp =
  1091:   let i' = truncateInteger64 k i in
  1092:   if i' <> i then
  1093:     ignore (warnOpt "Truncating integer %s to %s\n"
  1094:               (Int64.format "0x%x" i) (Int64.format "0x%x" i'));
  1095:   Const (CInt64(i', k,  None))
  1096: 
  1097: (* Construct an integer of a given kind. *)
  1098: let kinteger (k: ikind) (i: int) = kinteger64 k (Int64.of_int i)
  1099: 
  1100: (* Construct an integer. Use only for values that fit on 31 bits *)
  1101: let integer (i: int) = Const (CInt64(Int64.of_int i, IInt, None))
  1102: 
  1103: let zero      = integer 0
  1104: let one       = integer 1
  1105: let mone      = integer (-1)
  1106: 
  1107: let rec isInteger = function
  1108:   | Const(CInt64 (n,_,_)) -> Some n
  1109:   | Const(CChr c) -> Some (Int64.of_int (Char.code c))
  1110:   | CastE(_, e) -> isInteger e
  1111:   | _ -> None
  1112: 
  1113: 
  1114: 
  1115: let rec isZero (e: exp) : bool = isInteger e = Some Int64.zero
  1116: 
  1117: let voidType = TVoid([])
  1118: let intType = TInt(IInt,[])
  1119: let uintType = TInt(IUInt,[])
  1120: let longType = TInt(ILong,[])
  1121: let ulongType = TInt(IULong,[])
  1122: let charType = TInt(IChar, [])
  1123: let boolType = TInt(IBool, [])
  1124: 
  1125: let charPtrType = TPtr(charType,[])
  1126: let charConstPtrType = TPtr(TInt(IChar, [Attr("const", [])]),[])
  1127: let stringLiteralType = ref charPtrType
  1128: 
  1129: let voidPtrType = TPtr(voidType, [])
  1130: let intPtrType = TPtr(intType, [])
  1131: let uintPtrType = TPtr(uintType, [])
  1132: 
  1133: let doubleType = TFloat(FDouble, [])
  1134: 
  1135: let parseInt (str: string) : exp =
  1136:   let hasSuffix str =
  1137:     let l = String.length str in
  1138:     fun s ->
  1139:       let ls = String.length s in
  1140:       l >= ls && s = String.uppercase (String.sub str (l - ls) ls)
  1141:   in
  1142:   let l = String.length str in
  1143:   (* See if it is octal or hex *)
  1144:   let octalhex = (l >= 1 && String.get str 0 = '0') in
  1145:   (* The length of the suffix and a list of possible kinds. See ISO
  1146:   * 6.4.4.1 *)
  1147:   let hasSuffix = hasSuffix str in
  1148:   let suffixlen, kinds =
  1149:     if hasSuffix "ULL" || hasSuffix "LLU" then
  1150:       3, [IULongLong]
  1151:     else if hasSuffix "LL" then
  1152:       2, if octalhex then [ILongLong; IULongLong] else [ILongLong]
  1153:     else if hasSuffix "UL" || hasSuffix "LU" then
  1154:       2, [IULong; IULongLong]
  1155:     else if hasSuffix "L" then
  1156:       1, if octalhex then [ILong; IULong; ILongLong; IULongLong]
  1157:       else [ILong; ILongLong]
  1158:     else if hasSuffix "U" then
  1159:       1, [IUInt; IULong; IULongLong]
  1160:     else
  1161:       0, if octalhex || true (* !!! This is against the ISO but it
  1162:         * is what GCC and MSVC do !!! *)
  1163:       then [IInt; IUInt; ILong; IULong; ILongLong; IULongLong]
  1164:       else [IInt; ILong; IUInt; ILongLong]
  1165:   in
  1166:   (* Convert to integer. To prevent overflow we do the arithmetic
  1167:   * on Int64 and we take care of overflow. We work only with
  1168:   * positive integers since the lexer takes care of the sign *)
  1169:   let rec toInt (base: int64) (acc: int64) (idx: int) : int64 =
  1170:     let doAcc (what: int) =
  1171:       let acc' =
  1172:         Int64.add (Int64.mul base acc)  (Int64.of_int what) in
  1173:       if acc < Int64.zero || (* We clearly overflow since base >= 2
  1174:       * *)
  1175:       (acc' > Int64.zero && acc' < acc) then
  1176:         E.s (unimp "Cannot represent on 64 bits the integer %s\n"
  1177:                str)
  1178:       else
  1179:         toInt base acc' (idx + 1)
  1180:     in
  1181:     if idx >= l - suffixlen then begin
  1182:       acc
  1183:     end else
  1184:       let ch = String.get str idx in
  1185:       if ch >= '0' && ch <= '9' then
  1186:         doAcc (Char.code ch - Char.code '0')
  1187:       else if  ch >= 'a' && ch <= 'f'  then
  1188:         doAcc (10 + Char.code ch - Char.code 'a')
  1189:       else if  ch >= 'A' && ch <= 'F'  then
  1190:         doAcc (10 + Char.code ch - Char.code 'A')
  1191:       else
  1192:         E.s (bug "Invalid integer constant: %s" str)
  1193:   in
  1194:   try
  1195:     let i =
  1196:       if octalhex then
  1197:         if l >= 2 &&
  1198:           (let c = String.get str 1 in c = 'x' || c = 'X') then
  1199:           toInt (Int64.of_int 16) Int64.zero 2
  1200:         else
  1201:           toInt (Int64.of_int 8) Int64.zero 1
  1202:       else
  1203:         toInt (Int64.of_int 10) Int64.zero 0
  1204:     in
  1205:     (* Construct an integer of the first kinds that fits. i must be
  1206:     * POSITIVE  *)
  1207:     let res =
  1208:       let rec loop = function
  1209:         | ((IInt | ILong) as k) :: _
  1210:                   when i < Int64.shift_left (Int64.of_int 1) 31 ->
  1211:                     kinteger64 k i
  1212:         | ((IUInt | IULong) as k) :: _
  1213:                   when i < Int64.shift_left (Int64.of_int 1) 32
  1214:           ->  kinteger64 k i
  1215:         | (ILongLong as k) :: _
  1216:                  when i <= Int64.sub (Int64.shift_left
  1217:                                               (Int64.of_int 1) 63)
  1218:                                           (Int64.of_int 1)
  1219:           ->
  1220:             kinteger64 k i
  1221:         | (IULongLong as k) :: _ -> kinteger64 k i
  1222:         | _ :: rest -> loop rest
  1223:         | [] -> E.s (E.unimp "Cannot represent the integer %s\n"
  1224:                        (Int64.to_string i))
  1225:       in
  1226:       loop kinds
  1227:     in
  1228:     res
  1229:   with e -> begin
  1230:     ignore (E.log "int_of_string %s (%s)\n" str
  1231:               (Printexc.to_string e));
  1232:     zero
  1233:   end
  1234: 
  1235: 
  1236: (* An integer type that fits pointers. Initialized by initCIL *)
  1237: let upointType = ref voidType
  1238: 
  1239: (* An integer type that fits wchar_t. Initialized by initCIL *)
  1240: let wcharKind = ref IChar
  1241: let wcharType = ref voidType
  1242: 
  1243: 
  1244: (* An integer type that is the type of sizeof. Initialized by initCIL *)
  1245: let typeOfSizeOf = ref voidType
  1246: let kindOfSizeOf = ref IUInt
  1247: 
  1248: (** Returns true if and only if the given integer type is signed. *)
  1249: let isSigned = function
  1250:   | IBool
  1251:   | IUChar
  1252:   | IUShort
  1253:   | IUInt
  1254:   | IULong
  1255:   | IULongLong ->
  1256:       false
  1257:   | ISChar
  1258:   | IShort
  1259:   | IInt
  1260:   | ILong
  1261:   | ILongLong ->
  1262:       true
  1263:   | IChar ->
  1264:       not !theMachine.Flx_cil_machdep_type.char_is_unsigned
  1265: 
  1266: let mkStmt (sk: stmtkind) : stmt =
  1267:   { skind = sk;
  1268:     labels = [];
  1269:     sid = -1; succs = []; preds = [] }
  1270: 
  1271: let mkBlock (slst: stmt list) : block =
  1272:   { battrs = []; bstmts = slst; }
  1273: 
  1274: let mkEmptyStmt () = mkStmt (Instr [])
  1275: let mkStmtOneInstr (i: instr) = mkStmt (Instr [i])
  1276: 
  1277: let dummyInstr = (Asm([], ["dummy statement!!"], [], [], [], lu))
  1278: let dummyStmt =  mkStmt (Instr [dummyInstr])
  1279: 
  1280: let compactStmts (b: stmt list) : stmt list =
  1281:       (* Try to compress statements. Scan the list of statements and remember
  1282:        * the last instrunction statement encountered, along with a Flx_cil_clist of
  1283:        * instructions in it. *)
  1284:   let rec compress (lastinstrstmt: stmt) (* Might be dummStmt *)
  1285:                    (lastinstrs: instr Flx_cil_clist.clist)
  1286:                    (body: stmt list) =
  1287:     let finishLast (tail: stmt list) : stmt list =
  1288:       if lastinstrstmt == dummyStmt then tail
  1289:       else begin
  1290:         lastinstrstmt.skind <- Instr (Flx_cil_clist.toList lastinstrs);
  1291:         lastinstrstmt :: tail
  1292:       end
  1293:     in
  1294:     match body with
  1295:       [] -> finishLast []
  1296:     | ({skind=Instr il} as s) :: rest ->
  1297:         let ils = Flx_cil_clist.fromList il in
  1298:         if lastinstrstmt != dummyStmt && s.labels == [] then
  1299:           compress lastinstrstmt (Flx_cil_clist.append lastinstrs ils) rest
  1300:         else
  1301:           finishLast (compress s ils rest)
  1302: 
  1303:     | s :: rest ->
  1304:         let res = s :: compress dummyStmt Flx_cil_clist.empty rest in
  1305:         finishLast res
  1306:   in
  1307:   compress dummyStmt Flx_cil_clist.empty b
  1308: 
  1309: 
  1310: (** Construct sorted lists of attributes ***)
  1311: let rec addAttribute (Attr(an, _) as a: attribute) (al: attributes) =
  1312:   let rec insertSorted = function
  1313:       [] -> [a]
  1314:     | ((Attr(an0, _) as a0) :: rest) as l ->
  1315:         if an < an0 then a :: l
  1316:         else if an > an0 then a0 :: insertSorted rest
  1317:         else if a = a0 then l (* Do not add if already in there *)
  1318:         else a0 :: insertSorted rest (* Make sure we see all attributes with
  1319:                                       * this name *)
  1320:   in
  1321:   insertSorted al
  1322: 
  1323: (** The second attribute list is sorted *)
  1324: and addAttributes al0 (al: attributes) : attributes =
  1325:     if al0 == [] then al else
  1326:     List.fold_left (fun acc a -> addAttribute a acc) al al0
  1327: 
  1328: and dropAttribute (an: string) (al: attributes) =
  1329:   List.filter (fun (Attr(an', _)) -> an <> an') al
  1330: 
  1331: and dropAttributes (anl: string list) (al: attributes) =
  1332:   List.fold_left (fun acc an -> dropAttribute an acc) al anl
  1333: 
  1334: and filterAttributes (s: string) (al: attribute list) : attribute list =
  1335:   List.filter (fun (Attr(an, _)) -> an = s) al
  1336: 
  1337: (* sm: *)
  1338: let hasAttribute s al =
  1339:   (filterAttributes s al <> [])
  1340: 
  1341: 
  1342: type attributeClass =
  1343:     AttrName of bool
  1344:         (* Attribute of a name. If argument is true and we are on MSVC then
  1345:          * the attribute is printed using __declspec as part of the storage
  1346:          * specifier  *)
  1347:   | AttrFunType of bool
  1348:         (* Attribute of a function type. If argument is true and we are on
  1349:          * MSVC then the attribute is printed just before the function name *)
  1350: 
  1351:   | AttrType  (* Attribute of a type *)
  1352: 
  1353: (* This table contains the mapping of predefined attributes to classes.
  1354:  * Extend this table with more attributes as you need. This table is used to
  1355:  * determine how to associate attributes with names or type during cabs2cil
  1356:  * conversion *)
  1357: let attributeHash: (string, attributeClass) H.t =
  1358:   let table = H.create 13 in
  1359:   List.iter (fun a -> H.add table a (AttrName false))
  1360:     [ "section"; "constructor"; "destructor"; "unused"; "weak";
  1361:       "no_instrument_function"; "alias"; "no_check_memory_usage";
  1362:       "exception"; "model"; (* "restrict"; *)
  1363:       "aconst"; "__asm__" (* Gcc uses this to specifiy the name to be used in
  1364:                            * assembly for a global  *)];
  1365: 
  1366:   (* Now come the MSVC declspec attributes *)
  1367:   List.iter (fun a -> H.add table a (AttrName true))
  1368:     [ "thread"; "naked"; "dllimport"; "dllexport"; "noreturn";
  1369:       "selectany"; "allocate"; "nothrow"; "novtable"; "property";
  1370:       "uuid"; "align" ];
  1371: 
  1372:   List.iter (fun a -> H.add table a (AttrFunType false))
  1373:     [ "format"; "regparm"; "longcall" ];
  1374:   List.iter (fun a -> H.add table a (AttrFunType true))
  1375:     [ "stdcall";"cdecl"; "fastcall" ];
  1376:   List.iter (fun a -> H.add table a AttrType)
  1377:     [ "const"; "volatile"; "restrict"; "mode" ];
  1378:   table
  1379: 
  1380: 
  1381: (* Partition the attributes into classes *)
  1382: let partitionAttributes
  1383:     ~(default:attributeClass)
  1384:     (attrs:  attribute list) :
  1385:     attribute list * attribute list * attribute list =
  1386:   let rec loop (n,f,t) = function
  1387:       [] -> n, f, t
  1388:     | (Attr(an, _) as a) :: rest ->
  1389:         match (try H.find attributeHash an with Not_found -> default) with
  1390:           AttrName _ -> loop (addAttribute a n, f, t) rest
  1391:         | AttrFunType _ -> loop (n, addAttribute a f, t) rest
  1392:         | AttrType -> loop (n, f, addAttribute a t) rest
  1393:   in
  1394:   loop ([], [], []) attrs
  1395: 
  1396: 
  1397: (* Get the full name of a comp *)
  1398: let compFullName comp =
  1399:   (if comp.cstruct then "struct " else "union ") ^ comp.cname
  1400: 
  1401: 
  1402: let missingFieldName = "___missing_field_name"
  1403: 
  1404: (** Creates a a (potentially recursive) composite type. Make sure you add a
  1405:   * GTag for it to the file! **)
  1406: let mkCompInfo
  1407:       (isstruct: bool)
  1408:       (n: string)
  1409:       (* fspec is a function that when given a forward
  1410:        * representation of the structure type constructs the type of
  1411:        * the fields. The function can ignore this argument if not
  1412:        * constructing a recursive type.  *)
  1413:        (mkfspec: compinfo -> (string * typ * int option * attribute list *
  1414:                              location * storage) list)
  1415:        (a: attribute list) : compinfo =
  1416: 
  1417:   (* make an new name for anonymous structs *)
  1418:    if n = "" then
  1419:      E.s (E.bug "mkCompInfo: missing structure name\n");
  1420:    (* Make a new self cell and a forward reference *)
  1421:    let comp =
  1422:      { cstruct = isstruct; cname = ""; ckey = 0; cfields = [];
  1423:        cattr = a; creferenced = false;
  1424:        (* Make this compinfo undefined by default *)
  1425:        cdefined = false; }
  1426:    in
  1427:    comp.cname <- n;
  1428:    comp.ckey <- !nextCompinfoKey;
  1429:    incr nextCompinfoKey;
  1430:    let self = ref voidType in
  1431:    let flds =
  1432:        List.map (fun (fn, ft, fb, fa, fl, fs) ->
  1433:           { fcomp = comp;
  1434:             ftype = ft;
  1435:             fname = fn;
  1436:             fbitfield = fb;
  1437:             fattr = fa;
  1438:             floc = fl;
  1439:             fstorage = fs}) (mkfspec comp) in
  1440:    comp.cfields <- flds;
  1441:    if flds <> [] then comp.cdefined <- true;
  1442:    comp
  1443: 
  1444: (** Make a copy of a compinfo, changing the name and the key *)
  1445: let copyCompInfo (ci: compinfo) (n: string) : compinfo =
  1446:   let ci' = {ci with cname = n;
  1447:                      ckey = !nextCompinfoKey; } in
  1448:   incr nextCompinfoKey;
  1449:   (* Copy the fields and set the new pointers to parents *)
  1450:   ci'.cfields <- List.map (fun f -> {f with fcomp = ci'}) ci'.cfields;
  1451:   ci'
  1452: 
  1453: (**** Flx_cil_utility functions ******)
  1454: let rec unrollType = function   (* Might drop some attributes !! *)
  1455:     TNamed (r, _) -> unrollType r.ttype
  1456:   | x -> x
  1457: 
  1458: let rec unrollTypeDeep = function   (* Might drop some attributes !! *)
  1459:     TNamed (r, _) -> unrollTypeDeep r.ttype
  1460:   | TPtr(t, a) -> TPtr(unrollTypeDeep t, a)
  1461:   | TArray(t, l, a) -> TArray(unrollTypeDeep t, l, a)
  1462:   | TFun(rt, args, isva, a) ->
  1463:       TFun (unrollTypeDeep rt,
  1464:             (match args with
  1465:               None -> None
  1466:             | Some argl ->
  1467:                 Some (List.map (fun (an,at,aa) -> (an, unrollTypeDeep at, aa)) argl)),
  1468:             isva, a)
  1469:   | x -> x
  1470: 
  1471: let isVoidType t =
  1472:   match unrollType t with
  1473:     TVoid _ -> true
  1474:   | _ -> false
  1475: let isVoidPtrType t =
  1476:   match unrollType t with
  1477:     TPtr(tau,_) when isVoidType tau -> true
  1478:   | _ -> false
  1479: 
  1480: let var vi : lval = (Var vi, NoOffset)
  1481: (* let assign vi e = Instrs(Set (var vi, e), lu) *)
  1482: 
  1483: let mkString s = Const(CStr s)
  1484: 
  1485: 
  1486: let mkWhile ~(guard:exp) ~(body: stmt list) : stmt list =
  1487:   (* Do it like this so that the pretty printer recognizes it *)
  1488:   [ mkStmt (Loop (mkBlock (mkStmt (If(guard,
  1489:                                       mkBlock [ mkEmptyStmt () ],
  1490:                                       mkBlock [ mkStmt (Break lu)], lu)) ::
  1491:                            body), lu, None, None)) ]
  1492: 
  1493: 
  1494: 
  1495: let mkFor ~(start: stmt list) ~(guard: exp) ~(next: stmt list)
  1496:           ~(body: stmt list) : stmt list =
  1497:   (start @
  1498:      (mkWhile guard (body @ next)))
  1499: 
  1500: 
  1501: let mkForIncr ~(iter : varinfo) ~(first: exp) ~stopat:(past: exp) ~(incr: exp)
  1502:     ~(body: stmt list) : stmt list =
  1503:       (* See what kind of operator we need *)
  1504:   let compop, nextop =
  1505:     match unrollType iter.vtype with
  1506:       TPtr _ -> Lt, PlusPI
  1507:     | _ -> Lt, PlusA
  1508:   in
  1509:   mkFor
  1510:     [ mkStmt (Instr [(Set (var iter, first, lu))]) ]
  1511:     (BinOp(compop, Lval(var iter), past, intType))
  1512:     [ mkStmt (Instr [(Set (var iter,
  1513:                            (BinOp(nextop, Lval(var iter), incr, iter.vtype)),
  1514:                            lu))])]
  1515:     body
  1516: 
  1517: 
  1518: 
  1519: 
  1520: (* the name of the C function we call to get ccgr ASTs
  1521: external parse : string -> file = "cil_main"
  1522: *)
  1523: (*
  1524:   Flx_cil_pretty Printing
  1525:  *)
  1526: 
  1527: let d_ikind () = function
  1528:   | IBool -> text "_Bool"
  1529:   | IChar -> text "char"
  1530:   | ISChar -> text "signed char"
  1531:   | IUChar -> text "unsigned char"
  1532:   | IInt -> text "int"
  1533:   | IUInt -> text "unsigned int"
  1534:   | IShort -> text "short"
  1535:   | IUShort -> text "unsigned short"
  1536:   | ILong -> text "long"
  1537:   | IULong -> text "unsigned long"
  1538:   | ILongLong ->
  1539:       if !msvcMode then text "__int64" else text "long long"
  1540:   | IULongLong ->
  1541:       if !msvcMode then text "unsigned __int64"
  1542:       else text "unsigned long long"
  1543: 
  1544: let d_fkind () = function
  1545:     FFloat -> text "float"
  1546:   | FDouble -> text "double"
  1547:   | FLongDouble -> text "long double"
  1548: 
  1549:   | CFloat -> text "_Complex"
  1550:   | CDouble -> text "double _Complex"
  1551:   | CLongDouble -> text "long double _Complex"
  1552: 
  1553:   | IFloat -> text "_Imaginary"
  1554:   | IDouble -> text "double _Imaginary"
  1555:   | ILongDouble -> text "long double _Imaginary"
  1556: 
  1557: let d_storage () = function
  1558:     NoStorage -> nil
  1559:   | Static -> text "static "
  1560:   | Extern -> text "extern "
  1561:   | Register -> text "register "
  1562: 
  1563: (* sm: need this value below *)
  1564: let mostNeg32BitInt : int64 = (Int64.of_string "-0x80000000")
  1565: let mostNeg64BitInt : int64 = (Int64.of_string "-0x8000000000000000")
  1566: 
  1567: (* constant *)
  1568: let d_const () c =
  1569:   let suffix ik =
  1570:     match ik with
  1571:       IUInt -> "U"
  1572:     | ILong -> "L"
  1573:     | IULong -> "UL"
  1574:     | ILongLong -> if !msvcMode then "L" else "LL"
  1575:     | IULongLong -> if !msvcMode then "UL" else "ULL"
  1576:     | _ -> ""
  1577:   in
  1578:   match c with
  1579:     CInt64(_, _, Some s) -> text s (* Always print the text if there is one *)
  1580:   | CInt64(i, ik, None) ->
  1581:       (* Watch out here for negative integers that we should be printing as
  1582:        * large positive ones *)
  1583:       if i < Int64.zero
  1584:           && (match ik with
  1585:             IUInt | IULong | IULongLong | IUChar | IUShort -> true | _ -> false) then
  1586:         let high = Int64.shift_right i 32 in
  1587:         if ik <> IULongLong && ik <> ILongLong && high = Int64.of_int (-1) then
  1588:           (* Print only the low order 32 bits *)
  1589:           text ("0x" ^
  1590:                 Int64.format "%x" (Int64.logand i (Int64.shift_right_logical high 32))
  1591:                 ^ suffix ik)
  1592:         else
  1593:           text ("0x" ^ Int64.format "%x" i ^ suffix ik)
  1594:       else (
  1595:         if (i = mostNeg32BitInt) then
  1596:           (* sm: quirk here: if you print -2147483648 then this is two tokens *)
  1597:           (* in C, and the second one is too large to represent in a signed *)
  1598:           (* int.. so we do what's done in limits.h, and print (-2147483467-1); *)
  1599:           (* in gcc this avoids a warning, but it might avoid a real problem *)
  1600:           (* on another compiler or a 64-bit architecture *)
  1601:           text "(-0x7FFFFFFF-1)"
  1602:         else if (i = mostNeg64BitInt) then
  1603:           (* The same is true of the largest 64-bit negative. *)
  1604:           text "(-0x7FFFFFFFFFFFFFFF-1)"
  1605:         else
  1606:           text (Int64.to_string i ^ suffix ik)
  1607:       )
  1608: 
  1609:   | CStr(s) -> text ("\"" ^ escape_string s ^ "\"")
  1610:   | CWStr(s) ->
  1611:       (* text ("L\"" ^ escape_string s ^ "\"")  *)
  1612:       (List.fold_left (fun acc elt ->
  1613:         acc ++
  1614:         if (elt >= Int64.zero &&
  1615:             elt <= (Int64.of_int 255)) then
  1616:           text (escape_char (Char.chr (Int64.to_int elt)))
  1617:         else
  1618:           ( text (Printf.sprintf "\\x%LX\"" elt) ++ break ++
  1619:             (text "\""))
  1620:       ) (text "L\"") s ) ++ text "\""
  1621:       (* we cannot print L"\xabcd" "feedme" as L"\xabcdfeedme" --
  1622:        * the former has 7 wide characters and the later has 3. *)
  1623: 
  1624:   | CChr(c) -> text ("'" ^ escape_char c ^ "'")
  1625:   | CReal(_, _, Some s) -> text s
  1626:   | CReal(f, _, None) -> text (string_of_float f)
  1627: 
  1628: (* Parentheses level. An expression "a op b" is printed parenthesized if its
  1629:  * parentheses level is >= that that of its context. Identifiers have the
  1630:  * lowest level and weakly binding operators (e.g. |) have the largest level.
  1631:  * The correctness criterion is that a smaller level MUST correspond to a
  1632:  * stronger precedence!
  1633:  *)
  1634: let derefStarLevel = 20
  1635: let indexLevel = 20
  1636: let arrowLevel = 20
  1637: let addrOfLevel = 30
  1638: let additiveLevel = 60
  1639: let comparativeLevel = 70
  1640: let bitwiseLevel = 75
  1641: let getParenthLevel = function
  1642:   | BinOp((LAnd | LOr), _,_,_) -> 80
  1643:                                         (* Bit operations. *)
  1644:   | BinOp((BOr|BXor|BAnd),_,_,_) -> bitwiseLevel (* 75 *)
  1645: 
  1646:                                         (* Comparisons *)
  1647:   | BinOp((Eq|Ne|Gt|Lt|Ge|Le),_,_,_) ->
  1648:       comparativeLevel (* 70 *)
  1649:                                         (* Additive. Shifts can have higher
  1650:                                          * level than + or - but I want
  1651:                                          * parentheses around them *)
  1652:   | BinOp((MinusA|MinusPP|MinusPI|PlusA|
  1653:            PlusPI|IndexPI|Shiftlt|Shiftrt),_,_,_)
  1654:     -> additiveLevel (* 60 *)
  1655: 
  1656:                                         (* Multiplicative *)
  1657:   | BinOp((Div|Mod|Mult),_,_,_) -> 40
  1658: 
  1659:                                         (* Unary *)
  1660:   | CastE(_,_) -> 30
  1661:   | AddrOf(_) -> 30
  1662:   | StartOf(_) -> 30
  1663:   | UnOp((Neg|BNot|LNot),_,_) -> 30
  1664: 
  1665:                                         (* Lvals *)
  1666:   | Lval(Mem _ , _) -> 20
  1667:   | Lval(Var _, (Field _|Index _)) -> 20
  1668:   | SizeOf _ | SizeOfE _ | SizeOfStr _ -> 20
  1669:   | AlignOf _ | AlignOfE _ -> 20
  1670: 
  1671:   | Lval(Var _, NoOffset) -> 0        (* Plain variables *)
  1672:   | Const _ -> 0                        (* Constants *)
  1673: 
  1674: 
  1675: 
  1676: (* Separate out the storage-modifier name attributes *)
  1677: let separateStorageModifiers (al: attribute list) =
  1678:   let isstoragemod (Attr(an, _): attribute) : bool =
  1679:     try
  1680:       match H.find attributeHash an with
  1681:         AttrName issm -> issm
  1682:       | _ -> E.s (E.bug "separateStorageModifier: %s is not a name attribute" an)
  1683:     with Not_found -> false
  1684:   in
  1685:     let stom, rest = List.partition isstoragemod al in
  1686:     if not !msvcMode then
  1687:       stom, rest
  1688:     else
  1689:       (* Put back the declspec. Put it without the leading __ since these will
  1690:        * be added later *)
  1691:       let stom' =
  1692:         List.map (fun (Attr(an, args)) ->
  1693:           Attr("declspec", [ACons(an, args)])) stom in
  1694:       stom', rest
  1695: 
  1696: 
  1697: let rec typeAttrs = function
  1698:     TVoid a -> a
  1699:   | TInt (_, a) -> a
  1700:   | TFloat (_, a) -> a
  1701:   | TNamed (t, a) -> addAttributes a (typeAttrs t.ttype)
  1702:   | TPtr (_, a) -> a
  1703:   | TArray (_, _, a) -> a
  1704:   | TComp (comp, a) -> addAttributes comp.cattr a
  1705:   | TEnum (enum, a) -> addAttributes enum.eattr a
  1706:   | TFun (_, _, _, a) -> a
  1707:   | TBuiltin_va_list a -> a
  1708: 
  1709: 
  1710: let setTypeAttrs t a =
  1711:   match t with
  1712:     TVoid _ -> TVoid a
  1713:   | TInt (i, _) -> TInt (i, a)
  1714:   | TFloat (f, _) -> TFloat (f, a)
  1715:   | TNamed (t, _) -> TNamed(t, a)
  1716:   | TPtr (t', _) -> TPtr(t', a)
  1717:   | TArray (t', l, _) -> TArray(t', l, a)
  1718:   | TComp (comp, _) -> TComp (comp, a)
  1719:   | TEnum (enum, _) -> TEnum (enum, a)
  1720:   | TFun (r, args, v, _) -> TFun(r,args,v,a)
  1721:   | TBuiltin_va_list _ -> TBuiltin_va_list a
  1722: 
  1723: 
  1724: let typeAddAttributes a0 t =
  1725: begin
  1726:   match a0 with
  1727:   | [] ->
  1728:       (* no attributes, keep same type *)
  1729:       t
  1730:   | _ ->
  1731:       (* anything else: add a0 to existing attributes *)
  1732:       let add (a: attributes) = addAttributes a0 a in
  1733:       match t with
  1734:         TVoid a -> TVoid (add a)
  1735:       | TInt (ik, a) -> TInt (ik, add a)
  1736:       | TFloat (fk, a) -> TFloat (fk, add a)
  1737:       | TEnum (enum, a) -> TEnum (enum, add a)
  1738:       | TPtr (t, a) -> TPtr (t, add a)
  1739:       | TArray (t, l, a) -> TArray (t, l, add a)
  1740:       | TFun (t, args, isva, a) -> TFun(t, args, isva, add a)
  1741:       | TComp (comp, a) -> TComp (comp, add a)
  1742:       | TNamed (t, a) -> TNamed (t, add a)
  1743:       | TBuiltin_va_list a -> TBuiltin_va_list (add a)
  1744: end
  1745: 
  1746: let typeRemoveAttributes (anl: string list) t =
  1747:   let drop (al: attributes) = dropAttributes anl al in
  1748:   match t with
  1749:     TVoid a -> TVoid (drop a)
  1750:   | TInt (ik, a) -> TInt (ik, drop a)
  1751:   | TFloat (fk, a) -> TFloat (fk, drop a)
  1752:   | TEnum (enum, a) -> TEnum (enum, drop a)
  1753:   | TPtr (t, a) -> TPtr (t, drop a)
  1754:   | TArray (t, l, a) -> TArray (t, l, drop a)
  1755:   | TFun (t, args, isva, a) -> TFun(t, args, isva, drop a)
  1756:   | TComp (comp, a) -> TComp (comp, drop a)
  1757:   | TNamed (t, a) -> TNamed (t, drop a)
  1758:   | TBuiltin_va_list a -> TBuiltin_va_list (drop a)
  1759: 
  1760: 
  1761:      (* Type signatures. Two types are identical iff they have identical
  1762:       * signatures *)
  1763: type typsig =
  1764:     TSArray of typsig * exp option * attribute list
  1765:   | TSPtr of typsig * attribute list
  1766:   | TSComp of bool * string * attribute list
  1767:   | TSFun of typsig * typsig list * bool * attribute list
  1768:   | TSEnum of string * attribute list
  1769:   | TSBase of typ
  1770: 
  1771: (* Compute a type signature *)
  1772: let rec typeSigWithAttrs doattr t =
  1773:   let typeSig = typeSigWithAttrs doattr in
  1774:   match t with
  1775:   | TInt (ik, al) -> TSBase (TInt (ik, doattr al))
  1776:   | TFloat (fk, al) -> TSBase (TFloat (fk, doattr al))
  1777:   | TVoid al -> TSBase (TVoid (doattr al))
  1778:   | TEnum (enum, a) -> TSEnum (enum.ename, doattr a)
  1779:   | TPtr (t, a) -> TSPtr (typeSig t, doattr a)
  1780:   | TArray (t,l,a) -> TSArray(typeSig t, l, doattr a)
  1781:   | TComp (comp, a) ->
  1782:       TSComp (comp.cstruct, comp.cname, doattr (addAttributes comp.cattr a))
  1783:   | TFun(rt,args,isva,a) ->
  1784:       TSFun(typeSig rt,
  1785:             List.map (fun (_, atype, _) -> (typeSig atype)) (argsToList args),
  1786:             isva, doattr a)
  1787:   | TNamed(t, a) -> typeSigAddAttrs (doattr a) (typeSig t.ttype)
  1788:   | TBuiltin_va_list al -> TSBase (TBuiltin_va_list (doattr al))
  1789: and typeSigAddAttrs a0 t =
  1790:   if a0 == [] then t else
  1791:   match t with
  1792:     TSBase t -> TSBase (typeAddAttributes a0 t)
  1793:   | TSPtr (ts, a) -> TSPtr (ts, addAttributes a0 a)
  1794:   | TSArray (ts, l, a) -> TSArray(ts, l, addAttributes a0 a)
  1795:   | TSComp (iss, n, a) -> TSComp (iss, n, addAttributes a0 a)
  1796:   | TSEnum (n, a) -> TSEnum (n, addAttributes a0 a)
  1797:   | TSFun(ts, tsargs, isva, a) -> TSFun(ts, tsargs, isva, addAttributes a0 a)
  1798: 
  1799: 
  1800: let typeSig t = typeSigWithAttrs (fun al -> al) t
  1801: 
  1802: (* Remove the attribute from the top-level of the type signature *)
  1803: let setTypeSigAttrs (a: attribute list) = function
  1804:     TSBase t -> TSBase (setTypeAttrs t a)
  1805:   | TSPtr (ts, _) -> TSPtr (ts, a)
  1806:   | TSArray (ts, l, _) -> TSArray(ts, l, a)
  1807:   | TSComp (iss, n, _) -> TSComp (iss, n, a)
  1808:   | TSEnum (n, _) -> TSEnum (n, a)
  1809:   | TSFun (ts, tsargs, isva, _) -> TSFun (ts, tsargs, isva, a)
  1810: 
  1811: 
  1812: let typeSigAttrs = function
  1813:     TSBase t -> typeAttrs t
  1814:   | TSPtr (ts, a) -> a
  1815:   | TSArray (ts, l, a) -> a
  1816:   | TSComp (iss, n, a) -> a
  1817:   | TSEnum (n, a) -> a
  1818:   | TSFun (ts, tsargs, isva, a) -> a
  1819: 
  1820: 
  1821: (**** Compute the type of an expression ****)
  1822: let rec typeOf (e: exp) : typ =
  1823:   match e with
  1824:   | Const(CInt64 (_, ik, _)) -> TInt(ik, [])
  1825: 
  1826:     (* Character constants have type int.  ISO/IEC 9899:1999 (E),
  1827:      * section 6.4.4.4 [Character constants], paragraph 10, if you
  1828:      * don't believe me. *)
  1829:   | Const(CChr _) -> intType
  1830: 
  1831:     (* The type of a string is a pointer to characters ! The only case when
  1832:      * you would want it to be an array is as an argument to sizeof, but we
  1833:      * have SizeOfStr for that *)
  1834:   | Const(CStr s) -> !stringLiteralType
  1835: 
  1836:   | Const(CWStr s) -> TPtr(!wcharType,[])
  1837: 
  1838:   | Const(CReal (_, fk, _)) -> TFloat(fk, [])
  1839:   | Lval(lv) -> typeOfLval lv
  1840:   | SizeOf _ | SizeOfE _ | SizeOfStr _ -> !typeOfSizeOf
  1841:   | AlignOf _ | AlignOfE _ -> !typeOfSizeOf
  1842:   | UnOp (_, _, t) -> t
  1843:   | BinOp (_, _, _, t) -> t
  1844:   | CastE (t, _) -> t
  1845:   | AddrOf (lv) -> TPtr(typeOfLval lv, [])
  1846:   | StartOf (lv) -> begin
  1847:       match unrollType (typeOfLval lv) with
  1848:         TArray (t,_, _) -> TPtr(t, [])
  1849:      | _ -> E.s (E.bug "typeOf: StartOf on a non-array")
  1850:   end
  1851: 
  1852: and typeOfInit (i: init) : typ =
  1853:   match i with
  1854:     SingleInit e -> typeOf e
  1855:   | CompoundInit (t, _) -> t
  1856: 
  1857: and typeOfLval = function
  1858:     Var vi, off -> typeOffset vi.vtype off
  1859:   | Mem addr, off -> begin
  1860:       match unrollType (typeOf addr) with
  1861:         TPtr (t, _) -> typeOffset t off
  1862:       | _ -> E.s (bug "typeOfLval: Mem on a non-pointer")
  1863:   end
  1864: 
  1865: and typeOffset basetyp = function
  1866:     NoOffset -> basetyp
  1867:   | Index (_, o) -> begin
  1868:       match unrollType basetyp with
  1869:         TArray (t, _, _) -> typeOffset t o
  1870:       | t -> E.s (E.bug "typeOffset: Index on a non-array")
  1871:   end
  1872:   | Field (fi, o) -> typeOffset fi.ftype o
  1873: 
  1874: 
  1875: and d_binop () b =
  1876:   match b with
  1877:     PlusA | PlusPI | IndexPI -> text "+"
  1878:   | MinusA | MinusPP | MinusPI -> text "-"
  1879:   | Mult -> text "*"
  1880:   | Div -> text "/"
  1881:   | Mod -> text "%"
  1882:   | Shiftlt -> text "<<"
  1883:   | Shiftrt -> text ">>"
  1884:   | Lt -> text "<"
  1885:   | Gt -> text ">"
  1886:   | Le -> text "<="
  1887:   | Ge -> text ">="
  1888:   | Eq -> text "=="
  1889:   | Ne -> text "!="
  1890:   | BAnd -> text "&"
  1891:   | BXor -> text "^"
  1892:   | BOr -> text "|"
  1893:   | LAnd -> text "&&"
  1894:   | LOr -> text "||"
  1895: 
  1896: let invalidStmt = mkStmt (Instr [])
  1897: 
  1898: (** Construct a hash with the builtins *)
  1899: let gccBuiltins : (string, typ * typ list * bool) H.t =
  1900:   let h = H.create 17 in
  1901:   (* See if we have builtin_va_list *)
  1902:   let hasbva = M.gccHas__builtin_va_list in
  1903:   (* When we parse builtin_next_arg we drop the second argument *)
  1904:   H.add h "__builtin_next_arg"
  1905:     ((if hasbva then TBuiltin_va_list [] else voidPtrType), [], false);
  1906:   H.add h "__builtin_constant_p" (intType, [ intType ], false);
  1907:   H.add h "__builtin_fabs" (doubleType, [ doubleType ], false);
  1908:   let longDouble = TFloat (FLongDouble, []) in
  1909:   H.add h "__builtin_fabsl" (longDouble, [ longDouble ], false);
  1910:   if hasbva then begin
  1911:     H.add h "__builtin_va_end" (voidType, [ TBuiltin_va_list [] ], false);
  1912:     H.add h "__builtin_varargs_start"
  1913:       (voidType, [ TBuiltin_va_list [] ], false);
  1914:     H.add h "__builtin_va_start" (voidType, [ TBuiltin_va_list [] ], false);
  1915:     (* When we parse builtin_stdarg_start, we drop the second argument *)
  1916:     H.add h "__builtin_stdarg_start" (voidType, [ TBuiltin_va_list []; ],
  1917:                                       false);
  1918:     (* When we parse builtin_va_arg we change its interface *)
  1919:     H.add h "__builtin_va_arg" (voidType, [ TBuiltin_va_list [];
  1920:                                             uintType; (* Sizeof the type *)
  1921:                                             voidPtrType; (* Ptr to res *) ],
  1922:                                false);
  1923:     H.add h "__builtin_va_copy" (voidType, [ TBuiltin_va_list [];
  1924:                                              TBuiltin_va_list [] ],
  1925:                                 false);
  1926:   end;
  1927:   h
  1928: 
  1929: (** Construct a hash with the builtins *)
  1930: let msvcBuiltins : (string, typ * typ list * bool) H.t =
  1931:   (* These are empty for now but can be added to depending on the application*)
  1932:   let h = H.create 17 in
  1933:   (** Take a number of wide string literals *)
  1934:   H.add h "__annotation" (voidType, [ ], true);
  1935:   h
  1936: 
  1937: 
  1938: (** A printer interface for CIL trees. Create instantiations of
  1939:  * this type by specializing the class {!Flx_cil_cil.defaultCilPrinter}. *)
  1940: class type cilPrinter = object
  1941:   method pVDecl: unit -> varinfo -> doc
  1942:     (** Invoked for each variable declaration. Note that variable
  1943:      * declarations are all the [GVar], [GVarDecl], [GFun], all the [varinfo]
  1944:      * in formals of function types, and the formals and locals for function
  1945:      * definitions. *)
  1946: 
  1947:   method pVar: varinfo -> doc
  1948:     (** Invoked on each variable use. *)
  1949: 
  1950:   method pLval: unit -> lval -> doc
  1951:     (** Invoked on each lvalue occurence *)
  1952: 
  1953:   method pOffset: doc -> offset -> doc
  1954:     (** Invoked on each offset occurence. The second argument is the base. *)
  1955: 
  1956:   method pInstr: unit -> instr -> doc
  1957:     (** Invoked on each instruction occurrence. *)
  1958: 
  1959:   method pStmt: unit -> stmt -> doc
  1960:     (** Control-flow statement. This is used by
  1961:      * {!Flx_cil_cil.printGlobal} and by {!Flx_cil_cil.dumpGlobal}. *)
  1962: 
  1963:   method dStmt: out_channel -> int -> stmt -> unit
  1964:     (** Dump a control-flow statement to a file with a given indentation. This is used by
  1965:      * {!Flx_cil_cil.dumpGlobal}. *)
  1966: 
  1967:   method dBlock: out_channel -> int -> block -> unit
  1968:     (** Dump a control-flow block to a file with a given indentation. This is
  1969:      * used by {!Flx_cil_cil.dumpGlobal}. *)
  1970: 
  1971:   method pBlock: unit -> block -> Flx_cil_pretty.doc
  1972:     (** Print a block. *)
  1973: 
  1974:   method pGlobal: unit -> global -> doc
  1975:     (** Global (vars, types, etc.). This can be slow and is used only by
  1976:      * {!Flx_cil_cil.printGlobal} but by {!Flx_cil_cil.dumpGlobal} for everything else except
  1977:      * [GVar] and [GFun]. *)
  1978: 
  1979:   method dGlobal: out_channel -> global -> unit
  1980:     (** Dump a global to a file. This is used by {!Flx_cil_cil.dumpGlobal}. *)
  1981: 
  1982:   method pFieldDecl: unit -> fieldinfo -> doc
  1983:     (** A field declaration *)
  1984: 
  1985:   method pType: doc option -> unit -> typ -> doc
  1986:   (* Use of some type in some declaration. The first argument is used to print
  1987:    * the declared element, or is None if we are just printing a type with no
  1988:    * name being decalred. Note that for structure/union and enumeration types
  1989:    * the definition of the composite type is not visited. Use [vglob] to
  1990:    * visit it.  *)
  1991: 
  1992:   method pAttr: attribute -> doc * bool
  1993:     (** Attribute. Also return an indication whether this attribute must be
  1994:       * printed inside the __attribute__ list or not. *)
  1995: 
  1996:   method pAttrParam: unit -> attrparam -> doc
  1997:     (** Attribute paramter *)
  1998: 
  1999:   method pAttrs: unit -> attributes -> doc
  2000:     (** Attribute lists *)
  2001: 
  2002:   method pLabel: unit -> label -> doc
  2003:     (** Label *)
  2004: 
  2005:   method pLineDirective: ?forcefile:bool -> location -> Flx_cil_pretty.doc
  2006:     (** Print a line-number. This is assumed to come always on an empty line.
  2007:      * If the forcefile argument is present and is true then the file name
  2008:      * will be printed always. Otherwise the file name is printed only if it
  2009:      * is different from the last time time this function is called. The last
  2010:      * file name is stored in a private field inside the cilPrinter object. *)
  2011: 
  2012:   method pStmtKind : stmt -> unit -> stmtkind -> Flx_cil_pretty.doc
  2013:     (** Print a statement kind. The code to be printed is given in the
  2014:      * {!Flx_cil_cil.stmtkind} argument.  The initial {!Flx_cil_cil.stmt} argument
  2015:      * records the statement which follows the one being printed;
  2016:      * {!Flx_cil_cil.defaultCilPrinterClass} uses this information to prettify
  2017:      * statement printing in certain special cases. *)
  2018: 
  2019:   method pExp: unit -> exp -> doc
  2020:     (** Print expressions *)
  2021: 
  2022:   method pInit: unit -> init -> doc
  2023:     (** Print initializers. This can be slow and is used by
  2024:      * {!Flx_cil_cil.printGlobal} but not by {!Flx_cil_cil.dumpGlobal}. *)
  2025: 
  2026:   method dInit: out_channel -> int -> init -> unit
  2027:     (** Dump a global to a file with a given indentation. This is used by
  2028:      * {!Flx_cil_cil.dumpGlobal}. *)
  2029: end
  2030: 
  2031: 
  2032: class defaultCilPrinterClass : cilPrinter = object (self)
  2033:   val mutable currentFormals : varinfo list = []
  2034:   method private getLastNamedArgument (s: string) : exp =
  2035:     match List.rev currentFormals with
  2036:       f :: _ -> Lval (var f)
  2037:     | [] ->
  2038:         E.s (warn "Cannot find the last named argument when priting call to %s\n" s);
  2039:         zero
  2040: 
  2041:   (*** VARIABLES ***)
  2042:   (* variable use *)
  2043:   method pVar (v:varinfo) = text v.vname
  2044: 
  2045:   (* variable declaration *)
  2046:   method pVDecl () (v:varinfo) =
  2047:     let stom, rest = separateStorageModifiers v.vattr in
  2048:     (* First the storage modifiers *)
  2049:     text (if v.vinline then "__inline " else "")
  2050:       ++ d_storage () v.vstorage
  2051:       ++ (self#pAttrs () stom)
  2052:       ++ (self#pType (Some (text v.vname)) () v.vtype)
  2053:       ++ text " "
  2054:       ++ self#pAttrs () rest
  2055: 
  2056:   (*** L-VALUES ***)
  2057:   method pLval () (lv:lval) =  (* lval (base is 1st field)  *)
  2058:     match lv with
  2059:       Var vi, o -> self#pOffset (self#pVar vi) o
  2060:     | Mem e, Field(fi, o) ->
  2061:         self#pOffset
  2062:           ((self#pExpPrec arrowLevel () e) ++ text ("->" ^ fi.fname)) o
  2063:     | Mem e, o ->
  2064:         self#pOffset
  2065:           (text "(*" ++ self#pExpPrec derefStarLevel () e ++ text ")") o
  2066: 
  2067:   (** Offsets **)
  2068:   method pOffset (base: doc) = function
  2069:     | NoOffset -> base
  2070:     | Field (fi, o) ->
  2071:         self#pOffset (base ++ text "." ++ text fi.fname) o
  2072:     | Index (e, o) ->
  2073:         self#pOffset (base ++ text "[" ++ self#pExp () e ++ text "]") o
  2074: 
  2075:   method private pLvalPrec (contextprec: int) () lv =
  2076:     if getParenthLevel (Lval(lv)) >= contextprec then
  2077:       text "(" ++ self#pLval () lv ++ text ")"
  2078:     else
  2079:       self#pLval () lv
  2080: 
  2081:   (*** EXPRESSIONS ***)
  2082:   method pExp () (e: exp) : doc =
  2083:     let level = getParenthLevel e in
  2084:     match e with
  2085:       Const(c) -> d_const () c
  2086:     | Lval(l) -> self#pLval () l
  2087:     | UnOp(u,e1,_) ->
  2088:         let d_unop () u =
  2089:           match u with
  2090:             Neg -> text "-"
  2091:           | BNot -> text "~"
  2092:           | LNot -> text "!"
  2093:         in
  2094:         (d_unop () u) ++ chr ' ' ++ (self#pExpPrec level () e1)
  2095: 
  2096:     | BinOp(b,e1,e2,_) ->
  2097:         align
  2098:           ++ (self#pExpPrec level () e1)
  2099:           ++ chr ' '
  2100:           ++ (d_binop () b)
  2101:           ++ break
  2102:           ++ (self#pExpPrec level () e2)
  2103:           ++ unalign
  2104: 
  2105:     | CastE(t,e) ->
  2106:         text "("
  2107:           ++ self#pType None () t
  2108:           ++ text ")"
  2109:           ++ self#pExpPrec level () e
  2110: 
  2111:     | SizeOf (t) ->
  2112:         text "sizeof(" ++ self#pType None () t ++ chr ')'
  2113:     | SizeOfE (e) ->  text "sizeof(" ++ self#pExp () e ++ chr ')'
  2114: 
  2115:     | SizeOfStr s ->
  2116:         text "sizeof(" ++ d_const () (CStr s) ++ chr ')'
  2117: 
  2118:     | AlignOf (t) ->
  2119:         text "__alignof__(" ++ self#pType None () t ++ chr ')'
  2120:     | AlignOfE (e) ->
  2121:         text "__alignof__(" ++ self#pExp () e ++ chr ')'
  2122:     | AddrOf(lv) ->
  2123:         text "& " ++ (self#pLvalPrec addrOfLevel () lv)
  2124: 
  2125:     | StartOf(lv) -> self#pLval () lv
  2126: 
  2127:   method private pExpPrec (contextprec: int) () (e: exp) =
  2128:     let thisLevel = getParenthLevel e in
  2129:     let needParens =
  2130:       if thisLevel >= contextprec then
  2131:         true
  2132:       else if contextprec == bitwiseLevel then
  2133:         (* quiet down some GCC warnings *)
  2134:         thisLevel == additiveLevel || thisLevel == comparativeLevel
  2135:       else
  2136:         false
  2137:     in
  2138:     if needParens then
  2139:       chr '(' ++ self#pExp () e ++ chr ')'
  2140:     else
  2141:       self#pExp () e
  2142: 
  2143:   method pInit () = function
  2144:       SingleInit e -> self#pExp () e
  2145:     | CompoundInit (t, initl) ->
  2146:       (* We do not print the type of the Compound *)
  2147: (*
  2148:       let dinit e = d_init () e in
  2149:       dprintf "{@[%a@]}"
  2150:         (docList (chr ',' ++ break) dinit) initl
  2151: *)
  2152:         let printDesignator =
  2153:           if not !msvcMode then begin
  2154:             (* Print only for union when we do not initialize the first field *)
  2155:             match unrollType t, initl with
  2156:               TComp(ci, _), [(Field(f, NoOffset), _)] ->
  2157:                 if not (ci.cstruct) && ci.cfields != [] &&
  2158:                   (List.hd ci.cfields).fname = f.fname then
  2159:                   true
  2160:                 else
  2161:                   false
  2162:             | _ -> false
  2163:           end else
  2164:             false
  2165:         in
  2166:         let d_oneInit = function
  2167:             Field(f, NoOffset), i ->
  2168:               (if printDesignator then
  2169:                 text ("." ^ f.fname ^ " = ")
  2170:               else nil) ++ self#pInit () i
  2171:           | Index(e, NoOffset), i ->
  2172:               (if printDesignator then
  2173:                 text "[" ++ self#pExp () e ++ text "] = " else nil) ++
  2174:                 self#pInit () i
  2175:           | _ -> E.s (unimp "Trying to print malformed initializer")
  2176:         in
  2177:         chr '{' ++ (align
  2178:                       ++ ((docList (chr ',' ++ break) d_oneInit) () initl)
  2179:                       ++ unalign)
  2180:           ++ chr '}'
  2181: (*
  2182:     | ArrayInit (_, _, il) ->
  2183:         chr '{' ++ (align
  2184:                       ++ ((docList (chr ',' ++ break) (self#pInit ())) () il)
  2185:                       ++ unalign)
  2186:           ++ chr '}'
  2187: *)
  2188:   (* dump initializers to a file. *)
  2189:   method dInit (out: out_channel) (ind: int) (i: init) =
  2190:     (* Dump an array *)
  2191:     let dumpArray (bt: typ) (il: 'a list) (getelem: 'a -> init) =
  2192:       let onALine = (* How many elements on a line *)
  2193:         match unrollType bt with TComp _ | TArray _ -> 1 | _ -> 4
  2194:       in
  2195:       let rec outputElements (isfirst: bool) (room_on_line: int) = function
  2196:           [] -> output_string out "}"
  2197:         | (i: 'a) :: rest ->
  2198:             if not isfirst then output_string out ", ";
  2199:             let new_room_on_line =
  2200:               if room_on_line == 0 then begin
  2201:                 output_string out "\n"; output_string out (String.make ind ' ');
  2202:                 onALine - 1
  2203:               end else
  2204:                 room_on_line - 1
  2205:             in
  2206:             self#dInit out (ind + 2) (getelem i);
  2207:             outputElements false new_room_on_line rest
  2208:       in
  2209:       output_string out "{ ";
  2210:       outputElements true onALine il
  2211:     in
  2212:     match i with
  2213:       SingleInit e ->
  2214:         fprint out 80 (indent ind (self#pExp () e))
  2215:     | CompoundInit (t, initl) -> begin
  2216:         match unrollType t with
  2217:           TArray(bt, _, _) ->
  2218:             dumpArray bt initl (fun (_, i) -> i)
  2219:         | _ ->
  2220:             (* Now a structure or a union *)
  2221:             fprint out 80 (indent ind (self#pInit () i))
  2222:     end
  2223: (*
  2224:     | ArrayInit (bt, len, initl) -> begin
  2225:         (* If the base type does not contain structs then use the pInit
  2226:         match unrollType bt with
  2227:           TComp _ | TArray _ ->
  2228:             dumpArray bt initl (fun x -> x)
  2229:         | _ -> *)
  2230:             fprint out 80 (indent ind (self#pInit () i))
  2231:     end
  2232: *)
  2233: 
  2234:   (** What terminator to print after an instruction. sometimes we want to
  2235:    * print sequences of instructions separated by comma *)
  2236:   val mutable printInstrTerminator = ";"
  2237: 
  2238:   (*** INSTRUCTIONS ****)
  2239:   method pInstr () (i:instr) =       (* imperative instruction *)
  2240:     match i with
  2241:     | Set(lv,e,l) -> begin
  2242:         (* Be nice to some special cases *)
  2243:         match e with
  2244:           BinOp((PlusA|PlusPI|IndexPI),Lval(lv'),Const(CInt64(one,_,_)),_)
  2245:             when lv == lv' && one = Int64.one && not !printCilAsIs ->
  2246:               self#pLineDirective l
  2247:                 ++ self#pLval () lv
  2248:                 ++ text (" ++" ^ printInstrTerminator)
  2249: 
  2250:         | BinOp((MinusA|MinusPI),Lval(lv'),
  2251:                 Const(CInt64(one,_,_)), _)
  2252:             when lv == lv' && one = Int64.one && not !printCilAsIs ->
  2253:                   self#pLineDirective l
  2254:                     ++ self#pLval () lv
  2255:                     ++ text (" --" ^ printInstrTerminator)
  2256: 
  2257:         | BinOp((PlusA|PlusPI|IndexPI),Lval(lv'),Const(CInt64(mone,_,_)),_)
  2258:             when lv == lv' && mone = Int64.minus_one && not !printCilAsIs ->
  2259:               self#pLineDirective l
  2260:                 ++ self#pLval () lv
  2261:                 ++ text (" --" ^ printInstrTerminator)
  2262: 
  2263:         | BinOp((PlusA|PlusPI|IndexPI|MinusA|MinusPP|MinusPI|BAnd|BOr|BXor|
  2264:           Mult|Div|Mod|Shiftlt|Shiftrt) as bop,
  2265:                 Lval(lv'),e,_) when lv == lv' ->
  2266:                   self#pLineDirective l
  2267:                     ++ self#pLval () lv
  2268:                     ++ text " " ++ d_binop () bop
  2269:                     ++ text "= "
  2270:                     ++ self#pExp () e
  2271:                     ++ text printInstrTerminator
  2272: 
  2273:         | _ ->
  2274:             self#pLineDirective l
  2275:               ++ self#pLval () lv
  2276:               ++ text " = "
  2277:               ++ self#pExp () e
  2278:               ++ text printInstrTerminator
  2279: 
  2280:     end
  2281:       (* In cabs2cil we have turned the call to builtin_va_arg into a
  2282:        * three-argument call: the last argument is the address of the
  2283:        * destination *)
  2284:     | Call(None, Lval(Var vi, NoOffset), [dest; SizeOf t; adest], l)
  2285:         when vi.vname = "__builtin_va_arg" && not !printCilAsIs ->
  2286:           let rec stripCast = function
  2287:               CastE (_, e) -> stripCast e
  2288:             | e -> e in
  2289:           let destlv = match stripCast adest with
  2290:             AddrOf destlv -> destlv
  2291:           | _ -> E.s (E.error "Encountered unexpected call to %s\n" vi.vname)
  2292:           in
  2293:           self#pLineDirective l
  2294:             ++ self#pLval () destlv ++ text " = "
  2295: 
  2296:             (* Now the function name *)
  2297:             ++ text "__builtin_va_arg"
  2298:             ++ text "(" ++ (align
  2299:                               (* Now the arguments *)
  2300:                               ++ self#pExp () dest
  2301:                               ++ chr ',' ++ break
  2302:                               ++ self#pType None () t
  2303:                               ++ unalign)
  2304:             ++ text (")" ^ printInstrTerminator)
  2305: 
  2306:       (* In cabs2cil we have dropped the last argument in the call to
  2307:        * __builtin_stdarg_start. *)
  2308:     | Call(None, Lval(Var vi, NoOffset), [marker], l)
  2309:         when vi.vname = "__builtin_stdarg_start" && not !printCilAsIs -> begin
  2310:           let last = self#getLastNamedArgument vi.vname in
  2311:           self#pInstr () (Call(None,Lval(Var vi,NoOffset),[marker; last],l))
  2312:         end
  2313: 
  2314:       (* In cabs2cil we have dropped the last argument in the call to
  2315:        * __builtin_next_arg. *)
  2316:     | Call(res, Lval(Var vi, NoOffset), [ ], l)
  2317:         when vi.vname = "__builtin_next_arg" && not !printCilAsIs -> begin
  2318:           let last = self#getLastNamedArgument vi.vname in
  2319:           self#pInstr () (Call(res,Lval(Var vi,NoOffset),[last],l))
  2320:         end
  2321: 
  2322:     | Call(dest,e,args,l) ->
  2323:         self#pLineDirective l
  2324:           ++ (match dest with
  2325:             None -> nil
  2326:           | Some lv ->
  2327:               self#pLval () lv ++ text " = " ++
  2328:                 (* Maybe we need to print a cast *)
  2329:                 (let destt = typeOfLval lv in
  2330:                 match unrollType (typeOf e) with
  2331:                   TFun (rt, _, _, _) when typeSig rt <> typeSig destt ->
  2332:                     text "(" ++ self#pType None () destt ++ text ")"
  2333:                 | _ -> nil))
  2334:           (* Now the function name *)
  2335:           ++ (let ed = self#pExp () e in
  2336:               match e with
  2337:                 Lval(Var _, _) -> ed
  2338:               | _ -> text "(" ++ ed ++ text ")")
  2339:           ++ text "(" ++
  2340:           (align
  2341:              (* Now the arguments *)
  2342:              ++ (docList (chr ',' ++ break)
  2343:                    (self#pExp ()) () args)
  2344:              ++ unalign)
  2345:         ++ text (")" ^ printInstrTerminator)
  2346: 
  2347:     | Asm(attrs, tmpls, outs, ins, clobs, l) ->
  2348:         if !msvcMode then
  2349:           self#pLineDirective l
  2350:             ++ text "__asm {"
  2351:             ++ (align
  2352:                   ++ (docList line text () tmpls)
  2353:                   ++ unalign)
  2354:             ++ text ("}" ^ printInstrTerminator)
  2355:         else
  2356:           self#pLineDirective l
  2357:             ++ text ("__asm__ ")
  2358:             ++ self#pAttrs () attrs
  2359:             ++ text " ("
  2360:             ++ (align
  2361:                   ++ (docList line
  2362:                         (fun x -> text ("\"" ^ escape_string x ^ "\""))
  2363:                         () tmpls)
  2364:                   ++
  2365:                   (if outs = [] && ins = [] && clobs = [] then
  2366:                     nil
  2367:                 else
  2368:                   (text ": "
  2369:                      ++ (docList (chr ',' ++ break)
  2370:                            (fun (c, lv) ->
  2371:                              text ("\"" ^ escape_string c ^ "\" (")
  2372:                                ++ self#pLval () lv
  2373:                                ++ text ")") () outs)))
  2374:                 ++
  2375:                   (if ins = [] && clobs = [] then
  2376:                     nil
  2377:                   else
  2378:                     (text ": "
  2379:                        ++ (docList (chr ',' ++ break)
  2380:                              (fun (c, e) ->
  2381:                                text ("\"" ^ escape_string c ^ "\" (")
  2382:                                  ++ self#pExp () e
  2383:                                  ++ text ")") () ins)))
  2384:                   ++
  2385:                   (if clobs = [] then nil
  2386:                   else
  2387:                     (text ": "
  2388:                        ++ (docList (chr ',' ++ break)
  2389:                              (fun c -> text ("\"" ^ escape_string c ^ "\""))
  2390:                              ()
  2391:                              clobs)))
  2392:                   ++ unalign)
  2393:             ++ text (")" ^ printInstrTerminator)
  2394: 
  2395: 
  2396:   (**** STATEMENTS ****)
  2397:   method pStmt () (s:stmt) =        (* control-flow statement *)
  2398:     self#pStmtNext invalidStmt () s
  2399: 
  2400:   method dStmt (out: out_channel) (ind: int) (s:stmt) : unit =
  2401:     fprint out 80 (indent ind (self#pStmt () s))
  2402: 
  2403:   method dBlock (out: out_channel) (ind: int) (b:block) : unit =
  2404:     fprint out 80 (indent ind (self#pBlock () b))
  2405: 
  2406:   method private pStmtNext (next: stmt) () (s: stmt) =
  2407:     (* print the labels *)
  2408:     ((docList line (fun l -> self#pLabel () l)) () s.labels)
  2409:       (* print the statement itself. If the labels are non-empty and the
  2410:       * statement is empty, print a semicolon  *)
  2411:       ++
  2412:       (if s.skind = Instr [] && s.labels <> [] then
  2413:         text ";"
  2414:       else
  2415:         (if s.labels <> [] then line else nil)
  2416:           ++ self#pStmtKind next () s.skind)
  2417: 
  2418:   method private pLabel () = function
  2419:       Label (s, _, true) -> text (s ^ ": ")
  2420:     | Label (s, _, false) -> text (s ^ ": /* CIL Label */ ")
  2421:     | Case (e, _) -> text "case " ++ self#pExp () e ++ text ": "
  2422:     | Default _ -> text "default: "
  2423: 
  2424:   (* The pBlock will put the unalign itself *)
  2425:   method pBlock () (blk: block) =
  2426:     let rec dofirst () = function
  2427:         [] -> nil
  2428:       | [x] -> self#pStmtNext invalidStmt () x
  2429:       | x :: rest -> dorest nil x rest
  2430:     and dorest acc prev = function
  2431:         [] -> acc ++ (self#pStmtNext invalidStmt () prev)
  2432:       | x :: rest ->
  2433:           dorest (acc ++ (self#pStmtNext x () prev) ++ line)
  2434:             x rest
  2435:     in
  2436:     (* Let the host of the block decide on the alignment. The d_block will
  2437:      * pop the alignment as well  *)
  2438:     text "{"
  2439:       ++
  2440:       (if blk.battrs <> [] then
  2441:         self#pAttrsGen true blk.battrs
  2442:       else nil)
  2443:       ++ line
  2444:       ++ (dofirst () blk.bstmts)
  2445:       ++ unalign ++ line ++ text "}"
  2446: 
  2447: 
  2448:   (* Store here the name of the last file printed in a line number. This is
  2449:    * private to the object *)
  2450:   val mutable lastFileName = ""
  2451:   (* Make sure that you only call self#pLineDirective on an empty line *)
  2452:   method pLineDirective ?(forcefile=false) l =
  2453:     currentLoc := l;
  2454:     match !lineDirectiveStyle with
  2455:     | Some style when l.line > 0 ->
  2456:         let directive =
  2457:           match style with
  2458:           | LineComment -> text "//#line "
  2459:           | LinePreprocessorOutput when not !msvcMode -> chr '#'
  2460:           | _ -> text "#line"
  2461:         in
  2462:         let filename =
  2463:           if forcefile || l.file <> lastFileName then
  2464:             begin
  2465:               lastFileName <- l.file;
  2466:               text " \"" ++ text l.file ++ text "\""
  2467:             end
  2468:           else
  2469:             nil
  2470:         in
  2471:         leftflush ++ directive ++ chr ' ' ++ num l.line ++ filename ++ line
  2472:     | _ ->
  2473:         nil
  2474: 
  2475: 
  2476:   method private pStmtKind (next: stmt) () = function
  2477:       Return(None, l) ->
  2478:         self#pLineDirective l
  2479:           ++ text "return;"
  2480: 
  2481:     | Return(Some e, l) ->
  2482:         self#pLineDirective l
  2483:           ++ text "return ("
  2484:           ++ self#pExp () e
  2485:           ++ text ");"
  2486: 
  2487:     | Goto (sref, l) -> begin
  2488:         (* Grab one of the labels *)
  2489:         let rec pickLabel = function
  2490:             [] -> None
  2491:           | Label (l, _, _) :: _ -> Some l
  2492:           | _ :: rest -> pickLabel rest
  2493:         in
  2494:         match pickLabel !sref.labels with
  2495:           Some l -> text ("goto " ^ l ^ ";")
  2496:         | None ->
  2497:             ignore (error "Cannot find label for target of goto\n");
  2498:             text "goto __invalid_label;"
  2499:     end
  2500: 
  2501:     | Break l ->
  2502:         self#pLineDirective l
  2503:           ++ text "break;"
  2504: 
  2505:     | Continue l ->
  2506:         self#pLineDirective l
  2507:           ++ text "continue;"
  2508: 
  2509:     | Instr il ->
  2510:         align
  2511:           ++ (docList line (fun i -> self#pInstr () i) () il)
  2512:           ++ unalign
  2513: 
  2514:     | If(be,t,{bstmts=[];battrs=[]},l) when not !printCilAsIs ->
  2515:         self#pLineDirective l
  2516:           ++ text "if"
  2517:           ++ (align
  2518:                 ++ text " ("
  2519:                 ++ self#pExp () be
  2520:                 ++ text ") "
  2521:                 ++ self#pBlock () t)
  2522: 
  2523:     | If(be,t,{bstmts=[{skind=Goto(gref,_);labels=[]} as s];
  2524:                 battrs=[]},l)
  2525:      when !gref == next && not !printCilAsIs ->
  2526:        self#pLineDirective l
  2527:          ++ text "if"
  2528:          ++ (align
  2529:                ++ text " ("
  2530:                ++ self#pExp () be
  2531:                ++ text ") "
  2532:                ++ self#pBlock () t)
  2533: 
  2534:     | If(be,{bstmts=[];battrs=[]},e,l) when not !printCilAsIs ->
  2535:         self#pLineDirective l
  2536:           ++ text "if"
  2537:           ++ (align
  2538:                 ++ text " ("
  2539:                 ++ self#pExp () (UnOp(LNot,be,intType))
  2540:                 ++ text ") "
  2541:                 ++ self#pBlock () e)
  2542: 
  2543:     | If(be,{bstmts=[{skind=Goto(gref,_);labels=[]} as s];
  2544:            battrs=[]},e,l)
  2545:       when !gref == next && not !printCilAsIs ->
  2546:         self#pLineDirective l
  2547:           ++ text "if"
  2548:           ++ (align
  2549:                 ++ text " ("
  2550:                 ++ self#pExp () (UnOp(LNot,be,intType))
  2551:                 ++ text ") "
  2552:                 ++ self#pBlock () e)
  2553: 
  2554:     | If(be,t,e,l) ->
  2555:         self#pLineDirective l
  2556:           ++ (align
  2557:                 ++ text "if"
  2558:                 ++ (align
  2559:                       ++ text " ("
  2560:                       ++ self#pExp () be
  2561:                       ++ text ") "
  2562:                       ++ self#pBlock () t)
  2563:                 ++ text " "   (* sm: indent next code 2 spaces (was 4) *)
  2564:                 ++ (align
  2565:                       ++ text "else "
  2566:                       ++ self#pBlock () e)
  2567:           ++ unalign)
  2568: 
  2569:     | Switch(e,b,_,l) ->
  2570:         self#pLineDirective l
  2571:           ++ (align
  2572:                 ++ text "switch ("
  2573:                 ++ self#pExp () e
  2574:                 ++ text ") "
  2575:                 ++ self#pBlock () b)
  2576:     | Loop(b, l, _, _) -> begin
  2577:         (* Maybe the first thing is a conditional. Turn it into a WHILE *)
  2578:         try
  2579:           let term, bodystmts =
  2580:             let rec skipEmpty = function
  2581:                 [] -> []
  2582:               | {skind=Instr [];labels=[]} :: rest -> skipEmpty rest
  2583:               | x -> x
  2584:             in
  2585:             (* Bill McCloskey: Do not remove the If if it has labels *)
  2586:             match skipEmpty b.bstmts with
  2587:               {skind=If(e,tb,fb,_); labels=[]} :: rest
  2588:                                               when not !printCilAsIs -> begin
  2589:                 match skipEmpty tb.bstmts, skipEmpty fb.bstmts with
  2590:                   [], {skind=Break _; labels=[]} :: _  -> e, rest
  2591:                 | {skind=Break _; labels=[]} :: _, []
  2592:                                      -> UnOp(LNot, e, intType), rest
  2593:                 | _ -> raise Not_found
  2594:               end
  2595:             | _ -> raise Not_found
  2596:           in
  2597:           self#pLineDirective l
  2598:             ++ text "wh"
  2599:             ++ (align
  2600:                   ++ text "ile ("
  2601:                   ++ self#pExp () term
  2602:                   ++ text ") "
  2603:                   ++ self#pBlock () {bstmts=bodystmts; battrs=b.battrs})
  2604: 
  2605:         with Not_found ->
  2606:           self#pLineDirective l
  2607:             ++ text "wh"
  2608:             ++ (align
  2609:                   ++ text "ile (1) "
  2610:                   ++ self#pBlock () b)
  2611:     end
  2612:     | Block b -> align ++ self#pBlock () b
  2613: 
  2614:     | TryFinally (b, h, l) ->
  2615:         self#pLineDirective l
  2616:           ++ text "__try "
  2617:           ++ align
  2618:           ++ self#pBlock () b
  2619:           ++ text " __fin" ++ align ++ text "ally "
  2620:           ++ self#pBlock () h
  2621: 
  2622:     | TryExcept (b, (il, e), h, l) ->
  2623:         self#pLineDirective l
  2624:           ++ text "__try "
  2625:           ++ align
  2626:           ++ self#pBlock () b
  2627:           ++ text " __e" ++ align ++ text "xcept(" ++ line
  2628:           ++ align
  2629:           (* Print the instructions but with a comma at the end, instead of
  2630:            * semicolon *)
  2631:           ++ (printInstrTerminator <- ",";
  2632:               let res =
  2633:                 (docList line (self#pInstr ())
  2634:                    () il)
  2635:               in
  2636:               printInstrTerminator <- ";";
  2637:               res)
  2638:           ++ self#pExp () e
  2639:           ++ text ") " ++ unalign
  2640:           ++ self#pBlock () h
  2641: 
  2642: 
  2643:   (*** GLOBALS ***)
  2644:   method pGlobal () (g:global) : doc =       (* global (vars, types, etc.) *)
  2645:     match g with
  2646:     | GFun (fundec, l) ->
  2647:         (* If the function has attributes then print a prototype because
  2648:         * GCC cannot accept function attributes in a definition *)
  2649:         let oldattr = fundec.svar.vattr in
  2650:         (* Always pring the file name before function declarations *)
  2651:         let proto =
  2652:           if oldattr <> [] then
  2653:             (self#pLineDirective l) ++ (self#pVDecl () fundec.svar)
  2654:               ++ chr ';' ++ line
  2655:           else nil in
  2656:         (* Temporarily remove the function attributes *)
  2657:         fundec.svar.vattr <- [];
  2658:         let body = (self#pLineDirective ~forcefile:true l)
  2659:                       ++ (self#pFunDecl () fundec) in
  2660:         fundec.svar.vattr <- oldattr;
  2661:         proto ++ body ++ line
  2662: 
  2663:     | GType (typ, l) ->
  2664:         self#pLineDirective ~forcefile:true l ++
  2665:           text "typedef "
  2666:           ++ (self#pType (Some (text typ.tname)) () typ.ttype)
  2667:           ++ text ";\n"
  2668: 
  2669:     | GEnumTag (enum, l) ->
  2670:         self#pLineDirective l ++
  2671:           text "enum" ++ align ++ text (" " ^ enum.ename) ++
  2672:           self#pAttrs () enum.eattr ++ text " {" ++ line
  2673:           ++ (docList (chr ',' ++ line)
  2674:                 (fun (n,i, loc) ->
  2675:                   text (n ^ " = ")
  2676:                     ++ self#pExp () i)
  2677:                 () enum.eitems)
  2678:           ++ unalign ++ line ++ text "};\n"
  2679: 
  2680:     | GEnumTagDecl (enum, l) -> (* This is a declaration of a tag *)
  2681:         self#pLineDirective l ++
  2682:           text ("enum " ^ enum.ename ^ ";\n")
  2683: 
  2684:     | GCompTag (comp, l) -> (* This is a definition of a tag *)
  2685:         let n = comp.cname in
  2686:         let su, su1, su2 =
  2687:           if comp.cstruct then "struct", "str", "uct"
  2688:           else "union",  "uni", "on"
  2689:         in
  2690:         let sto_mod, rest_attr = separateStorageModifiers comp.cattr in
  2691:         self#pLineDirective ~forcefile:true l ++
  2692:           text su1 ++ (align ++ text su2 ++ chr ' ' ++ (self#pAttrs () sto_mod)
  2693:                          ++ text n
  2694:                          ++ text " {" ++ line
  2695:                          ++ ((docList line (self#pFieldDecl ())) ()
  2696:                                comp.cfields)
  2697:                          ++ unalign)
  2698:           ++ line ++ text "}" ++
  2699:           (self#pAttrs () rest_attr) ++ text ";\n"
  2700: 
  2701:     | GCompTagDecl (comp, l) -> (* This is a declaration of a tag *)
  2702:         self#pLineDirective l ++
  2703:           text (compFullName comp) ++ text ";\n"
  2704: 
  2705:     | GVar (vi, io, l) ->
  2706:         self#pLineDirective ~forcefile:true l ++
  2707:           self#pVDecl () vi
  2708:           ++ chr ' '
  2709:           ++ (match io.init with
  2710:             None -> nil
  2711:           | Some i -> text " = " ++
  2712:                 (let islong =
  2713:                   match i with
  2714:                     CompoundInit (_, il) when List.length il >= 8 -> true
  2715:                   | _ -> false
  2716:                 in
  2717:                 if islong then
  2718:                   line ++ self#pLineDirective l ++ text "  "
  2719:                 else nil) ++
  2720:                 (self#pInit () i))
  2721:           ++ text ";\n"
  2722: 
  2723:     (* print global variable 'extern' declarations, and function prototypes *)
  2724:     | GVarDecl (vi, l) ->
  2725:         self#pLineDirective l ++
  2726:           (self#pVDecl () vi)
  2727:           ++ text ";\n"
  2728: 
  2729:     | GAsm (s, l) ->
  2730:         self#pLineDirective l ++
  2731:           text ("__asm__(\"" ^ escape_string s ^ "\");\n")
  2732: 
  2733:     | GPragma (Attr(an, args), l) ->
  2734:         (* sm: suppress printing pragmas that gcc does not understand *)
  2735:         (* assume anything starting with "ccured" is ours *)
  2736:         (* also don't print the 'combiner' pragma *)
  2737:         (* nor 'cilnoremove' *)
  2738:         let suppress =
  2739:           not !print_CIL_Input &&
  2740:           not !msvcMode &&
  2741:           ((startsWith "box" an) ||
  2742:            (startsWith "ccured" an) ||
  2743:            (an = "merger") ||
  2744:            (an = "cilnoremove")) in
  2745:         let d =
  2746:           match an, args with
  2747:           | _, [] ->
  2748:               text an
  2749:           | "weak", [ACons (symbol, [])] ->
  2750:               text "weak " ++ text symbol
  2751:           | _ ->
  2752:             text (an ^ "(")
  2753:               ++ docList (chr ',') (self#pAttrParam ()) () args
  2754:               ++ text ")"
  2755:         in
  2756:         self#pLineDirective l
  2757:           ++ (if suppress then text "/* " else text "")
  2758:           ++ (text "#pragma ")
  2759:           ++ d
  2760:           ++ (if suppress then text " */\n" else text "\n")
  2761: 
  2762:     | GText s  ->
  2763:         if s <> "//" then
  2764:           text s ++ text "\n"
  2765:         else
  2766:           nil
  2767: 
  2768: 
  2769:    method dGlobal (out: out_channel) (g: global) : unit =
  2770:      (* For all except functions and variable with initializers, use the
  2771:       * pGlobal *)
  2772:      match g with
  2773:        GFun (fdec, l) ->
  2774:          (* If the function has attributes then print a prototype because
  2775:           * GCC cannot accept function attributes in a definition *)
  2776:          let oldattr = fdec.svar.vattr in
  2777:          let proto =
  2778:            if oldattr <> [] then
  2779:              (self#pLineDirective l) ++ (self#pVDecl () fdec.svar)
  2780:                ++ chr ';' ++ line
  2781:            else nil in
  2782:          fprint out 80 (proto ++ (self#pLineDirective ~forcefile:true l));
  2783:          (* Temporarily remove the function attributes *)
  2784:          fdec.svar.vattr <- [];
  2785:          fprint out 80 (self#pFunDecl () fdec);
  2786:          fdec.svar.vattr <- oldattr;
  2787:          output_string out "\n"
  2788: 
  2789:      | GVar (vi, {init = Some i}, l) -> begin
  2790:          fprint out 80
  2791:            (self#pLineDirective ~forcefile:true l ++
  2792:               self#pVDecl () vi
  2793:               ++ text " = "
  2794:               ++ (let islong =
  2795:                 match i with
  2796:                   CompoundInit (_, il) when List.length il >= 8 -> true
  2797:                 | _ -> false
  2798:               in
  2799:               if islong then
  2800:                 line ++ self#pLineDirective l ++ text "  "
  2801:               else nil));
  2802:          self#dInit out 3 i;
  2803:          output_string out ";\n"
  2804:      end
  2805: 
  2806:      | g -> fprint out 80 (self#pGlobal () g)
  2807: 
  2808:    method pFieldDecl () fi =
  2809:      (self#pType
  2810:         (Some (text (if fi.fname = missingFieldName then "" else fi.fname)))
  2811:         ()
  2812:         fi.ftype)
  2813:        ++ text " "
  2814:        ++ (match fi.fbitfield with None -> nil
  2815:        | Some i -> text ": " ++ num i ++ text " ")
  2816:        ++ self#pAttrs () fi.fattr
  2817:        ++ text ";"
  2818: 
  2819:   method private pFunDecl () f =
  2820:       self#pVDecl () f.svar
  2821:       ++  line
  2822:       ++ text "{ "
  2823:       ++ (align
  2824:             (* locals. *)
  2825:             ++ (docList line (fun vi -> self#pVDecl () vi ++ text ";")
  2826:                   () f.slocals)
  2827:             ++ line ++ line
  2828:             (* the body *)
  2829:             ++ ((* remember the declaration *) currentFormals <- f.sformals;
  2830:                 let body = self#pBlock () f.sbody in
  2831:                 currentFormals <- [];
  2832:                 body))
  2833:       ++ line
  2834:       ++ text "}"
  2835: 
  2836:   (***** PRINTING DECLARATIONS and TYPES ****)
  2837: 
  2838:   method pType (nameOpt: doc option) (* Whether we are declaring a name or
  2839:                                       * we are just printing a type *)
  2840:                () (t:typ) =       (* use of some type *)
  2841:     let name = match nameOpt with None -> nil | Some d -> d in
  2842:     let printAttributes (a: attributes) =
  2843:       let pa = self#pAttrs () a in
  2844:       match nameOpt with
  2845:       | None when not !print_CIL_Input && not !msvcMode ->
  2846:           (* Cannot print the attributes in this case because gcc does not
  2847:            * like them here, except if we are printing for CIL, or for MSVC.
  2848:            * In fact, for MSVC we MUST print attributes such as __stdcall *)
  2849:           if pa = nil then nil else
  2850:           text "/*" ++ pa ++ text "*/"
  2851:       | _ -> pa
  2852:     in
  2853:     match t with
  2854:       TVoid a ->
  2855:         text "void"
  2856:           ++ self#pAttrs () a
  2857:           ++ text " "
  2858:           ++ name
  2859: 
  2860:     | TInt (ikind,a) ->
  2861:         d_ikind () ikind
  2862:           ++ self#pAttrs () a
  2863:           ++ text " "
  2864:           ++ name
  2865: 
  2866:     | TFloat(fkind, a) ->
  2867:         d_fkind () fkind
  2868:           ++ self#pAttrs () a
  2869:           ++ text " "
  2870:           ++ name
  2871: 
  2872:     | TComp (comp, a) -> (* A reference to a struct *)
  2873:         let su = if comp.cstruct then "struct" else "union" in
  2874:         text (su ^ " " ^ comp.cname ^ " ")
  2875:           ++ self#pAttrs () a
  2876:           ++ name
  2877: 
  2878:     | TEnum (enum, a) ->
  2879:         text ("enum " ^ enum.ename ^ " ")
  2880:           ++ self#pAttrs () a
  2881:           ++ name
  2882:     | TPtr (bt, a)  ->
  2883:         (* Parenthesize the ( * attr name) if a pointer to a function or an
  2884:          * array. However, on MSVC the __stdcall modifier must appear right
  2885:          * before the pointer constructor "(__stdcall *f)". We push them into
  2886:          * the parenthesis. *)
  2887:         let (paren: doc option), (bt': typ) =
  2888:           match bt with
  2889:             TFun(rt, args, isva, fa) when !msvcMode ->
  2890:               let an, af', at = partitionAttributes ~default:AttrType fa in
  2891:               (* We take the af' and we put them into the parentheses *)
  2892:               Some (text "(" ++ printAttributes af'),
  2893:               TFun(rt, args, isva, addAttributes an at)
  2894: 
  2895:           | TFun _ | TArray _ -> Some (text "("), bt
  2896: 
  2897:           | _ -> None, bt
  2898:         in
  2899:         let name' = text "*" ++ printAttributes a ++ name in
  2900:         let name'' = (* Put the parenthesis *)
  2901:           match paren with
  2902:             Some p -> p ++ name' ++ text ")"
  2903:           | _ -> name'
  2904:         in
  2905:         self#pType
  2906:           (Some name'')
  2907:           ()
  2908:           bt'
  2909: 
  2910:     | TArray (elemt, lo, a) ->
  2911:         let name' =
  2912:           if a == [] then name else
  2913:           if nameOpt == None then printAttributes a else
  2914:           text "(" ++ printAttributes a ++ name ++ text ")"
  2915:         in
  2916:         self#pType
  2917:           (Some (name'
  2918:                    ++ text "["
  2919:                    ++ (match lo with None -> nil | Some e -> self#pExp () e)
  2920:                    ++ text "]"))
  2921:           ()
  2922:           elemt
  2923: 
  2924:     | TFun (restyp, args, isvararg, a) ->
  2925:         let name' =
  2926:           if a == [] then name else
  2927:           if nameOpt == None then printAttributes a else
  2928:           text "(" ++ printAttributes a ++ name ++ text ")"
  2929:         in
  2930:         self#pType
  2931:           (Some
  2932:              (name'
  2933:                 ++ text "("
  2934:                 ++ (align
  2935:                       ++
  2936:                       (if args = Some [] && isvararg then
  2937:                         text "..."
  2938:                       else
  2939:                         (if args = None then nil
  2940:                         else if args = Some [] then text "void"
  2941:                         else
  2942:                           let pArg (aname, atype, aattr) =
  2943:                             let stom, rest = separateStorageModifiers aattr in
  2944:                             (* First the storage modifiers *)
  2945:                             (self#pAttrs () stom)
  2946:                               ++ (self#pType (Some (text aname)) () atype)
  2947:                               ++ text " "
  2948:                               ++ self#pAttrs () rest
  2949:                           in
  2950:                           (docList (chr ',' ++ break) pArg) ()
  2951:                             (argsToList args))
  2952:                           ++ (if isvararg then break ++ text ", ..." else nil))
  2953:                       ++ unalign)
  2954:                 ++ text ")"))
  2955:           ()
  2956:           restyp
  2957: 
  2958:   | TNamed (t, a) ->
  2959:       text t.tname ++ self#pAttrs () a ++ text " " ++ name
  2960: 
  2961:   | TBuiltin_va_list a ->
  2962:       text "__builtin_va_list"
  2963:        ++ self#pAttrs () a
  2964:         ++ text " "
  2965:         ++ name
  2966: 
  2967: 
  2968:   (**** PRINTING ATTRIBUTES *********)
  2969:   method pAttrs () (a: attributes) =
  2970:     self#pAttrsGen false a
  2971: 
  2972: 
  2973:   (* Print one attribute. Return also an indication whether this attribute
  2974:    * should be printed inside the __attribute__ list *)
  2975:   method pAttr (Attr(an, args): attribute) : doc * bool =
  2976:     (* Recognize and take care of some known cases *)
  2977:     match an, args with
  2978:       "const", [] -> text "const", false
  2979:           (* Put the aconst inside the attribute list *)
  2980:     | "aconst", [] when not !msvcMode -> text "__const__", true
  2981:     | "thread", [] when not !msvcMode -> text "__thread", false
  2982:     | "volatile", [] -> text "volatile", false
  2983:     | "restrict", [] -> text "__restrict", false
  2984:     | "missingproto", [] -> text "/* missing proto */", false
  2985:     | "cdecl", [] when !msvcMode -> text "__cdecl", false
  2986:     | "stdcall", [] when !msvcMode -> text "__stdcall", false
  2987:     | "fastcall", [] when !msvcMode -> text "__fastcall", false
  2988:     | "declspec", args when !msvcMode ->
  2989:         text "__declspec("
  2990:           ++ docList (chr ',') (self#pAttrParam ()) () args
  2991:           ++ text ")", false
  2992:     | "w64", [] when !msvcMode -> text "__w64", false
  2993:     | "asm", args ->
  2994:         text "__asm__("
  2995:           ++ docList (chr ',') (self#pAttrParam ()) () args
  2996:           ++ text ")", false
  2997:     (* we suppress printing mode(__si__) because it triggers an *)
  2998:     (* internal compiler error in all current gcc versions *)
  2999:     (* sm: I've now encountered a problem with mode(__hi__)... *)
  3000:     (* I don't know what's going on, but let's try disabling all "mode"..*)
  3001:     | "mode", [ACons(tag,[])] ->
  3002:         text "/* mode(" ++ text tag ++ text ") */", false
  3003: 
  3004:     (* sm: also suppress "format" because we seem to print it in *)
  3005:     (* a way gcc does not like *)
  3006:     | "format", _ -> text "/* format attribute */", false
  3007: 
  3008:     (* sm: here's another one I don't want to see gcc warnings about.. *)
  3009:     | "mayPointToStack", _ when not !print_CIL_Input
  3010:     (* [matth: may be inside another comment.]
  3011:       -> text "/*mayPointToStack*/", false
  3012:     *)
  3013:       -> text "", false
  3014: 
  3015:     | _ -> (* This is the dafault case *)
  3016:         (* Add underscores to the name *)
  3017:         let an' = if !msvcMode then "__" ^ an else "__" ^ an ^ "__" in
  3018:         if args = [] then
  3019:           text an', true
  3020:         else
  3021:           text (an' ^ "(")
  3022:             ++ (docList (chr ',') (self#pAttrParam ()) () args)
  3023:             ++ text ")",
  3024:           true
  3025: 
  3026:   method pAttrParam () = function
  3027:     | AInt n -> num n
  3028:     | AStr s -> text ("\"" ^ escape_string s ^ "\"")
  3029:     | ACons(s, []) -> text s
  3030:     | ACons(s,al) ->
  3031:         text (s ^ "(")
  3032:           ++ (docList (chr ',') (self#pAttrParam ()) () al)
  3033:           ++ text ")"
  3034:     | ASizeOfE a -> text "sizeof(" ++ self#pAttrParam () a ++ text ")"
  3035:     | ASizeOf t -> text "sizeof(" ++ self#pType None () t ++ text ")"
  3036:     | AAlignOfE a -> text "__alignof__(" ++ self#pAttrParam () a ++ text ")"
  3037:     | AAlignOf t -> text "__alignof__(" ++ self#pType None () t ++ text ")"
  3038:     | AUnOp(u,a1) ->
  3039:         let d_unop () u =
  3040:           match u with
  3041:             Neg -> text "-"
  3042:           | BNot -> text "~"
  3043:           | LNot -> text "!"
  3044:         in
  3045:         (d_unop () u) ++ text " (" ++ (self#pAttrParam () a1) ++ text ")"
  3046: 
  3047:     | ABinOp(b,a1,a2) ->
  3048:         align
  3049:           ++ text "("
  3050:           ++ (self#pAttrParam () a1)
  3051:           ++ text ") "
  3052:           ++ (d_binop () b)
  3053:           ++ break
  3054:           ++ text " (" ++ (self#pAttrParam () a2) ++ text ") "
  3055:           ++ unalign
  3056:     | ADot (ap, s) -> (self#pAttrParam () ap) ++ text ("." ^ s)
  3057: 
  3058:   (* A general way of printing lists of attributes *)
  3059:   method private pAttrsGen (block: bool) (a: attributes) =
  3060:     (* Scan all the attributes and separate those that must be printed inside
  3061:      * the __attribute__ list *)
  3062:     let rec loop (in__attr__: doc list) = function
  3063:         [] -> begin
  3064:           match in__attr__ with
  3065:             [] -> nil
  3066:           | _ :: _->
  3067:               (* sm: added 'forgcc' calls to not comment things out
  3068:                * if CIL is the consumer; this is to address a case
  3069:                * Daniel ran into where blockattribute(nobox) was being
  3070:                * dropped by the merger
  3071:                *)
  3072:               (if block then
  3073:                 text (" " ^ (forgcc "/*") ^ " __blockattribute__(")
  3074:                else
  3075:                  text "__attribute__((")
  3076: 
  3077:                 ++ (docList (chr ',' ++ break)
  3078:                       (fun a -> a)) () in__attr__
  3079:                 ++ text ")"
  3080:                 ++ (if block then text (forgcc "*/") else text ")")
  3081:         end
  3082:       | x :: rest ->
  3083:           let dx, ina = self#pAttr x in
  3084:           if ina then
  3085:             loop (dx :: in__attr__) rest
  3086:           else
  3087:             dx ++ text " " ++ loop in__attr__ rest
  3088:     in
  3089:     let res = loop [] a in
  3090:     if res = nil then
  3091:       res
  3092:     else
  3093:       text " " ++ res ++ text " "
  3094: 
  3095: end (* class defaultCilPrinterClass *)
  3096: 
  3097: let defaultCilPrinter = new defaultCilPrinterClass
  3098: 
  3099: (* Top-level printing functions *)
  3100: let printType (pp: cilPrinter) () (t: typ) : doc =
  3101:   pp#pType None () t
  3102: 
  3103: let printExp (pp: cilPrinter) () (e: exp) : doc =
  3104:   pp#pExp () e
  3105: 
  3106: let printLval (pp: cilPrinter) () (lv: lval) : doc =
  3107:   pp#pLval () lv
  3108: 
  3109: let printGlobal (pp: cilPrinter) () (g: global) : doc =
  3110:   pp#pGlobal () g
  3111: 
  3112: let dumpGlobal (pp: cilPrinter) (out: out_channel) (g: global) : unit =
  3113:   pp#dGlobal out g
  3114: 
  3115: let printAttr (pp: cilPrinter) () (a: attribute) : doc =
  3116:   let ad, _ = pp#pAttr a in ad
  3117: 
  3118: let printAttrs (pp: cilPrinter) () (a: attributes) : doc =
  3119:   pp#pAttrs () a
  3120: 
  3121: let printInstr (pp: cilPrinter) () (i: instr) : doc =
  3122:   pp#pInstr () i
  3123: 
  3124: let printStmt (pp: cilPrinter) () (s: stmt) : doc =
  3125:   pp#pStmt () s
  3126: 
  3127: let printBlock (pp: cilPrinter) () (b: block) : doc =
  3128:   (* We must add the alignment ourselves, beucase pBlock will pop it *)
  3129:   align ++ pp#pBlock () b
  3130: 
  3131: let dumpStmt (pp: cilPrinter) (out: out_channel) (ind: int) (s: stmt) : unit =
  3132:   pp#dStmt out ind s
  3133: 
  3134: let dumpBlock (pp: cilPrinter) (out: out_channel) (ind: int) (b: block) : unit =
  3135:   pp#dBlock out ind b
  3136: 
  3137: let printInit (pp: cilPrinter) () (i: init) : doc =
  3138:   pp#pInit () i
  3139: 
  3140: let dumpInit (pp: cilPrinter) (out: out_channel) (ind: int) (i: init) : unit =
  3141:   pp#dInit out ind i
  3142: 
  3143: (* Now define some short cuts *)
  3144: let d_exp () e = printExp defaultCilPrinter () e
  3145: let d_lval () lv = printLval defaultCilPrinter () lv
  3146: let d_offset base () off = defaultCilPrinter#pOffset base off
  3147: let d_init () i = printInit defaultCilPrinter () i
  3148: let d_type () t = printType defaultCilPrinter () t
  3149: let d_global () g = printGlobal defaultCilPrinter () g
  3150: let d_attrlist () a = printAttrs defaultCilPrinter () a
  3151: let d_attr () a = printAttr defaultCilPrinter () a
  3152: let d_attrparam () e = defaultCilPrinter#pAttrParam () e
  3153: let d_label () l = defaultCilPrinter#pLabel () l
  3154: let d_stmt () s = printStmt defaultCilPrinter () s
  3155: let d_block () b = printBlock defaultCilPrinter () b
  3156: let d_instr () i = printInstr defaultCilPrinter () i
  3157: 
  3158: let d_shortglobal () = function
  3159:     GPragma (Attr(an, _), _) -> dprintf "#pragma %s" an
  3160:   | GType (ti, _) -> dprintf "typedef %s" ti.tname
  3161:   | GVarDecl (vi, _) -> dprintf "declaration of %s" vi.vname
  3162:   | GVar (vi, _, _) -> dprintf "definition of %s" vi.vname
  3163:   | GCompTag(ci,_) -> dprintf "definition of %s" (compFullName ci)
  3164:   | GCompTagDecl(ci,_) -> dprintf "declaration of %s" (compFullName ci)
  3165:   | GEnumTag(ei,_) -> dprintf "definition of enum %s" ei.ename
  3166:   | GEnumTagDecl(ei,_) -> dprintf "declaration of enum %s" ei.ename
  3167:   | GFun(fd, _) -> dprintf "definition of %s" fd.svar.vname
  3168:   | GText _ -> text "GText"
  3169:   | GAsm _ -> text "GAsm"
  3170: 
  3171: 
  3172: (* sm: given an ordinary CIL object printer, yield one which
  3173:  * behaves the same, except it never prints #line directives
  3174:  * (this is useful for debugging printfs) *)
  3175: let dn_obj (func: unit -> 'a -> doc) : (unit -> 'a -> doc) =
  3176: begin
  3177:   (* construct the closure to return *)
  3178:   let theFunc () (obj:'a) : doc =
  3179:   begin
  3180:     let prevStyle = !lineDirectiveStyle in
  3181:     lineDirectiveStyle := None;
  3182:     let ret = (func () obj) in    (* call underlying printer *)
  3183:     lineDirectiveStyle := prevStyle;
  3184:     ret
  3185:   end in
  3186:   theFunc
  3187: end
  3188: 
  3189: (* now define shortcuts for the non-location-printing versions,
  3190:  * with the naming prefix "dn_" *)
  3191: let dn_exp       = (dn_obj d_exp)
  3192: let dn_lval      = (dn_obj d_lval)
  3193: (* dn_offset is missing because it has a different interface *)
  3194: let dn_init      = (dn_obj d_init)
  3195: let dn_type      = (dn_obj d_type)
  3196: let dn_global    = (dn_obj d_global)
  3197: let dn_attrlist  = (dn_obj d_attrlist)
  3198: let dn_attr      = (dn_obj d_attr)
  3199: let dn_attrparam = (dn_obj d_attrparam)
  3200: let dn_stmt      = (dn_obj d_stmt)
  3201: let dn_instr     = (dn_obj d_instr)
  3202: 
  3203: 
  3204: (* Now define a cilPlainPrinter *)
  3205: class plainCilPrinterClass =
  3206:   (* We keep track of the composite types that we have done to avoid
  3207:    * recursion *)
  3208:   let donecomps : (int, unit) H.t = H.create 13 in
  3209:   object (self)
  3210: 
  3211:   inherit defaultCilPrinterClass as super
  3212: 
  3213:   (*** PLAIN TYPES ***)
  3214:   method pType (dn: doc option) () (t: typ) =
  3215:     match dn with
  3216:       None -> self#pOnlyType () t
  3217:     | Some d -> d ++ text " : " ++ self#pOnlyType () t
  3218: 
  3219:  method private pOnlyType () = function
  3220:      TVoid a -> dprintf "TVoid(@[%a@])" self#pAttrs a
  3221:    | TInt(ikind, a) -> dprintf "TInt(@[%a,@?%a@])"
  3222:          d_ikind ikind self#pAttrs a
  3223:    | TFloat(fkind, a) ->
  3224:        dprintf "TFloat(@[%a,@?%a@])" d_fkind fkind self#pAttrs a
  3225:    | TNamed (t, a) ->
  3226:        dprintf "TNamed(@[%s,@?%a,@?%a@])"
  3227:          t.tname self#pOnlyType t.ttype self#pAttrs a
  3228:    | TPtr(t, a) -> dprintf "TPtr(@[%a,@?%a@])" self#pOnlyType t self#pAttrs a
  3229:    | TArray(t,l,a) ->
  3230:        let dl = match l with
  3231:          None -> text "None" | Some l -> dprintf "Some(@[%a@])" self#pExp l in
  3232:        dprintf "TArray(@[%a,@?%a,@?%a@])"
  3233:          self#pOnlyType t insert dl self#pAttrs a
  3234:    | TEnum(enum,a) -> dprintf "Enum(%s,@[%a@])" enum.ename self#pAttrs a
  3235:    | TFun(tr,args,isva,a) ->
  3236:        dprintf "TFun(@[%a,@?%a%s,@?%a@])"
  3237:          self#pOnlyType tr
  3238:          insert
  3239:          (if args = None then text "None"
  3240:          else (docList (chr ',' ++ break)
  3241:                  (fun (an,at,aa) ->
  3242:                    dprintf "%s: %a" an self#pOnlyType at))
  3243:              ()
  3244:              (argsToList args))
  3245:          (if isva then "..." else "") self#pAttrs a
  3246:    | TComp (comp, a) ->
  3247:        if H.mem donecomps comp.ckey then
  3248:          dprintf "TCompLoop(%s %s, _, %a)"
  3249:            (if comp.cstruct then "struct" else "union") comp.cname
  3250:            self#pAttrs comp.cattr
  3251:        else begin
  3252:          H.add donecomps comp.ckey (); (* Add it before we do the fields *)
  3253:          dprintf "TComp(@[%s %s,@?%a,@?%a,@?%a@])"
  3254:            (if comp.cstruct then "struct" else "union") comp.cname
  3255:            (docList (chr ',' ++ break)
  3256:               (fun f -> dprintf "%s : %a" f.fname self#pOnlyType f.ftype))
  3257:            comp.cfields
  3258:            self#pAttrs comp.cattr
  3259:            self#pAttrs a
  3260:        end
  3261:    | TBuiltin_va_list a ->
  3262:        dprintf "TBuiltin_va_list(%a)" self#pAttrs a
  3263: 
  3264: 
  3265:   (* Some plain pretty-printers. Unlike the above these expose all the
  3266:    * details of the internal representation *)
  3267:   method pExp () = function
  3268:     Const(c) ->
  3269:       text "Const(" ++ d_const () c ++ text ")"
  3270:   | Lval(lv) ->
  3271:       text "Lval("
  3272:         ++ (align
  3273:               ++ self#pLval () lv
  3274:               ++ unalign)
  3275:         ++ text ")"
  3276: 
  3277:   | CastE(t,e) -> dprintf "CastE(@[%a,@?%a@])" self#pOnlyType t self#pExp e
  3278: 
  3279:   | UnOp(u,e1,_) ->
  3280:       let d_unop () u =
  3281:         match u with
  3282:           Neg -> text "-"
  3283:         | BNot -> text "~"
  3284:         | LNot -> text "!"
  3285:       in
  3286:       dprintf "UnOp(@[%a,@?%a@])"
  3287:         d_unop u self#pExp e1
  3288: 
  3289:   | BinOp(b,e1,e2,_) ->
  3290:       dprintf "%a(@[%a,@?%a@])" d_binop b
  3291:         self#pExp e1 self#pExp e2
  3292: 
  3293:   | SizeOf (t) ->
  3294:       text "sizeof(" ++ self#pType None () t ++ chr ')'
  3295:   | SizeOfE (e) ->
  3296:       text "sizeofE(" ++ self#pExp () e ++ chr ')'
  3297:   | SizeOfStr (s) ->
  3298:       text "sizeofStr(" ++ d_const () (CStr s) ++ chr ')'
  3299:   | AlignOf (t) ->
  3300:       text "__alignof__(" ++ self#pType None () t ++ chr ')'
  3301:   | AlignOfE (e) ->
  3302:       text "__alignof__(" ++ self#pExp () e ++ chr ')'
  3303: 
  3304:   | StartOf lv -> dprintf "StartOf(%a)" self#pLval lv
  3305:   | AddrOf (lv) -> dprintf "AddrOf(%a)" self#pLval lv
  3306: 
  3307: 
  3308: 
  3309:   method private d_plainoffset () = function
  3310:       NoOffset -> text "NoOffset"
  3311:     | Field(fi,o) ->
  3312:         dprintf "Field(@[%s:%a,@?%a@])"
  3313:           fi.fname self#pOnlyType fi.ftype self#d_plainoffset o
  3314:      | Index(e, o) ->
  3315:          dprintf "Index(@[%a,@?%a@])" self#pExp e self#d_plainoffset o
  3316: 
  3317:   method pInit () = function
  3318:       SingleInit e -> dprintf "SI(%a)" d_exp e
  3319:     | CompoundInit (t, initl) ->
  3320:         let d_plainoneinit (o, i) =
  3321:           self#d_plainoffset () o ++ text " = " ++ self#pInit () i
  3322:         in
  3323:         dprintf "CI(@[%a,@?%a@])" self#pOnlyType t
  3324:           (docList (chr ',' ++ break) d_plainoneinit) initl
  3325: (*
  3326:     | ArrayInit (t, len, initl) ->
  3327:         let idx = ref (- 1) in
  3328:         let d_plainoneinit i =
  3329:           incr idx;
  3330:           text "[" ++ num !idx ++ text "] = " ++ self#pInit () i
  3331:         in
  3332:         dprintf "AI(@[%a,%d,@?%a@])" self#pOnlyType t len
  3333:           (docList (chr ',' ++ break) d_plainoneinit) initl
  3334: *)
  3335:   method pLval () (lv: lval) =
  3336:     match lv with
  3337:     | Var vi, o -> dprintf "Var(@[%s,@?%a@])" vi.vname self#d_plainoffset o
  3338:     | Mem e, o -> dprintf "Mem(@[%a,@?%a@])" self#pExp e self#d_plainoffset o
  3339: 
  3340: 
  3341: end
  3342: let plainCilPrinter = new plainCilPrinterClass
  3343: 
  3344: (* And now some shortcuts *)
  3345: let d_plainexp () e = plainCilPrinter#pExp () e
  3346: let d_plaintype () t = plainCilPrinter#pType None () t
  3347: let d_plaininit () i = plainCilPrinter#pInit () i
  3348: let d_plainlval () l = plainCilPrinter#pLval () l
  3349: 
  3350: let rec d_typsig () = function
  3351:     TSArray (ts, eo, al) ->
  3352:       dprintf "TSArray(@[%a,@?%a,@?%a@])"
  3353:         d_typsig ts
  3354:         insert (match eo with None -> text "None" | Some e -> d_exp () e)
  3355:         d_attrlist al
  3356:   | TSPtr (ts, al) ->
  3357:       dprintf "TSPtr(@[%a,@?%a@])"
  3358:         d_typsig ts d_attrlist al
  3359:   | TSComp (iss, name, al) ->
  3360:       dprintf "TSComp(@[%s %s,@?%a@])"
  3361:         (if iss then "struct" else "union") name
  3362:         d_attrlist al
  3363:   | TSFun (rt, args, isva, al) ->
  3364:       dprintf "TSFun(@[%a,@?%a,%b,@?%a@])"
  3365:         d_typsig rt
  3366:         (docList (chr ',' ++ break) (d_typsig ())) args isva
  3367:         d_attrlist al
  3368:   | TSEnum (n, al) ->
  3369:       dprintf "TSEnum(@[%s,@?%a@])"
  3370:         n d_attrlist al
  3371:   | TSBase t -> dprintf "TSBase(%a)" d_type t
  3372: 
  3373: 
  3374: 
  3375:    (* Make a varinfo. Used mostly as a helper function below  *)
  3376: let makeVarinfo global name typ =
  3377:   (* Strip const from type for locals *)
  3378:   let vi =
  3379:     { vname = name;
  3380:       vid   = !nextGlobalVID;
  3381:       vglob = global;
  3382:       vtype = if global then typ else typeRemoveAttributes ["const"] typ;
  3383:       vdecl = lu;
  3384:       vinline = false;
  3385:       vattr = [];
  3386:       vstorage = NoStorage;
  3387:       vaddrof = false;
  3388:       vreferenced = false;    (* sm *)
  3389:     } in
  3390:   incr nextGlobalVID;
  3391:   vi
  3392: 
  3393: let copyVarinfo (vi: varinfo) (newname: string) : varinfo =
  3394:   let vi' = {vi with vname = newname; vid = !nextGlobalVID } in
  3395:   incr nextGlobalVID;
  3396:   vi'
  3397: 
  3398: let makeLocal fdec name typ = (* a helper function *)
  3399:   fdec.smaxid <- 1 + fdec.smaxid;
  3400:   let vi = makeVarinfo false name typ in
  3401:   vi
  3402: 
  3403:    (* Make a local variable and add it to a function *)
  3404: let makeLocalVar fdec ?(insert = true) name typ =
  3405:   let vi = makeLocal fdec name typ in
  3406:   if insert then fdec.slocals <- fdec.slocals @ [vi];
  3407:   vi
  3408: 
  3409: 
  3410: let makeTempVar fdec ?(name = "__cil_tmp") typ : varinfo =
  3411:   let name = name ^ (string_of_int (1 + fdec.smaxid)) in
  3412:   makeLocalVar fdec name typ
  3413: 
  3414: 
  3415:   (* Set the formals and re-create the function name based on the information*)
  3416: let setFormals (f: fundec) (forms: varinfo list) =
  3417:   f.sformals <- forms; (* Set the formals *)
  3418:   match unrollType f.svar.vtype with
  3419:     TFun(rt, _, isva, fa) ->
  3420:       f.svar.vtype <-
  3421:          TFun(rt,
  3422:               Some (List.map (fun a -> (a.vname, a.vtype, a.vattr)) forms),
  3423:               isva, fa)
  3424:   | _ -> E.s (E.bug "Set formals. %s does not have function type\n"
  3425:                 f.svar.vname)
  3426: 
  3427:    (* Set the types of arguments and results as given by the function type
  3428:     * passed as the second argument *)
  3429: let setFunctionType (f: fundec) (t: typ) =
  3430:   match unrollType t with
  3431:     TFun (rt, Some args, va, a) ->
  3432:       if List.length f.sformals <> List.length args then
  3433:         E.s (E.bug "setFunctionType: number of arguments differs from the number of formals");
  3434:       (* Change the function type. *)
  3435:       f.svar.vtype <- t;
  3436:       (* Change the sformals and we know that indirectly we'll change the
  3437:        * function type *)
  3438:       List.iter2
  3439:         (fun (an,at,aa) f ->
  3440:           f.vtype <- at; f.vattr <- aa)
  3441:         args f.sformals
  3442: 
  3443:   | _ -> E.s (E.bug "setFunctionType: not a function type")
  3444: 
  3445: 
  3446: let setMaxId (f: fundec) =
  3447:   f.smaxid <- List.length f.sformals + List.length f.slocals
  3448: 
  3449: 
  3450:   (* Make a formal variable for a function. Insert it in both the sformals
  3451:    * and the type of the function. You can optionally specify where to insert
  3452:    * this one. If where = "^" then it is inserted first. If where = "$" then
  3453:    * it is inserted last. Otherwise where must be the name of a formal after
  3454:    * which to insert this. By default it is inserted at the end. *)
  3455: let makeFormalVar fdec ?(where = "$") name typ : varinfo =
  3456:   (* Search for the insertion place *)
  3457:   let thenewone = ref fdec.svar in (* Just a placeholder *)
  3458:   let makeit () : varinfo =
  3459:     let vi = makeLocal fdec name typ in
  3460:     thenewone := vi;
  3461:     vi
  3462:   in
  3463:   let rec loopFormals = function
  3464:       [] ->
  3465:         if where = "$" then [makeit ()]
  3466:         else E.s (E.error "makeFormalVar: cannot find insert-after formal %s"
  3467:                     where)
  3468:     | f :: rest when f.vname = where -> f :: makeit () :: rest
  3469:     | f :: rest -> f :: loopFormals rest
  3470:   in
  3471:   let newformals =
  3472:     if where = "^" then makeit () :: fdec.sformals else
  3473:     loopFormals fdec.sformals in
  3474:   setFormals fdec newformals;
  3475:   !thenewone
  3476: 
  3477:    (* Make a global variable. Your responsibility to make sure that the name
  3478:     * is unique *)
  3479: let makeGlobalVar name typ =
  3480:   let vi = makeVarinfo true name typ in
  3481:   vi
  3482: 
  3483: 
  3484:    (* Make an empty function *)
  3485: let emptyFunction name =
  3486:   { svar  = makeGlobalVar name (TFun(voidType, Some [], false,[]));
  3487:     smaxid = 0;
  3488:     slocals = [];
  3489:     sformals = [];
  3490:     sbody = mkBlock [];
  3491:     smaxstmtid = None;
  3492:   }
  3493: 
  3494: 
  3495: 
  3496:     (* A dummy function declaration handy for initialization *)
  3497: let dummyFunDec = emptyFunction "@dummy"
  3498: let dummyFile =
  3499:   { globals = [];
  3500:     fileName = "<dummy>";
  3501:     globinit = None;
  3502:     globinitcalled = false}
  3503: 
  3504: let saveBinaryFile (cil_file : file) (filename : string) =
  3505:   let outchan = open_out_bin filename in
  3506:   Marshal.to_channel outchan cil_file [] ;
  3507:   close_out outchan
  3508: 
  3509: let saveBinaryFileChannel (cil_file : file) (outchan : out_channel) =
  3510:   Marshal.to_channel outchan cil_file []
  3511: 
  3512: let loadBinaryFile (filename : string) : file =
  3513:   let inchan = open_in_bin filename in
  3514:   let cil_file = (Marshal.from_channel inchan : file) in
  3515:   close_in inchan ;
  3516:   cil_file
  3517: 
  3518: 
  3519: (* Take the name of a file and make a valid symbol name out of it. There are
  3520:  * a few chanracters that are not valid in symbols *)
  3521: let makeValidSymbolName (s: string) =
  3522:   let s = String.copy s in (* So that we can update in place *)
  3523:   let l = String.length s in
  3524:   for i = 0 to l - 1 do
  3525:     let c = String.get s i in
  3526:     let isinvalid =
  3527:       match c with
  3528:         '-' | '.' -> true
  3529:       | _ -> false
  3530:     in
  3531:     if isinvalid then
  3532:       String.set s i '_';
  3533:   done;
  3534:   s
  3535: 
  3536: 
  3537: (*** Define the visiting engine ****)
  3538: (* visit all the nodes in a Flx_cil_cil expression *)
  3539: let doVisit (vis: cilVisitor)
  3540:             (startvisit: 'a -> 'a visitAction)
  3541:             (children: cilVisitor -> 'a -> 'a)
  3542:             (node: 'a) : 'a =
  3543:   let action = startvisit node in
  3544:   match action with
  3545:     SkipChildren -> node
  3546:   | ChangeTo node' -> node'
  3547:   | _ -> (* DoChildren and ChangeDoChildrenPost *)
  3548:       let nodepre = match action with
  3549:         ChangeDoChildrenPost (node', _) -> node'
  3550:       | _ -> node
  3551:       in
  3552:       let nodepost = children vis nodepre in
  3553:       match action with
  3554:         ChangeDoChildrenPost (_, f) -> f nodepost
  3555:       | _ -> nodepost
  3556: 
  3557: (* mapNoCopy is like map but avoid copying the list if the function does not
  3558:  * change the elements. *)
  3559: let rec mapNoCopy (f: 'a -> 'a) = function
  3560:     [] -> []
  3561:   | (i :: resti) as li ->
  3562:       let i' = f i in
  3563:       let resti' = mapNoCopy f resti in
  3564:       if i' != i || resti' != resti then i' :: resti' else li
  3565: 
  3566: let rec mapNoCopyList (f: 'a -> 'a list) = function
  3567:     [] -> []
  3568:   | (i :: resti) as li ->
  3569:       let il' = f i in
  3570:       let resti' = mapNoCopyList f resti in
  3571:       match il' with
  3572:         [i'] when i' == i && resti' == resti -> li
  3573:       | _ -> il' @ resti'
  3574: 
  3575: (* A visitor for lists *)
  3576: let doVisitList  (vis: cilVisitor)
  3577:                  (startvisit: 'a -> 'a list visitAction)
  3578:                  (children: cilVisitor -> 'a -> 'a)
  3579:                  (node: 'a) : 'a list =
  3580:   let action = startvisit node in
  3581:   match action with
  3582:     SkipChildren -> [node]
  3583:   | ChangeTo nodes' -> nodes'
  3584:   | _ ->
  3585:       let nodespre = match action with
  3586:         ChangeDoChildrenPost (nodespre, _) -> nodespre
  3587:       | _ -> [node]
  3588:       in
  3589:       let nodespost = mapNoCopy (children vis) nodespre in
  3590:       match action with
  3591:         ChangeDoChildrenPost (_, f) -> f nodespost
  3592:       | _ -> nodespost
  3593: 
  3594: let debugVisit = false
  3595: 
  3596: let rec visitCilExpr (vis: cilVisitor) (e: exp) : exp =
  3597:   doVisit vis vis#vexpr childrenExp e
  3598: and childrenExp (vis: cilVisitor) (e: exp) : exp =
  3599:   let vExp e = visitCilExpr vis e in
  3600:   let vTyp t = visitCilType vis t in
  3601:   let vLval lv = visitCilLval vis lv in
  3602:   match e with
  3603:     Const _ -> e
  3604:   | SizeOf t ->
  3605:       let t'= vTyp t in
  3606:       if t' != t then SizeOf t' else e
  3607:   | SizeOfE e1 ->
  3608:       let e1' = vExp e1 in
  3609:       if e1' != e1 then SizeOfE e1' else e
  3610:   | SizeOfStr s -> e
  3611: 
  3612:   | AlignOf t ->
  3613:       let t' = vTyp t in
  3614:       if t' != t then AlignOf t' else e
  3615:   | AlignOfE e1 ->
  3616:       let e1' = vExp e1 in
  3617:       if e1' != e1 then AlignOfE e1' else e
  3618:   | Lval lv ->
  3619:       let lv' = vLval lv in
  3620:       if lv' != lv then Lval lv' else e
  3621:   | UnOp (uo, e1, t) ->
  3622:       let e1' = vExp e1 in let t' = vTyp t in
  3623:       if e1' != e1 || t' != t then UnOp(uo, e1', t') else e
  3624:   | BinOp (bo, e1, e2, t) ->
  3625:       let e1' = vExp e1 in let e2' = vExp e2 in let t' = vTyp t in
  3626:       if e1' != e1 || e2' != e2 || t' != t then BinOp(bo, e1',e2',t') else e
  3627:   | CastE (t, e1) ->
  3628:       let t' = vTyp t in let e1' = vExp e1 in
  3629:       if t' != t || e1' != e1 then CastE(t', e1') else e
  3630:   | AddrOf lv ->
  3631:       let lv' = vLval lv in
  3632:       if lv' != lv then AddrOf lv' else e
  3633:   | StartOf lv ->
  3634:       let lv' = vLval lv in
  3635:       if lv' != lv then StartOf lv' else e
  3636: 
  3637: and visitCilInit (vis: cilVisitor) (i: init) : init =
  3638:   doVisit vis vis#vinit childrenInit i
  3639: and childrenInit (vis: cilVisitor) (i: init) : init =
  3640:   let fExp e = visitCilExpr vis e in
  3641:   let fInit i = visitCilInit vis i in
  3642:   let fTyp t = visitCilType vis t in
  3643:   match i with
  3644:   | SingleInit e ->
  3645:       let e' = fExp e in
  3646:       if e' != e then SingleInit e' else i
  3647:   | CompoundInit (t, initl) ->
  3648:       let t' = fTyp t in
  3649:       (* Collect the new initializer list, in reverse. We prefer two
  3650:        * traversals to ensure tail-recursion. *)
  3651:       let newinitl : (offset * init) list ref = ref [] in
  3652:       (* Keep track whether the list has changed *)
  3653:       let hasChanged = ref false in
  3654:       let doOneInit ((o, i) as oi) =
  3655:         let o' = visitCilInitOffset vis o in    (* use initializer version *)
  3656:         let i' = fInit i in
  3657:         let newio =
  3658:           if o' != o || i' != i then
  3659:             begin hasChanged := true; (o', i') end else oi
  3660:         in
  3661:         newinitl := newio :: !newinitl
  3662:       in
  3663:       List.iter doOneInit initl;
  3664:       let initl' = if !hasChanged then List.rev !newinitl else initl in
  3665:       if t' != t || initl' != initl then CompoundInit (t', initl') else i
  3666: (*
  3667:   | ArrayInit (bt, len, initl) ->
  3668:       let bt' = fTyp bt in
  3669:       (* Collect the new initializer list, in reverse. We prefer two
  3670:        * traversals to ensure tail-recursion. *)
  3671:       let newinitl : init list ref = ref [] in
  3672:       (* Keep track whether the list has changed *)
  3673:       let hasChanged = ref false in
  3674:       List.iter (fun i -> let i' = fInit i in
  3675:                           let i'' =
  3676:                             if i' != i then
  3677:                               begin hasChanged := true; i' end else i
  3678:                           in
  3679:                           newinitl := i'' :: !newinitl) initl;
  3680:       let initl' = if !hasChanged then List.rev !newinitl else initl in
  3681:       if bt' != bt || initl' != initl then ArrayInit(bt', len, initl') else i
  3682: *)
  3683: 
  3684: and visitCilLval (vis: cilVisitor) (lv: lval) : lval =
  3685:   doVisit vis vis#vlval childrenLval lv
  3686: and childrenLval (vis: cilVisitor) (lv: lval) : lval =
  3687:   (* and visit its subexpressions *)
  3688:   let vExp e = visitCilExpr vis e in
  3689:   let vTyp t = visitCilType vis t in
  3690:   let vOff off = visitCilOffset vis off in
  3691:   match lv with
  3692:     Var v, off ->
  3693:       let v'   = doVisit vis vis#vvrbl (fun _ x -> x) v in
  3694:       let off' = vOff off in
  3695:       if v' != v || off' != off then Var v', off' else lv
  3696:   | Mem e, off ->
  3697:       let e' = vExp e in
  3698:       let off' = vOff off in
  3699:       if e' != e || off' != off then Mem e', off' else lv
  3700: 
  3701: and visitCilOffset (vis: cilVisitor) (off: offset) : offset =
  3702:   doVisit vis vis#voffs childrenOffset off
  3703: and childrenOffset (vis: cilVisitor) (off: offset) : offset =
  3704:   let vOff off = visitCilOffset vis off in
  3705:   match off with
  3706:     Field (f, o) ->
  3707:       let o' = vOff o in
  3708:       if o' != o then Field (f, o') else off
  3709:   | Index (e, o) ->
  3710:       let e' = visitCilExpr vis e in
  3711:       let o' = vOff o in
  3712:       if e' != e || o' != o then Index (e', o') else off
  3713:   | NoOffset -> off
  3714: 
  3715: (* sm: for offsets in initializers, the 'startvisit' will be the
  3716:  * vinitoffs method, but we can re-use the childrenOffset from
  3717:  * above since recursive offsets are visited by voffs.  (this point
  3718:  * is moot according to cil.mli which claims the offsets in
  3719:  * initializers will never recursively contain offsets)
  3720:  *)
  3721: and visitCilInitOffset (vis: cilVisitor) (off: offset) : offset =
  3722:   doVisit vis vis#vinitoffs childrenOffset off
  3723: 
  3724: and visitCilInstr (vis: cilVisitor) (i: instr) : instr list =
  3725:   let oldloc = !currentLoc in
  3726:   currentLoc := (get_instrLoc i);
  3727:   assertEmptyQueue vis;
  3728:   let res = doVisitList vis vis#vinst childrenInstr i in
  3729:   currentLoc := oldloc;
  3730:   (* See if we have accumulated some instructions *)
  3731:   vis#unqueueInstr () @ res
  3732: 
  3733: and childrenInstr (vis: cilVisitor) (i: instr) : instr =
  3734:   let fExp = visitCilExpr vis in
  3735:   let fLval = visitCilLval vis in
  3736:   match i with
  3737:   | Set(lv,e,l) ->
  3738:       let lv' = fLval lv in let e' = fExp e in
  3739:       if lv' != lv || e' != e then Set(lv',e',l) else i
  3740:   | Call(None,f,args,l) ->
  3741:       let f' = fExp f in let args' = mapNoCopy fExp args in
  3742:       if f' != f || args' != args then Call(None,f',args',l) else i
  3743:   | Call(Some lv,fn,args,l) ->
  3744:       let lv' = fLval lv in let fn' = fExp fn in
  3745:       let args' = mapNoCopy fExp args in
  3746:       if lv' != lv || fn' != fn || args' != args
  3747:       then Call(Some lv', fn', args', l) else i
  3748: 
  3749:   | Asm(sl,isvol,outs,ins,clobs,l) ->
  3750:       let outs' = mapNoCopy (fun ((s,lv) as pair) ->
  3751:                                let lv' = fLval lv in
  3752:                                if lv' != lv then (s,lv') else pair) outs in
  3753:       let ins'  = mapNoCopy (fun ((s,e) as pair) ->
  3754:                                let e' = fExp e in
  3755:                                if e' != e then (s,e') else pair) ins in
  3756:       if outs' != outs || ins' != ins then
  3757:         Asm(sl,isvol,outs',ins',clobs,l) else i
  3758: 
  3759: 
  3760: (* visit all nodes in a Flx_cil_cil statement tree in preorder *)
  3761: and visitCilStmt (vis: cilVisitor) (s: stmt) : stmt =
  3762:   let oldloc = !currentLoc in
  3763:   currentLoc := (get_stmtLoc s.skind) ;
  3764:   assertEmptyQueue vis;
  3765:   let toPrepend : instr list ref = ref [] in (* childrenStmt may add to this *)
  3766:   let res = doVisit vis vis#vstmt (childrenStmt toPrepend) s in
  3767:   (* Now see if we have saved some instructions *)
  3768:   toPrepend := !toPrepend @ vis#unqueueInstr ();
  3769:   (match !toPrepend with
  3770:     [] -> () (* Return the same statement *)
  3771:   | _ ->
  3772:       (* Make our statement contain the instructions to prepend *)
  3773:       res.skind <- Block { battrs = []; bstmts = [ mkStmt (Instr !toPrepend);
  3774:                                                    mkStmt res.skind ] });
  3775:   currentLoc := oldloc;
  3776:   res
  3777: 
  3778: and childrenStmt (toPrepend: instr list ref) (vis:cilVisitor) (s:stmt): stmt =
  3779:   let fExp e = (visitCilExpr vis e) in
  3780:   let fLval lv = (visitCilLval vis lv) in
  3781:   let fOff o = (visitCilOffset vis o) in
  3782:   let fBlock b = visitCilBlock vis b in
  3783:   let fInst i = visitCilInstr vis i in
  3784:   (* Just change the statement kind *)
  3785:   let skind' =
  3786:     match s.skind with
  3787:       Break _ | Continue _ | Goto _ | Return (None, _) -> s.skind
  3788:     | Return (Some e, l) ->
  3789:         let e' = fExp e in
  3790:         if e' != e then Return (Some e', l) else s.skind
  3791:     | Loop (b, l, s1, s2) ->
  3792:         let b' = fBlock b in
  3793:         if b' != b then Loop (b', l, s1, s2) else s.skind
  3794:     | If(e, s1, s2, l) ->
  3795:         let e' = fExp e in
  3796:         (*if e queued any instructions, pop them here and remember them so that
  3797:           they are inserted before the If stmt, not in the then block. *)
  3798:         toPrepend := vis#unqueueInstr ();
  3799:         let s1'= fBlock s1 in let s2'= fBlock s2 in
  3800:         (* the stmts in the blocks should have cleaned up after themselves.*)
  3801:         assertEmptyQueue vis;
  3802:         if e' != e || s1' != s1 || s2' != s2 then
  3803:           If(e', s1', s2', l) else s.skind
  3804:     | Switch (e, b, stmts, l) ->
  3805:         let e' = fExp e in
  3806:         toPrepend := vis#unqueueInstr (); (* insert these before the switch *)
  3807:         let b' = fBlock b in
  3808:         (* the stmts in b should have cleaned up after themselves.*)
  3809:         assertEmptyQueue vis;
  3810:         (* Don't do stmts, but we better not change those *)
  3811:         if e' != e || b' != b then Switch (e', b', stmts, l) else s.skind
  3812:     | Instr il ->
  3813:         let il' = mapNoCopyList fInst il in
  3814:         if il' != il then Instr il' else s.skind
  3815:     | Block b ->
  3816:         let b' = fBlock b in
  3817:         if b' != b then Block b' else s.skind
  3818:     | TryFinally (b, h, l) ->
  3819:         let b' = fBlock b in
  3820:         let h' = fBlock h in
  3821:         if b' != b || h' != h then TryFinally(b', h', l) else s.skind
  3822:     | TryExcept (b, (il, e), h, l) ->
  3823:         let b' = fBlock b in
  3824:         assertEmptyQueue vis;
  3825:         (* visit the instructions *)
  3826:         let il' = mapNoCopyList fInst il in
  3827:         (* Visit the expression *)
  3828:         let e' = fExp e in
  3829:         let il'' =
  3830:           let more = vis#unqueueInstr () in
  3831:           if more != [] then
  3832:             il' @ more
  3833:           else
  3834:             il'
  3835:         in
  3836:         let h' = fBlock h in
  3837:         (* Now collect the instructions *)
  3838:         if b' != b || il'' != il || e' != e || h' != h then
  3839:           TryExcept(b', (il'', e'), h', l)
  3840:         else s.skind
  3841:   in
  3842:   if skind' != s.skind then s.skind <- skind';
  3843:   (* Visit the labels *)
  3844:   let labels' =
  3845:     let fLabel = function
  3846:         Case (e, l) as lb ->
  3847:           let e' = fExp e in
  3848:           if e' != e then Case (e', l) else lb
  3849:         | lb -> lb
  3850:     in
  3851:     mapNoCopy fLabel s.labels
  3852:   in
  3853:   if labels' != s.labels then s.labels <- labels';
  3854:   s
  3855: 
  3856: 
  3857: 
  3858: and visitCilBlock (vis: cilVisitor) (b: block) : block =
  3859:   doVisit vis vis#vblock childrenBlock b
  3860: and childrenBlock (vis: cilVisitor) (b: block) : block =
  3861:   let fStmt s = visitCilStmt vis s in
  3862:   let stmts' = mapNoCopy fStmt b.bstmts in
  3863:   if stmts' != b.bstmts then { battrs = b.battrs; bstmts = stmts'} else b
  3864: 
  3865: 
  3866: and visitCilType (vis : cilVisitor) (t : typ) : typ =
  3867:   doVisit vis vis#vtype childrenType t
  3868: and childrenType (vis : cilVisitor) (t : typ) : typ =
  3869:   (* look for types referred to inside t's definition *)
  3870:   let fTyp t  = visitCilType vis t in
  3871:   let fAttr a = visitCilAttributes vis a in
  3872:   match t with
  3873:     TPtr(t1, a) ->
  3874:       let t1' = fTyp t1 in
  3875:       let a' = fAttr a in
  3876:       if t1' != t || a' != a then TPtr(t1', a') else t
  3877:   | TArray(t1, None, a) ->
  3878:       let t1' = fTyp t1 in
  3879:       let a' = fAttr a in
  3880:       if t1' != t || a' != a  then TArray(t1', None, a') else t
  3881:   | TArray(t1, Some e, a) ->
  3882:       let t1' = fTyp t1 in
  3883:       let e' = visitCilExpr vis e in
  3884:       let a' = fAttr a in
  3885:       if t1' != t || e' != e  || a' != a then TArray(t1', Some e', a') else t
  3886: 
  3887:       (* DON'T recurse into the compinfo, this is done in visitCilGlobal.
  3888:          User can iterate over cinfo.cfields manually, if desired.*)
  3889:   | TComp(cinfo, a) ->
  3890:       let a' = fAttr a in
  3891:       if a != a' then TComp(cinfo, a') else t
  3892: 
  3893:   | TFun(rettype, args, isva, a) ->
  3894:       let rettype' = fTyp rettype in
  3895:       (* iterate over formals, as variable declarations *)
  3896:       let argslist = argsToList args in
  3897:       let visitArg ((an,at,aa) as arg) =
  3898:         let at' = fTyp at in
  3899:         let aa' = fAttr aa in
  3900:         if at' != at || aa' != aa then (an,at',aa') else arg
  3901:       in
  3902:       let argslist' = mapNoCopy visitArg argslist in
  3903:       let a' = fAttr a in
  3904:       if rettype' != rettype || argslist' != argslist || a' != a  then
  3905:         let args' = if argslist' == argslist then args else Some argslist' in
  3906:         TFun(rettype', args', isva, a') else t
  3907: 
  3908:   | TNamed(t1, a) -> (* Do not go into the type. Will do it at the time of
  3909:                       * GType *)
  3910:       let a' = fAttr a in
  3911:       if a' != a  then TNamed (t1, a') else t
  3912: 
  3913:   | _ ->  (* other types (TVoid, TInt, TFloat, TEnum, and TBuiltin_va_list)
  3914:              don't contain nested types, but they do have attributes. *)
  3915:       let a = typeAttrs t in
  3916:       let a' = fAttr a in
  3917:       if a' != a  then setTypeAttrs t a' else t
  3918: 
  3919: 
  3920: (* for declarations, we visit the types inside; but for uses, *)
  3921: (* we just visit the varinfo node *)
  3922: and visitCilVarDecl (vis : cilVisitor) (v : varinfo) : varinfo =
  3923:   doVisit vis vis#vvdec childrenVarDecl v
  3924: and childrenVarDecl (vis : cilVisitor) (v : varinfo) : varinfo =
  3925:   v.vtype <- visitCilType vis v.vtype;
  3926:   v.vattr <- visitCilAttributes vis v.vattr;
  3927:   v
  3928: 
  3929: and visitCilAttributes (vis: cilVisitor) (al: attribute list) : attribute list=
  3930:    let al' =
  3931:      mapNoCopyList (doVisitList vis vis#vattr childrenAttribute) al in
  3932:    if al' != al then
  3933:      (* Must re-sort *)
  3934:      addAttributes al' []
  3935:    else
  3936:      al
  3937: and childrenAttribute (vis: cilVisitor) (a: attribute) : attribute =
  3938:   let fTyp t  = visitCilType vis t in
  3939:   let rec doarg (aa: attrparam) =
  3940:     match aa with
  3941:       AInt _ | AStr _ -> aa
  3942:     | ACons(n, args) ->
  3943:         let args' = mapNoCopy doarg args in
  3944:         if args' != args then ACons(n, args') else aa
  3945:     | ASizeOf t ->
  3946:         let t' = fTyp t in
  3947:         if t' != t then ASizeOf t' else aa
  3948:     | ASizeOfE e ->
  3949:         let e' = doarg e in
  3950:         if e' != e then ASizeOfE e' else aa
  3951:     | AAlignOf t ->
  3952:         let t' = fTyp t in
  3953:         if t' != t then AAlignOf t' else aa
  3954:     | AAlignOfE e ->
  3955:         let e' = doarg e in
  3956:         if e' != e then AAlignOfE e' else aa
  3957:     | AUnOp (uo, e1) ->
  3958:         let e1' = doarg e1 in
  3959:         if e1' != e1 then AUnOp (uo, e1') else aa
  3960:     | ABinOp (bo, e1, e2) ->
  3961:         let e1' = doarg e1 in
  3962:         let e2' = doarg e2 in
  3963:         if e1' != e1 || e2' != e2 then ABinOp (bo, e1', e2') else aa
  3964:     | ADot (ap, s) ->
  3965:         let ap' = doarg ap in
  3966:         if ap' != ap then ADot (ap', s) else aa
  3967: 
  3968:   in
  3969:   match a with
  3970:     Attr (n, args) ->
  3971:       let args' = mapNoCopy doarg args in
  3972:       if args' != args then Attr(n, args') else a
  3973: 
  3974: 
  3975: 
  3976: let rec visitCilFunction (vis : cilVisitor) (f : fundec) : fundec =
  3977:   if debugVisit then ignore (E.log "Visiting function %s\n" f.svar.vname);
  3978:   doVisit vis vis#vfunc childrenFunction f
  3979: 
  3980: and childrenFunction (vis : cilVisitor) (f : fundec) : fundec =
  3981:   f.svar <- visitCilVarDecl vis f.svar; (* hit the function name *)
  3982:   (* visit local declarations *)
  3983:   f.slocals <- mapNoCopy (visitCilVarDecl vis) f.slocals;
  3984:   (* visit the formals *)
  3985:   let newformals = mapNoCopy (visitCilVarDecl vis) f.sformals in
  3986:   (* Make sure the type reflects the formals *)
  3987:   setFormals f newformals;
  3988:   f.sbody <- visitCilBlock vis f.sbody;        (* visit the body *)
  3989:   f
  3990: 
  3991: let rec visitCilGlobal (vis: cilVisitor) (g: global) : global list =
  3992:   (*(trace "visit" (dprintf "visitCilGlobal\n"));*)
  3993:   let oldloc = !currentLoc in
  3994:   currentLoc := (get_globalLoc g) ;
  3995:   let res = doVisitList vis vis#vglob childrenGlobal g in
  3996:   currentLoc := oldloc;
  3997:   res
  3998: and childrenGlobal (vis: cilVisitor) (g: global) : global =
  3999:   match g with
  4000:   | GFun (f, l) ->
  4001:       let f' = visitCilFunction vis f in
  4002:       if f' != f then GFun (f', l) else g
  4003:   | GType(t, l) ->
  4004:       t.ttype <- visitCilType vis t.ttype;
  4005:       g
  4006: 
  4007:   | GEnumTagDecl _ | GCompTagDecl _ -> g (* Nothing to visit *)
  4008:   | GEnumTag (enum, _) ->
  4009:       (trace "visit" (dprintf "visiting global enum %s\n" enum.ename));
  4010:       (* Do the values and attributes of the enumerated items *)
  4011:       let itemVisit (name, exp, loc) = (name, visitCilExpr vis exp, loc) in
  4012:       enum.eitems <- mapNoCopy itemVisit enum.eitems;
  4013:       enum.eattr <- visitCilAttributes vis enum.eattr;
  4014:       g
  4015: 
  4016:   | GCompTag (comp, _) ->
  4017:       (trace "visit" (dprintf "visiting global comp %s\n" comp.cname));
  4018:       (* Do the types and attirbutes of the fields *)
  4019:       let fieldVisit = fun fi ->
  4020:         fi.ftype <- visitCilType vis fi.ftype;
  4021:         fi.fattr <- visitCilAttributes vis fi.fattr
  4022:       in
  4023:       List.iter fieldVisit comp.cfields;
  4024:       g
  4025: 
  4026:   | GVarDecl(v, l) ->
  4027:       let v' = visitCilVarDecl vis v in
  4028:       if v' != v then GVarDecl (v', l) else g
  4029:   | GVar (v, inito, l) ->
  4030:       let v' = visitCilVarDecl vis v in
  4031:       (match inito.init with
  4032:         None -> ()
  4033:       | Some i -> let i' = visitCilInit vis i in
  4034:         if i' != i then inito.init <- Some i');
  4035: 
  4036:       if v' != v then GVar (v', inito, l) else g
  4037: 
  4038:   | GPragma (a, l) -> begin
  4039:       match visitCilAttributes vis [a] with
  4040:         [a'] -> if a' != a then GPragma (a', l) else g
  4041:       | _ -> E.s (E.unimp "visitCilAttributes returns more than one attribute")
  4042:   end
  4043:   | _ -> g
  4044: 
  4045: 
  4046: (* Iterate over all globals, including the global initializer *)
  4047: let iterGlobals (fl: file)
  4048:                 (doone: global -> unit) : unit =
  4049:   let doone' g =
  4050:       currentLoc := get_globalLoc g;
  4051:       doone g
  4052:   in
  4053:   List.iter doone' fl.globals;
  4054:   (match fl.globinit with
  4055:     None -> ()
  4056:   | Some g -> doone' (GFun(g, locUnknown)))
  4057: 
  4058: (* Fold over all globals, including the global initializer *)
  4059: let foldGlobals (fl: file)
  4060:                 (doone: 'a -> global -> 'a)
  4061:                 (acc: 'a) : 'a =
  4062:   let doone' acc g =
  4063:       currentLoc := get_globalLoc g;
  4064:       doone acc g
  4065:   in
  4066:   let acc' = List.fold_left doone' acc fl.globals in
  4067:   (match fl.globinit with
  4068:     None -> acc'
  4069:   | Some g -> doone' acc' (GFun(g, locUnknown)))
  4070: 
  4071: 
  4072: (* A visitor for the whole file that does not change the globals *)
  4073: let visitCilFileSameGlobals (vis : cilVisitor) (f : file) : unit =
  4074:   let fGlob g = visitCilGlobal vis g in
  4075:   iterGlobals f (fun g ->
  4076:     match fGlob g with
  4077:       [g'] when g' == g || g' = g -> () (* Try to do the pointer check first *)
  4078:     | gl ->
  4079:         ignore (E.log "You used visitCilFilSameGlobals but the global got changed:\n %a\nchanged to %a\n" d_global g (docList line (d_global ())) gl);
  4080:         ())
  4081: 
  4082: (* Be careful with visiting the whole file because it might be huge. *)
  4083: let visitCilFile (vis : cilVisitor) (f : file) : unit =
  4084:   let fGlob g = visitCilGlobal vis g in
  4085:   (* Scan the globals. Make sure this is tail recursive. *)
  4086:   let rec loop (acc: global list) = function
  4087:       [] -> f.globals <- List.rev acc
  4088:     | g :: restg ->
  4089:         loop ((List.rev (fGlob g)) @ acc) restg
  4090:   in
  4091:   loop [] f.globals;
  4092:   (* the global initializer *)
  4093:   (match f.globinit with
  4094:     None -> ()
  4095:   | Some g -> f.globinit <- Some (visitCilFunction vis g))
  4096: 
  4097: 
  4098: 
  4099: (** Create or fetch the global initializer. Tries to put a call to in the the
  4100:  * function with the main_name *)
  4101: let getGlobInit ?(main_name="main") (fl: file) =
  4102:   match fl.globinit with
  4103:     Some f -> f
  4104:   | None -> begin
  4105:       (* Sadly, we cannot use the Filename library because it does not like
  4106:        * function names with multiple . in them *)
  4107:       let f =
  4108:         let len = String.length fl.fileName in
  4109:         (* Find the last path separator and record the first . that we see,
  4110:         * going backwards *)
  4111:         let lastDot = ref len in
  4112:         let rec findLastPathSep i =
  4113:           if i < 0 then -1 else
  4114:           let c = String.get fl.fileName i in
  4115:           if c = '/' || c = '\\' then i
  4116:           else begin
  4117:             if c = '.' && !lastDot = len then
  4118:               lastDot := i;
  4119:             findLastPathSep (i - 1)
  4120:           end
  4121:         in
  4122:         let lastPathSep = findLastPathSep (len - 1) in
  4123:         let basenoext =
  4124:           String.sub fl.fileName (lastPathSep + 1) (!lastDot - lastPathSep - 1)
  4125:         in
  4126:         emptyFunction
  4127:           (makeValidSymbolName ("__globinit_" ^ basenoext))
  4128:       in
  4129:       fl.globinit <- Some f;
  4130:       (* Now try to add a call to the global initialized at the beginning of
  4131:        * main *)
  4132:       let mainname = "main" in
  4133:       let inserted = ref false in
  4134:       List.iter
  4135:         (fun g ->
  4136:           match g with
  4137:             GFun(m, lm) when m.svar.vname = "main" ->
  4138:               (* Prepend a prototype to the global initializer *)
  4139:               fl.globals <- GVarDecl (f.svar, lm) :: fl.globals;
  4140:               m.sbody.bstmts <-
  4141:                  compactStmts (mkStmt (Instr [Call(None,
  4142:                                                    Lval(var f.svar),
  4143:                                                    [], locUnknown)])
  4144:                                :: m.sbody.bstmts);
  4145:               inserted := true;
  4146:               if !E.verboseFlag then
  4147:                 ignore (E.log "Inserted the globinit\n");
  4148:               fl.globinitcalled <- true;
  4149:           | _ -> ())
  4150:         fl.globals;
  4151: 
  4152:       if not !inserted then
  4153:         ignore (E.warn "Cannot find %s to add global initializer %s"
  4154:                   main_name f.svar.vname);
  4155: 
  4156:       f
  4157:   end
  4158: 
  4159: 
  4160: 
  4161: (* Fold over all globals, including the global initializer *)
  4162: let mapGlobals (fl: file)
  4163:                (doone: global -> global) : unit =
  4164:   fl.globals <- List.map doone fl.globals;
  4165:   (match fl.globinit with
  4166:     None -> ()
  4167:   | Some g -> begin
  4168:       match doone (GFun(g, locUnknown)) with
  4169:         GFun(g', _) -> fl.globinit <- Some g'
  4170:       | _ -> E.s (E.bug "mapGlobals: globinit is not a function")
  4171:   end)
  4172: 
  4173: 
  4174: 
  4175: let dumpFile (pp: cilPrinter) (out : out_channel) file =
  4176:   printDepth := 99999;  (* We don't want ... in the output *)
  4177:   (* If we are in RELEASE mode then we do not print indentation *)
  4178:   (* AB: These flags are no longer used by Flx_cil_pretty *)
  4179: (*
  4180:   noBreaks := true; noAligns := true;
  4181:   assert (noBreaks := false; noAligns := false; true);
  4182: *)
  4183:   Flx_cil_pretty.fastMode := true;
  4184:   (* In debug mode the asserts are executed
  4185:   assert (Flx_cil_pretty.fastMode := false; true); *)
  4186:   if !E.verboseFlag then
  4187:     ignore (E.log "printing file %s\n" file.fileName);
  4188:   let print x = fprint out 78 x in
  4189:   print (text ("/* Generated by CIL v. " ^ cilVersion ^ " */\n" ^
  4190:                (* sm: I want to easily tell whether the generated output
  4191:                 * is with print_CIL_Input or not *)
  4192:                "/* print_CIL_Input is " ^ (if !print_CIL_Input then "true" else "false") ^ " */\n\n"));
  4193:   iterGlobals file (fun g -> dumpGlobal pp out g);
  4194: 
  4195:   (* sm: we have to flush the output channel; if we don't then under *)
  4196:   (* some circumstances (I haven't figure out exactly when, but it happens *)
  4197:   (* more often with big inputs), we get a truncated output file *)
  4198:   flush out
  4199: 
  4200: 
  4201: 
  4202: (******************
  4203:  ******************
  4204:  ******************)
  4205: 
  4206: 
  4207: 
  4208: (******************** OPTIMIZATIONS *****)
  4209: let rec peepHole1 (* Process one statement and possibly replace it *)
  4210:                   (doone: instr -> instr list option)
  4211:                   (* Scan a block and recurse inside nested blocks *)
  4212:                   (ss: stmt list) : unit =
  4213:   let rec doInstrList (il: instr list) : instr list =
  4214:     match il with
  4215:       [] -> []
  4216:     | i :: rest -> begin
  4217:         match doone i with
  4218:           None -> i :: doInstrList rest
  4219:         | Some sl -> doInstrList (sl @ rest)
  4220:     end
  4221:   in
  4222: 
  4223:   List.iter
  4224:     (fun s ->
  4225:       match s.skind with
  4226:         Instr il -> s.skind <- Instr (doInstrList il)
  4227:       | If (e, tb, eb, _) ->
  4228:           peepHole1 doone tb.bstmts;
  4229:           peepHole1 doone eb.bstmts
  4230:       | Switch (e, b, _, _) -> peepHole1 doone b.bstmts
  4231:       | Loop (b, l, _, _) -> peepHole1 doone b.bstmts
  4232:       | Block b -> peepHole1 doone b.bstmts
  4233:       | TryFinally (b, h, l) ->
  4234:           peepHole1 doone b.bstmts;
  4235:           peepHole1 doone h.bstmts
  4236:       | TryExcept (b, (il, e), h, l) ->
  4237:           peepHole1 doone b.bstmts;
  4238:           peepHole1 doone h.bstmts;
  4239:           s.skind <- TryExcept(b, (doInstrList il, e), h, l);
  4240:       | Return _ | Goto _ | Break _ | Continue _ -> ())
  4241:     ss
  4242: 
  4243: let rec peepHole2  (* Process two statements and possibly replace them both *)
  4244:                    (dotwo: instr * instr -> instr list option)
  4245:                    (ss: stmt list) : unit =
  4246:   let rec doInstrList (il: instr list) : instr list =
  4247:     match il with
  4248:       [] -> []
  4249:     | [i] -> [i]
  4250:     | (i1 :: ((i2 :: rest) as rest2)) ->
  4251:         begin
  4252:           match dotwo (i1,i2) with
  4253:             None -> i1 :: doInstrList rest2
  4254:           | Some sl -> doInstrList (sl @ rest)
  4255:         end
  4256:   in
  4257:   List.iter
  4258:     (fun s ->
  4259:       match s.skind with
  4260:         Instr il -> s.skind <- Instr (doInstrList il)
  4261:       | If (e, tb, eb, _) ->
  4262:           peepHole2 dotwo tb.bstmts;
  4263:           peepHole2 dotwo eb.bstmts
  4264:       | Switch (e, b, _, _) -> peepHole2 dotwo b.bstmts
  4265:       | Loop (b, l, _, _) -> peepHole2 dotwo b.bstmts
  4266:       | Block b -> peepHole2 dotwo b.bstmts
  4267:       | TryFinally (b, h, l) -> peepHole2 dotwo b.bstmts;
  4268:                                 peepHole2 dotwo h.bstmts
  4269:       | TryExcept (b, (il, e), h, l) ->
  4270:           peepHole2 dotwo b.bstmts;
  4271:           peepHole2 dotwo h.bstmts;
  4272:           s.skind <- TryExcept (b, (doInstrList il, e), h, l)
  4273: 
  4274:       | Return _ | Goto _ | Break _ | Continue _ -> ())
  4275:     ss
  4276: 
  4277: 
  4278: 
  4279: 
  4280: 
  4281: 
  4282: let dExp: doc -> exp =
  4283:   fun d -> Const(CStr(sprint 80 d))
  4284: 
  4285: let dInstr: doc -> location -> instr =
  4286:   fun d l -> Asm([], [sprint 80 d], [], [], [], l)
  4287: 
  4288: let dGlobal: doc -> location -> global =
  4289:   fun d l -> GAsm(sprint 80 d, l)
  4290: 
  4291: let rec addOffset (toadd: offset) (off: offset) : offset =
  4292:   match off with
  4293:     NoOffset -> toadd
  4294:   | Field(fid', offset) -> Field(fid', addOffset toadd offset)
  4295:   | Index(e, offset) -> Index(e, addOffset toadd offset)
  4296: 
  4297:  (* Add an offset at the end of an lv *)
  4298: let addOffsetLval toadd (b, off) : lval =
  4299:  b, addOffset toadd off
  4300: 
  4301: let rec removeOffset (off: offset) : offset * offset =
  4302:   match off with
  4303:     NoOffset -> NoOffset, NoOffset
  4304:   | Field(f, NoOffset) -> NoOffset, off
  4305:   | Index(i, NoOffset) -> NoOffset, off
  4306:   | Field(f, restoff) ->
  4307:       let off', last = removeOffset restoff in
  4308:       Field(f, off'), last
  4309:   | Index(i, restoff) ->
  4310:       let off', last = removeOffset restoff in
  4311:       Index(i, off'), last
  4312: 
  4313: let removeOffsetLval ((b, off): lval) : lval * offset =
  4314:   let off', last = removeOffset off in
  4315:   (b, off'), last
  4316: 
  4317:   (* Make an AddrOf. Given an lval of type T will give back an expression of
  4318:    * type ptr(T)  *)
  4319: let mkAddrOf ((b, off) as lval) : exp =
  4320:   (* Never take the address of a register variable *)
  4321:   (match lval with
  4322:     Var vi, off when vi.vstorage = Register -> vi.vstorage <- NoStorage
  4323:   | _ -> ());
  4324:   match lval with
  4325:     Mem e, NoOffset -> e
  4326:   | b, Index(z, NoOffset) when isZero z -> StartOf (b, NoOffset)(* array *)
  4327:   | _ -> AddrOf lval
  4328: 
  4329: 
  4330: let mkAddrOrStartOf (lv: lval) : exp =
  4331:   match unrollType (typeOfLval lv) with
  4332:     TArray _ -> StartOf lv
  4333:   | _ -> mkAddrOf lv
  4334: 
  4335: 
  4336:   (* Make a Mem, while optimizing AddrOf. The type of the addr must be
  4337:    * TPtr(t) and the type of the resulting lval is t. Note that in CIL the
  4338:    * implicit conversion between a function and a pointer to a function does
  4339:    * not apply. You must do the conversion yourself using AddrOf *)
  4340: let mkMem ~(addr: exp) ~(off: offset) : lval =
  4341:   let res =
  4342:     match addr, off with
  4343:       AddrOf lv, _ -> addOffsetLval off lv
  4344:     | StartOf lv, _ -> (* Must be an array *)
  4345:         addOffsetLval (Index(zero, off)) lv
  4346:     | _, _ -> Mem addr, off
  4347:   in
  4348: (*  ignore (E.log "memof : %a:%a\nresult = %a\n"
  4349:             d_plainexp addr d_plainoffset off d_plainexp res); *)
  4350:   res
  4351: 
  4352: 
  4353: let isIntegralType t =
  4354:   match unrollType t with
  4355:     (TInt _ | TEnum _) -> true
  4356:   | _ -> false
  4357: 
  4358: let isArithmeticType t =
  4359:   match unrollType t with
  4360:     (TInt _ | TEnum _ | TFloat _) -> true
  4361:   | _ -> false
  4362: 
  4363: 
  4364: let isPointerType t =
  4365:   match unrollType t with
  4366:     TPtr _ -> true
  4367:   | _ -> false
  4368: 
  4369: let isFunctionType t =
  4370:   match unrollType t with
  4371:     TFun _ -> true
  4372:   | _ -> false
  4373: 
  4374: let splitFunctionType (ftype: typ)
  4375:     : typ * (string * typ * attributes) list option * bool * attributes =
  4376:   match unrollType ftype with
  4377:     TFun (rt, args, isva, a) -> rt, args, isva, a
  4378:   | _ -> E.s (bug "splitFunctionType invoked on a non function type %a"
  4379:                 d_type ftype)
  4380: 
  4381: let splitFunctionTypeVI (fvi: varinfo)
  4382:     : typ * (string * typ * attributes) list option * bool * attributes =
  4383:   match unrollType fvi.vtype with
  4384:     TFun (rt, args, isva, a) -> rt, args, isva, a
  4385:   | _ -> E.s (bug "Function %s invoked on a non function type" fvi.vname)
  4386: 
  4387: let isArrayType t =
  4388:   match unrollType t with
  4389:     TArray _ -> true
  4390:   | _ -> false
  4391: 
  4392: 
  4393: let rec isConstant = function
  4394:   | Const _ -> true
  4395:   | UnOp (_, e, _) -> isConstant e
  4396:   | BinOp (_, e1, e2, _) -> isConstant e1 && isConstant e2
  4397:   | Lval (Var vi, NoOffset) ->
  4398:       (vi.vglob && isArrayType vi.vtype || isFunctionType vi.vtype)
  4399:   | Lval _ -> false
  4400:   | SizeOf _ | SizeOfE _ | SizeOfStr _ | AlignOf _ | AlignOfE _ -> true
  4401:   | CastE (_, e) -> isConstant e
  4402:   | AddrOf (Var vi, off) | StartOf (Var vi, off)
  4403:         -> vi.vglob && isConstantOff off
  4404:   | AddrOf (Mem e, off) | StartOf(Mem e, off)
  4405:         -> isConstant e && isConstantOff off
  4406: 
  4407: and isConstantOff = function
  4408:     NoOffset -> true
  4409:   | Field(fi, off) -> isConstantOff off
  4410:   | Index(e, off) -> isConstant e && isConstantOff off
  4411: 
  4412: 
  4413: let getCompField (cinfo:compinfo) (fieldName:string) : fieldinfo =
  4414:   (List.find (fun fi -> fi.fname = fieldName) cinfo.cfields)
  4415: 
  4416: 
  4417: let rec mkCastT ~(e: exp) ~(oldt: typ) ~(newt: typ) =
  4418:   (* Do not remove old casts because they are conversions !!! *)
  4419:   if typeSig oldt = typeSig newt then begin
  4420:     e
  4421:   end else begin
  4422:     (* Watch out for constants *)
  4423:     match newt, e with
  4424:       TInt(newik, []), Const(CInt64(i, _, _)) -> kinteger64 newik i
  4425:     | _ -> CastE(newt,e)
  4426:   end
  4427: 
  4428: let mkCast ~(e: exp) ~(newt: typ) =
  4429:   mkCastT e (typeOf e) newt
  4430: 
  4431: type existsAction =
  4432:     ExistsTrue                          (* We have found it *)
  4433:   | ExistsFalse                         (* Stop processing this branch *)
  4434:   | ExistsMaybe                         (* This node is not what we are
  4435:                                          * looking for but maybe its
  4436:                                          * successors are *)
  4437: let existsType (f: typ -> existsAction) (t: typ) : bool =
  4438:   let memo : (int, unit) H.t = H.create 17 in  (* Memo table *)
  4439:   let rec loop t =
  4440:     match f t with
  4441:       ExistsTrue -> true
  4442:     | ExistsFalse -> false
  4443:     | ExistsMaybe ->
  4444:         (match t with
  4445:           TNamed (t', _) -> loop t'.ttype
  4446:         | TComp (c, _) -> loopComp c
  4447:         | TArray (t', _, _) -> loop t'
  4448:         | TPtr (t', _) -> loop t'
  4449:         | TFun (rt, args, _, _) ->
  4450:             (loop rt || List.exists (fun (_, at, _) -> loop at)
  4451:               (argsToList args))
  4452:         | _ -> false)
  4453:   and loopComp c =
  4454:     if H.mem memo c.ckey then
  4455:       (* We are looping, the answer must be false *)
  4456:       false
  4457:     else begin
  4458:       H.add memo c.ckey ();
  4459:       List.exists (fun f -> loop f.ftype) c.cfields
  4460:     end
  4461:   in
  4462:   loop t
  4463: 
  4464: (**
  4465:  **
  4466:  ** MACHINE DEPENDENT PART
  4467:  **
  4468:  **)
  4469: exception SizeOfError of typ
  4470: 
  4471: 
  4472: (* Get the minimum aligment in bytes for a given type *)
  4473: let rec alignOf_int = function
  4474:   | TInt((IChar|ISChar|IUChar), _) -> 1
  4475:   | TInt((IBool), _) -> !theMachine.alignof_cbool
  4476:   | TInt((IShort|IUShort), _) -> !theMachine.alignof_short
  4477:   | TInt((IInt|IUInt), _) -> !theMachine.alignof_int
  4478:   | TInt((ILong|IULong), _) -> !theMachine.alignof_long
  4479:   | TInt((ILongLong|IULongLong), _) -> !theMachine.alignof_longlong
  4480:   | TEnum _ -> !theMachine.alignof_enum
  4481: 
  4482:   | TFloat(FFloat, _) -> !theMachine.alignof_float
  4483:   | TFloat(FDouble, _) -> !theMachine.alignof_double
  4484:   | TFloat(FLongDouble, _) -> !theMachine.alignof_longdouble
  4485: 
  4486:   | TFloat(IFloat, _) -> !theMachine.alignof_imaginary
  4487:   | TFloat(IDouble, _) -> !theMachine.alignof_doubleimaginary
  4488:   | TFloat(ILongDouble, _) -> !theMachine.alignof_longdoubleimaginary
  4489: 
  4490:   | TFloat(CFloat, _) -> !theMachine.alignof_complex
  4491:   | TFloat(CDouble, _) -> !theMachine.alignof_doublecomplex
  4492:   | TFloat(CLongDouble, _) -> !theMachine.alignof_longdoublecomplex
  4493: 
  4494:   | TNamed (t, _) -> alignOf_int t.ttype
  4495:   | TArray (t, _, _) -> alignOf_int t
  4496:   | TPtr _ | TBuiltin_va_list _ -> !theMachine.sizeof_ptr
  4497: 
  4498:         (* For composite types get the maximum alignment of any field inside *)
  4499:   | TComp (c, _) ->
  4500:       (* On GCC the zero-width fields do not contribute to the alignment. On
  4501:        * MSVC only those zero-width that _do_ appear after other
  4502:        * bitfields contribute to the alignment. So we drop those that
  4503:        * do not occur after othe bitfields *)
  4504:       let rec dropZeros (afterbitfield: bool) = function
  4505:         | f :: rest when f.fbitfield = Some 0 && not afterbitfield ->
  4506:             dropZeros afterbitfield rest
  4507:         | f :: rest -> f :: dropZeros (f.fbitfield <> None) rest
  4508:         | [] -> []
  4509:       in
  4510:       let fields = dropZeros false c.cfields in
  4511:       List.fold_left
  4512:         (fun sofar f ->
  4513:           (* Bitfields with zero width do not contribute to the alignment in
  4514:            * GCC *)
  4515:           if not !msvcMode && f.fbitfield = Some 0 then sofar else
  4516:           max sofar (alignOf_int f.ftype)) 1 fields
  4517:         (* These are some error cases *)
  4518:   | TFun _ when not !msvcMode -> !theMachine.alignof_fun
  4519: 
  4520:   | (TFun _ | TVoid _) as t -> raise (SizeOfError t)
  4521: 
  4522: 
  4523: 
  4524: type offsetAcc =
  4525:     { oaFirstFree: int;        (* The first free bit *)
  4526:       oaLastFieldStart: int;   (* Where the previous field started *)
  4527:       oaLastFieldWidth: int;   (* The width of the previous field. Might not
  4528:                                 * be same as FirstFree - FieldStart because
  4529:                                 * of internal padding *)
  4530:       oaPrevBitPack: (int * ikind * int) option; (* If the previous fields
  4531:                                                    * were packed bitfields,
  4532:                                                    * the bit where packing
  4533:                                                    * has started, the ikind
  4534:                                                    * of the bitfield and the
  4535:                                                    * width of the ikind *)
  4536:     }
  4537: 
  4538: 
  4539: (* GCC version *)
  4540: (* Does not use the sofar.oaPrevBitPack *)
  4541: let rec offsetOfFieldAcc_GCC (fi: fieldinfo)
  4542:                              (sofar: offsetAcc) : offsetAcc =
  4543:   (* field type *)
  4544:   let ftype = unrollType fi.ftype in
  4545:   let ftypeAlign = 8 * alignOf_int ftype in
  4546:   let ftypeBits = bitsSizeOf ftype in
  4547: (*
  4548:   if fi.fcomp.cname = "comp2468" ||
  4549:      fi.fcomp.cname = "comp2469" ||
  4550:      fi.fcomp.cname = "comp2470" ||
  4551:      fi.fcomp.cname = "comp2471" ||
  4552:      fi.fcomp.cname = "comp2472" ||
  4553:      fi.fcomp.cname = "comp2473" ||
  4554:      fi.fcomp.cname = "comp2474" ||
  4555:      fi.fcomp.cname = "comp2475" ||
  4556:      fi.fcomp.cname = "comp2476" ||
  4557:      fi.fcomp.cname = "comp2477" ||
  4558:      fi.fcomp.cname = "comp2478" then
  4559: 
  4560:     ignore (E.log "offsetOfFieldAcc_GCC(%s of %s:%a%a,firstFree=%d,pack=%a)\n"
  4561:               fi.fname fi.fcomp.cname
  4562:               d_type ftype
  4563:               insert
  4564:               (match fi.fbitfield with
  4565:                 None -> nil
  4566:               | Some wdthis -> dprintf ":%d" wdthis)
  4567:               sofar.oaFirstFree
  4568:               insert
  4569:               (match sofar.oaPrevBitPack with
  4570:                 None -> text "None"
  4571:               | Some (packstart, _, wdpack) ->
  4572:                   dprintf "Some(packstart=%d,wd=%d)"
  4573:                     packstart wdpack));
  4574: *)
  4575:   match ftype, fi.fbitfield with
  4576:     (* A width of 0 means that we must end the current packing. It seems that
  4577:      * GCC pads only up to the alignment boundary for the type of this field.
  4578:      * *)
  4579:   | _, Some 0 ->
  4580:       let firstFree      = addTrailing sofar.oaFirstFree ftypeAlign in
  4581:       { oaFirstFree      = firstFree;
  4582:         oaLastFieldStart = firstFree;
  4583:         oaLastFieldWidth = 0;
  4584:         oaPrevBitPack    = None }
  4585: 
  4586:     (* A bitfield cannot span more alignment boundaries of its type than the
  4587:      * type itself *)
  4588:   | _, Some wdthis
  4589:       when (sofar.oaFirstFree + wdthis + ftypeAlign - 1) / ftypeAlign
  4590:             - sofar.oaFirstFree / ftypeAlign > ftypeBits / ftypeAlign ->
  4591:           let start = addTrailing sofar.oaFirstFree ftypeAlign in
  4592:           { oaFirstFree      = start + wdthis;
  4593:             oaLastFieldStart = start;
  4594:             oaLastFieldWidth = wdthis;
  4595:             oaPrevBitPack    = None }
  4596: 
  4597:    (* Try a simple method. Just put the field down *)
  4598:   | _, Some wdthis ->
  4599:       { oaFirstFree      = sofar.oaFirstFree + wdthis;
  4600:         oaLastFieldStart = sofar.oaFirstFree;
  4601:         oaLastFieldWidth = wdthis;
  4602:         oaPrevBitPack    = None
  4603:       }
  4604: 
  4605:      (* Non-bitfield *)
  4606:   | _, None ->
  4607:       (* Align this field *)
  4608:       let newStart = addTrailing sofar.oaFirstFree ftypeAlign  in
  4609:       { oaFirstFree = newStart + ftypeBits;
  4610:         oaLastFieldStart = newStart;
  4611:         oaLastFieldWidth = ftypeBits;
  4612:         oaPrevBitPack = None;
  4613:       }
  4614: 
  4615: (* MSVC version *)
  4616: and offsetOfFieldAcc_MSVC (fi: fieldinfo)
  4617:                               (sofar: offsetAcc) : offsetAcc =
  4618:   (* field type *)
  4619:   let ftype = unrollType fi.ftype in
  4620:   let ftypeAlign = 8 * alignOf_int ftype in
  4621:   let ftypeBits = bitsSizeOf ftype in
  4622: (*
  4623:   ignore (E.log "offsetOfFieldAcc_MSVC(%s of %s:%a%a,firstFree=%d, pack=%a)\n"
  4624:             fi.fname fi.fcomp.cname
  4625:             d_type ftype
  4626:             insert
  4627:             (match fi.fbitfield with
  4628:               None -> nil
  4629:             | Some wdthis -> dprintf ":%d" wdthis)
  4630:             sofar.oaFirstFree
  4631:             insert
  4632:             (match sofar.oaPrevBitPack with
  4633:               None -> text "None"
  4634:             | Some (prevpack, _, wdpack) -> dprintf "Some(prev=%d,wd=%d)"
  4635:                   prevpack wdpack));
  4636: *)
  4637:   match ftype, fi.fbitfield, sofar.oaPrevBitPack with
  4638:     (* Ignore zero-width bitfields that come after non-bitfields *)
  4639:   | TInt (ikthis, _), Some 0, None ->
  4640:       let firstFree      = sofar.oaFirstFree in
  4641:       { oaFirstFree      = firstFree;
  4642:         oaLastFieldStart = firstFree;
  4643:         oaLastFieldWidth = 0;
  4644:         oaPrevBitPack    = None }
  4645: 
  4646:     (* If we are in a bitpack and we see a bitfield for a type with the
  4647:      * different width than the pack, then we finish the pack and retry *)
  4648:   | _, Some _, Some (packstart, _, wdpack) when wdpack != ftypeBits ->
  4649:       let firstFree =
  4650:         if sofar.oaFirstFree = packstart then packstart else
  4651:         packstart + wdpack
  4652:       in
  4653:       offsetOfFieldAcc_MSVC fi
  4654:         { oaFirstFree      = addTrailing firstFree ftypeAlign;
  4655:           oaLastFieldStart = sofar.oaLastFieldStart;
  4656:           oaLastFieldWidth = sofar.oaLastFieldWidth;
  4657:           oaPrevBitPack    = None }
  4658: 
  4659:     (* A width of 0 means that we must end the current packing. *)
  4660:   | TInt (ikthis, _), Some 0, Some (packstart, _, wdpack) ->
  4661:       let firstFree =
  4662:         if sofar.oaFirstFree = packstart then packstart else
  4663:         packstart + wdpack
  4664:       in
  4665:       let firstFree      = addTrailing firstFree ftypeAlign in
  4666:       { oaFirstFree      = firstFree;
  4667:         oaLastFieldStart = firstFree;
  4668:         oaLastFieldWidth = 0;
  4669:         oaPrevBitPack    = Some (firstFree, ikthis, ftypeBits) }
  4670: 
  4671:    (* Flx_cil_check for a bitfield that fits in the current pack after some other
  4672:     * bitfields *)
  4673:   | TInt(ikthis, _), Some wdthis, Some (packstart, ikprev, wdpack)
  4674:       when  packstart + wdpack >= sofar.oaFirstFree + wdthis ->
  4675:               { oaFirstFree = sofar.oaFirstFree + wdthis;
  4676:                 oaLastFieldStart = sofar.oaFirstFree;
  4677:                 oaLastFieldWidth = wdthis;
  4678:                 oaPrevBitPack = sofar.oaPrevBitPack
  4679:               }
  4680: 
  4681: 
  4682:   | _, _, Some (packstart, _, wdpack) -> (* Finish up the bitfield pack and
  4683:                                           * restart. *)
  4684:       let firstFree =
  4685:         if sofar.oaFirstFree = packstart then packstart else
  4686:         packstart + wdpack
  4687:       in
  4688:       offsetOfFieldAcc_MSVC fi
  4689:         { oaFirstFree      = addTrailing firstFree ftypeAlign;
  4690:           oaLastFieldStart = sofar.oaLastFieldStart;
  4691:           oaLastFieldWidth = sofar.oaLastFieldWidth;
  4692:           oaPrevBitPack    = None }
  4693: 
  4694:         (* No active bitfield pack. But we are seeing a bitfield. *)
  4695:   | TInt(ikthis, _), Some wdthis, None ->
  4696:       let firstFree     = addTrailing sofar.oaFirstFree ftypeAlign in
  4697:       { oaFirstFree     = firstFree + wdthis;
  4698:         oaLastFieldStart = firstFree;
  4699:         oaLastFieldWidth = wdthis;
  4700:         oaPrevBitPack = Some (firstFree, ikthis, ftypeBits); }
  4701: 
  4702:      (* No active bitfield pack. Non-bitfield *)
  4703:   | _, None, None ->
  4704:       (* Align this field *)
  4705:       let firstFree = addTrailing sofar.oaFirstFree ftypeAlign  in
  4706:       { oaFirstFree = firstFree + ftypeBits;
  4707:         oaLastFieldStart = firstFree;
  4708:         oaLastFieldWidth = ftypeBits;
  4709:         oaPrevBitPack = None;
  4710:       }
  4711: 
  4712:   | _, Some _, None -> E.s (E.bug "offsetAcc")
  4713: 
  4714: 
  4715: and offsetOfFieldAcc ~(fi: fieldinfo)
  4716:                      ~(sofar: offsetAcc) : offsetAcc =
  4717:   if !msvcMode then offsetOfFieldAcc_MSVC fi sofar
  4718:   else offsetOfFieldAcc_GCC fi sofar
  4719: 
  4720: (* The size of a type, in bits. If struct or array then trailing padding is
  4721:  * added *)
  4722: and bitsSizeOf t =
  4723:   match t with
  4724:     (* For long long sometimes the alignof and sizeof are different *)
  4725:   | TInt((ILongLong|IULongLong), _) -> 8 * !theMachine.sizeof_longlong
  4726:   | TFloat(FDouble, _) -> 8 * 8
  4727:   | TFloat(FLongDouble, _) -> 8 * !theMachine.sizeof_longdouble
  4728:   | TInt _ | TFloat _ | TEnum _ | TPtr _ | TBuiltin_va_list _
  4729:     -> 8 * alignOf_int t
  4730:   | TNamed (t, _) -> bitsSizeOf t.ttype
  4731:   | TComp (comp, _) when comp.cfields = [] -> begin
  4732:       (* Empty structs are allowed in msvc mode *)
  4733:       if not comp.cdefined && not !msvcMode then
  4734:         raise (SizeOfError t) (*abstract type*)
  4735:       else
  4736:         0
  4737:   end
  4738: 
  4739:   | TComp (comp, _) when comp.cstruct -> (* Struct *)
  4740:         (* Go and get the last offset *)
  4741:       let startAcc =
  4742:         { oaFirstFree = 0;
  4743:           oaLastFieldStart = 0;
  4744:           oaLastFieldWidth = 0;
  4745:           oaPrevBitPack = None;
  4746:         } in
  4747:       let lastoff =
  4748:         List.fold_left (fun acc fi -> offsetOfFieldAcc ~fi ~sofar:acc)
  4749:           startAcc comp.cfields
  4750:       in
  4751:       if !msvcMode && lastoff.oaFirstFree = 0 && comp.cfields <> [] then
  4752:           (* On MSVC if we have just a zero-width bitfields then the length
  4753:            * is 32 and is not padded  *)
  4754:         32
  4755:       else
  4756:         addTrailing lastoff.oaFirstFree (8 * alignOf_int t)
  4757: 
  4758:   | TComp (comp, _) -> (* when not comp.cstruct *)
  4759:         (* Get the maximum of all fields *)
  4760:       let startAcc =
  4761:         { oaFirstFree = 0;
  4762:           oaLastFieldStart = 0;
  4763:           oaLastFieldWidth = 0;
  4764:           oaPrevBitPack = None;
  4765:         } in
  4766:       let max =
  4767:         List.fold_left (fun acc fi ->
  4768:           let lastoff = offsetOfFieldAcc ~fi ~sofar:startAcc in
  4769:           if lastoff.oaFirstFree > acc then
  4770:             lastoff.oaFirstFree else acc) 0 comp.cfields in
  4771:         (* Add trailing by simulating adding an extra field *)
  4772:       addTrailing max (8 * alignOf_int t)
  4773: 
  4774:   | TArray(t, Some len, _) -> begin
  4775:       match constFold true len with
  4776:         Const(CInt64(l,_,_)) ->
  4777:           addTrailing ((bitsSizeOf t) * (Int64.to_int l)) (8 * alignOf_int t)
  4778:       | _ -> raise (SizeOfError t)
  4779:   end
  4780: 
  4781: 
  4782:   | TVoid _ -> 8 * !theMachine.sizeof_void
  4783:   | TFun _ when not !msvcMode -> (* On GCC the size of a function is defined *)
  4784:       8 * !theMachine.sizeof_fun
  4785: 
  4786:   | TArray (_, None, _) | TFun _ -> raise (SizeOfError t)
  4787: 
  4788: 
  4789: and addTrailing nrbits roundto =
  4790:     (nrbits + roundto - 1) land (lnot (roundto - 1))
  4791: 
  4792: and sizeOf t =
  4793:   try
  4794:     integer ((bitsSizeOf t) lsr 3)
  4795:   with SizeOfError _ -> SizeOf(t)
  4796: 
  4797: 
  4798: and bitsOffset (baset: typ) (off: offset) : int * int =
  4799:   let rec loopOff (baset: typ) (width: int) (start: int) = function
  4800:       NoOffset -> start, width
  4801:     | Index(e, off) -> begin
  4802:         let ei =
  4803:           match isInteger e with
  4804:             Some i64 -> Int64.to_int i64
  4805:           | None -> raise (SizeOfError baset)
  4806:         in
  4807:         let bt =
  4808:           match unrollType baset with
  4809:             TArray(bt, _, _) -> bt
  4810:           | _ -> E.s (E.bug "bitsOffset: Index on a non-array")
  4811:         in
  4812:         let bitsbt = bitsSizeOf bt in
  4813:         loopOff bt bitsbt (start + ei * bitsbt) off
  4814:     end
  4815:     | Field(f, off) when not f.fcomp.cstruct ->
  4816:         (* All union fields start at offset 0 *)
  4817:         loopOff f.ftype (bitsSizeOf f.ftype) start off
  4818: 
  4819:     | Field(f, off) ->
  4820:         (* Construct a list of fields preceeding and including this one *)
  4821:         let prevflds =
  4822:           let rec loop = function
  4823:               [] -> E.s (E.bug "bitsOffset: Cannot find field %s in %s\n"
  4824:                            f.fname f.fcomp.cname)
  4825:             | fi' :: _ when fi' == f -> [fi']
  4826:             | fi' :: rest -> fi' :: loop rest
  4827:           in
  4828:           loop f.fcomp.cfields
  4829:         in
  4830:         let lastoff =
  4831:           List.fold_left (fun acc fi' -> offsetOfFieldAcc ~fi:fi' ~sofar:acc)
  4832:             { oaFirstFree      = 0; (* Start at 0 because each struct is done
  4833:                                      * separately *)
  4834:               oaLastFieldStart = 0;
  4835:               oaLastFieldWidth = 0;
  4836:               oaPrevBitPack    = None } prevflds
  4837:         in
  4838:         (* ignore (E.log "Field %s of %s: start=%d, lastFieldStart=%d\n"
  4839:                   f.fname f.fcomp.cname start lastoff.oaLastFieldStart); *)
  4840:         loopOff f.ftype lastoff.oaLastFieldWidth
  4841:                (start + lastoff.oaLastFieldStart) off
  4842:   in
  4843:   loopOff baset (bitsSizeOf baset) 0 off
  4844: 
  4845: 
  4846: 
  4847: 
  4848: (*** Constant folding. If machdep is true then fold even sizeof operations ***)
  4849: and constFold (machdep: bool) (e: exp) : exp =
  4850:   match e with
  4851:     BinOp(bop, e1, e2, tres) -> constFoldBinOp machdep bop e1 e2 tres
  4852:   | UnOp(unop, e1, tres) -> begin
  4853:       try
  4854:         let tk =
  4855:           match unrollType tres with
  4856:             TInt(ik, _) -> ik
  4857:           | TEnum _ -> IInt
  4858:           | _ -> raise Not_found (* probably a float *)
  4859:         in
  4860:         match constFold machdep e1 with
  4861:           Const(CInt64(i,ik,_)) as e1c -> begin
  4862:             match unop with
  4863:               Neg -> kinteger64 tk (Int64.neg i)
  4864:             | BNot -> kinteger64 tk (Int64.lognot i)
  4865:             | LNot -> if i = Int64.zero then one else zero
  4866:             end
  4867:         | e1c -> UnOp(unop, e1c, tres)
  4868:       with Not_found -> e
  4869:   end
  4870:         (* Characters are integers *)
  4871:   | Const(CChr c) -> Const(CInt64(Int64.of_int (Char.code c),
  4872:                                   IInt, None))
  4873:   | SizeOf t when machdep -> begin
  4874:       try
  4875:         let bs = bitsSizeOf t in
  4876:         kinteger !kindOfSizeOf (bs / 8)
  4877:       with SizeOfError _ -> e
  4878:   end
  4879:   | SizeOfE e when machdep -> constFold machdep (SizeOf (typeOf e))
  4880:   | SizeOfStr s when machdep -> kinteger !kindOfSizeOf (1 + String.length s)
  4881:   | AlignOf t when machdep -> kinteger !kindOfSizeOf (alignOf_int t)
  4882:   | AlignOfE e when machdep -> begin
  4883:       (* The alignmetn of an expression is not always the alignment of its
  4884:        * type. I know that for strings this is not true *)
  4885:       match e with
  4886:         Const (CStr _) when not !msvcMode ->
  4887:           kinteger !kindOfSizeOf !theMachine.alignof_str
  4888:             (* For an array, it is the alignment of the array ! *)
  4889:       | _ -> constFold machdep (AlignOf (typeOf e))
  4890:   end
  4891: 
  4892:   | CastE (t, e) -> begin
  4893:       match constFold machdep e, unrollType t with
  4894:         (* Might truncate silently *)
  4895:         Const(CInt64(i,k,_)), TInt(nk,_) ->
  4896:           let i' = truncateInteger64 nk i in
  4897:           Const(CInt64(i', nk, None))
  4898:       | e', _ -> CastE (t, e')
  4899:   end
  4900: 
  4901:   | _ -> e
  4902: 
  4903: and constFoldBinOp (machdep: bool) bop e1 e2 tres =
  4904:   let e1' = constFold machdep e1 in
  4905:   let e2' = constFold machdep e2 in
  4906:   if isIntegralType tres then begin
  4907:     let newe =
  4908:       let rec mkInt = function
  4909:           Const(CChr c) -> Const(CInt64(Int64.of_int (Char.code c),
  4910:                                         IInt, None))
  4911:         | CastE(TInt (ik, ta), e) -> begin
  4912:             match mkInt e with
  4913:               Const(CInt64(i, _, _)) ->
  4914:                 let i' = truncateInteger64 ik i in
  4915:                 Const(CInt64(i', ik, None))
  4916: 
  4917:             | e' -> CastE(TInt(ik, ta), e')
  4918:         end
  4919:         | e -> e
  4920:       in
  4921:       let tk =
  4922:         match unrollType tres with
  4923:           TInt(ik, _) -> ik
  4924:         | TEnum _ -> IInt
  4925:         | _ -> E.s (bug "constFoldBinOp")
  4926:       in
  4927:       (* See if the result is unsigned *)
  4928:       let isunsigned typ = not (isSigned typ) in
  4929:       let ge (unsigned: bool) (i1: int64) (i2: int64) : bool =
  4930:         if unsigned then
  4931:           let l1 = Int64.shift_right_logical i1 1 in
  4932:           let l2 = Int64.shift_right_logical i2 1 in (* Both positive now *)
  4933:           (l1 > l2) || (l1 = l2 &&
  4934:                         Int64.logand i1 Int64.one >= Int64.logand i2 Int64.one)
  4935:         else i1 >= i2
  4936:       in
  4937:       (* Assume that the necessary promotions have been done *)
  4938:       match bop, mkInt e1', mkInt e2' with
  4939:       | PlusA, Const(CInt64(z,_,_)), e2'' when z = Int64.zero -> e2''
  4940:       | PlusA, e1'', Const(CInt64(z,_,_)) when z = Int64.zero -> e1''
  4941:       | PlusPI, e1'', Const(CInt64(z,_,_)) when z = Int64.zero -> e1''
  4942:       | IndexPI, e1'', Const(CInt64(z,_,_)) when z = Int64.zero -> e1''
  4943:       | MinusPI, e1'', Const(CInt64(z,_,_)) when z = Int64.zero -> e1''
  4944:       | PlusA, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
  4945:           kinteger64 tk (Int64.add i1 i2)
  4946:       | MinusA, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
  4947:           kinteger64 tk (Int64.sub i1 i2)
  4948:       | Mult, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
  4949:           kinteger64 tk (Int64.mul i1 i2)
  4950:       | Div, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> begin
  4951:           try kinteger64 tk (Int64.div i1 i2)
  4952:           with Division_by_zero -> BinOp(bop, e1', e2', tres)
  4953:       end
  4954:       | Mod, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> begin
  4955:           try kinteger64 tk (Int64.rem i1 i2)
  4956:           with Division_by_zero -> BinOp(bop, e1', e2', tres)
  4957:       end
  4958:       | BAnd, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
  4959:           kinteger64 tk (Int64.logand i1 i2)
  4960:       | BOr, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
  4961:           kinteger64 tk (Int64.logor i1 i2)
  4962:       | BXor, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
  4963:           kinteger64 tk (Int64.logxor i1 i2)
  4964:       | Shiftlt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,IInt,_)) ->
  4965:           kinteger64 tk (Int64.shift_left i1 (Int64.to_int i2))
  4966:       | Shiftrt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,IInt,_)) ->
  4967:           if isunsigned ik1 then
  4968:             kinteger64 tk (Int64.shift_right_logical i1 (Int64.to_int i2))
  4969:           else
  4970:             kinteger64 tk (Int64.shift_right i1 (Int64.to_int i2))
  4971: 
  4972:       | Eq, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
  4973:           integer (if i1 = i2 then 1 else 0)
  4974:       | Ne, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
  4975:           integer (if i1 <> i2 then 1 else 0)
  4976:       | Le, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
  4977:           integer (if ge (isunsigned ik1) i2 i1 then 1 else 0)
  4978: 
  4979:       | Ge, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
  4980:           integer (if ge (isunsigned ik1) i1 i2 then 1 else 0)
  4981: 
  4982:       | Lt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
  4983:           integer (if i1 <> i2 && ge (isunsigned ik1) i2 i1 then 1 else 0)
  4984: 
  4985:       | Gt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
  4986:           integer (if i1 <> i2 && ge (isunsigned ik1) i1 i2 then 1 else 0)
  4987:       | LAnd, _, _ when isZero e1' || isZero e2' -> zero
  4988:       | LOr, _, _ when isZero e1' -> e2'
  4989:       | LOr, _, _ when isZero e2' -> e1'
  4990:       | _ -> BinOp(bop, e1', e2', tres)
  4991:     in
  4992:     if debugConstFold then
  4993:       ignore (E.log "Folded %a to %a\n" d_exp (BinOp(bop, e1', e2', tres)) d_exp newe);
  4994:     newe
  4995:   end else
  4996:     BinOp(bop, e1', e2', tres)
  4997: 
  4998: 
  4999: (* Try to do an increment, with constant folding *)
  5000: let increm (e: exp) (i: int) =
  5001:   let et = typeOf e in
  5002:   let bop = if isPointerType et then PlusPI else PlusA in
  5003:   constFold false (BinOp(bop, e, integer i, et))
  5004: 
  5005: exception LenOfArray
  5006: let lenOfArray (eo: exp option) : int =
  5007:   match eo with
  5008:     None -> raise LenOfArray
  5009:   | Some e -> begin
  5010:       match constFold true e with
  5011:       | Const(CInt64(ni, _, _)) when ni >= Int64.zero ->
  5012:           Int64.to_int ni
  5013:       | e -> raise LenOfArray
  5014:   end
  5015: 
  5016: 
  5017: (*** Make a initializer for zeroe-ing a data type ***)
  5018: let rec makeZeroInit (t: typ) : init =
  5019:   match unrollType t with
  5020:     TInt (ik, _) -> SingleInit (Const(CInt64(Int64.zero, ik, None)))
  5021:   | TFloat(fk, _) -> SingleInit(Const(CReal(0.0, fk, None)))
  5022:   | TEnum _ -> SingleInit zero
  5023:   | TComp (comp, _) as t' when comp.cstruct ->
  5024:       let inits =
  5025:         List.fold_right
  5026:           (fun f acc ->
  5027:             if f.fname <> missingFieldName then
  5028:               (Field(f, NoOffset), makeZeroInit f.ftype) :: acc
  5029:             else
  5030:               acc)
  5031:           comp.cfields []
  5032:       in
  5033:       CompoundInit (t', inits)
  5034: 
  5035:   | TComp (comp, _) as t' when not comp.cstruct ->
  5036:       let fstfield =
  5037:         match comp.cfields with
  5038:           f :: _ -> f
  5039:         | [] -> E.s (unimp "Cannot create init for empty union")
  5040:       in
  5041:       CompoundInit(t, [(Field(fstfield, NoOffset),
  5042:                         makeZeroInit fstfield.ftype)])
  5043: 
  5044:   | TArray(bt, Some len, _) as t' ->
  5045:       let n =
  5046:         match constFold true len with
  5047:           Const(CInt64(n, _, _)) -> Int64.to_int n
  5048:         | _ -> E.s (E.unimp "Cannot understand length of array")
  5049:       in
  5050:       let initbt = makeZeroInit bt in
  5051:       let rec loopElems acc i =
  5052:         if i < 0 then acc
  5053:         else loopElems ((Index(integer i, NoOffset), initbt) :: acc) (i - 1)
  5054:       in
  5055:       CompoundInit(t', loopElems [] (n - 1))
  5056: 
  5057:   | TArray (bt, None, at) as t' ->
  5058:       (* Unsized array, allow it and fill it in later
  5059:        * (see cabs2cil.ml, collectInitializer) *)
  5060:       CompoundInit (t', [])
  5061: 
  5062:   | TPtr _ as t -> SingleInit(CastE(t, zero))
  5063:   | x -> E.s (unimp "Cannot initialize type: %a" d_type x)
  5064: 
  5065: 
  5066: (**** Fold over the list of initializers in a Compound. In the case of an
  5067:  * array initializer only the initializers present are scanned (a prefix of
  5068:  * all initializers) *)
  5069: let foldLeftCompound
  5070:     ~(doinit: offset -> init -> typ -> 'a -> 'a)
  5071:     ~(ct: typ)
  5072:     ~(initl: (offset * init) list)
  5073:     ~(acc: 'a) : 'a =
  5074:   match unrollType ct with
  5075:     TArray(bt, _, _) ->
  5076:       List.fold_left (fun acc (o, i) -> doinit o i bt acc) acc initl
  5077: 
  5078:   | TComp (comp, _) ->
  5079:       let getTypeOffset = function
  5080:           Field(f, NoOffset) -> f.ftype
  5081:         | _ -> E.s (bug "foldLeftCompound: malformed initializer")
  5082:       in
  5083:       List.fold_left
  5084:         (fun acc (o, i) -> doinit o i (getTypeOffset o) acc) acc initl
  5085: 
  5086:   | _ -> E.s (unimp "Type of Compound is not array or struct or union")
  5087: 
  5088: (**** Fold over the list of initializers in a Compound. Like foldLeftCompound
  5089:  * but scans even the zero-initializers that are missing at the end of the
  5090:  * array *)
  5091: let foldLeftCompoundAll
  5092:     ~(doinit: offset -> init -> typ -> 'a -> 'a)
  5093:     ~(ct: typ)
  5094:     ~(initl: (offset * init) list)
  5095:     ~(acc: 'a) : 'a =
  5096:   match unrollType ct with
  5097:     TArray(bt, leno, _) -> begin
  5098:       let part =
  5099:         List.fold_left (fun acc (o, i) -> doinit o i bt acc) acc initl in
  5100:       (* See how many more we have to do *)
  5101:       match leno with
  5102:         Some lene -> begin
  5103:           match constFold true lene with
  5104:             Const(CInt64(i, _, _)) ->
  5105:               let len_array = Int64.to_int i in
  5106:               let len_init = List.length initl in
  5107:               if len_array > len_init then
  5108:                 let zi = makeZeroInit bt in
  5109:                 let rec loop acc i =
  5110:                   if i >= len_array then acc
  5111:                   else
  5112:                     loop (doinit (Index(integer i, NoOffset)) zi bt acc)
  5113:                          (i + 1)
  5114:                 in
  5115:                 loop part (len_init + 1)
  5116:               else
  5117:                 part
  5118:           | _ -> E.s (unimp "foldLeftCompoundAll: array with initializer and non-constant length\n")
  5119:         end
  5120: 
  5121:       | _ -> E.s (unimp "foldLeftCompoundAll: TArray with initializer and no length")
  5122:     end
  5123:   | TComp (comp, _) ->
  5124:       let getTypeOffset = function
  5125:           Field(f, NoOffset) -> f.ftype
  5126:         | _ -> E.s (bug "foldLeftCompound: malformed initializer")
  5127:       in
  5128:       List.fold_left
  5129:         (fun acc (o, i) -> doinit o i (getTypeOffset o) acc) acc initl
  5130: 
  5131:   | _ -> E.s (E.unimp "Type of Compound is not array or struct or union")
  5132: 
  5133: 
  5134: 
  5135: let rec isCompleteType t =
  5136:   match unrollType t with
  5137:   | TArray(t, None, _) -> false
  5138:   | TArray(t, Some z, _) when isZero z -> false
  5139:   | TComp (comp, _) -> (* Struct or union *)
  5140:       List.for_all (fun fi -> isCompleteType fi.ftype) comp.cfields
  5141:   | _ -> true
  5142: 
  5143: 
  5144: 
  5145: let debugAlpha (prefix: string) = false
  5146: (*** Alpha conversion ***)
  5147: let alphaSeparator = "___"
  5148: let alphaSeparatorLen = String.length alphaSeparator
  5149: 
  5150: (** For each prefix we remember the list of suffixes and the next integer
  5151:  * suffix to use *)
  5152: type alphaTableData = int * (string * location) list
  5153: 
  5154: type undoAlphaElement =
  5155:     AlphaChangedSuffix of alphaTableData ref * alphaTableData (* The
  5156:                                              * reference that was changed and
  5157:                                              * the old suffix *)
  5158:   | AlphaAddedSuffix of string          (* We added this new entry to the
  5159:                                          * table *)
  5160: 
  5161: (* Create a new name based on a given name. The new name is formed from a
  5162:  * prefix (obtained from the given name by stripping a suffix consisting of
  5163:  * the alphaSeparator followed by only digits), followed by alphaSeparator
  5164:  * and then by a positive integer suffix. The first argument is a table
  5165:  * mapping name prefixes to the largest suffix used so far for that
  5166:  * prefix. The largest suffix is one when only the version without suffix has
  5167:  * been used. *)
  5168: let rec newAlphaName ~(alphaTable: (string, alphaTableData ref) H.t)
  5169:                      ~(undolist: undoAlphaElement list ref option)
  5170:                      ~(lookupname: string) : string * location =
  5171:   alphaWorker ~alphaTable:alphaTable ~undolist:undolist
  5172:               ~lookupname:lookupname true
  5173: 
  5174: 
  5175: (** Just register the name so that we will not use in the future *)
  5176: and registerAlphaName ~(alphaTable: (string, alphaTableData ref) H.t)
  5177:                       ~(undolist: undoAlphaElement list ref option)
  5178:                       ~(lookupname: string) : unit =
  5179:   ignore (alphaWorker ~alphaTable:alphaTable ~undolist:undolist
  5180:                       ~lookupname:lookupname false)
  5181: 
  5182: 
  5183: and alphaWorker      ~(alphaTable: (string, alphaTableData ref) H.t)
  5184:                      ~(undolist: undoAlphaElement list ref option)
  5185:                      ~(lookupname: string)
  5186:                      (make_new: bool) : string * location =
  5187:   let prefix, suffix, (numsuffix: int) = splitNameForAlpha ~lookupname in
  5188:   if debugAlpha prefix then
  5189:     ignore (E.log "Alpha worker: prefix=%s suffix=%s (%d) create=%b. "
  5190:               prefix suffix numsuffix make_new);
  5191:   let newname, (oldloc: location) =
  5192:     try
  5193:       let rc = H.find alphaTable prefix in
  5194:       let max, suffixes = !rc in
  5195:       (* We have seen this prefix *)
  5196:       if debugAlpha prefix then
  5197:         ignore (E.log " Old max %d. Old suffixes: @[%a@]" max
  5198:                   (docList (chr ',')
  5199:                      (fun (s, l) -> dprintf "%a:%s" d_loc l s)) suffixes);
  5200:       (* Save the undo info *)
  5201:       (match undolist with
  5202:         Some l -> l := AlphaChangedSuffix (rc, !rc) :: !l
  5203:       | _ -> ());
  5204: 
  5205:       let newmax, newsuffix, (oldloc: location), newsuffixes =
  5206:         if numsuffix > max then begin
  5207:           (* Clearly we have not seen it *)
  5208:           numsuffix, suffix, !currentLoc,
  5209:           (suffix, !currentLoc) :: suffixes
  5210:         end else begin
  5211:           match List.filter (fun (n, _) -> n = suffix) suffixes with
  5212:             [] -> (* Not found *)
  5213:               max, suffix, !currentLoc, (suffix, !currentLoc) :: suffixes
  5214:           | [(_, l) ] ->
  5215:               (* We have seen this exact suffix before *)
  5216:               if make_new then
  5217:                 let newsuffix = alphaSeparator ^ (string_of_int (max + 1)) in
  5218:                 max + 1, newsuffix, l, (newsuffix, !currentLoc) :: suffixes
  5219:               else
  5220:                 max, suffix, !currentLoc, suffixes
  5221:           |  _ -> E.s (E.bug "Flx_cil_cil.alphaWorker")
  5222:         end
  5223:       in
  5224:       rc := (newmax, newsuffixes);
  5225:       prefix ^ newsuffix, oldloc
  5226:     with Not_found -> begin (* First variable with this prefix *)
  5227:       (match undolist with
  5228:         Some l -> l := AlphaAddedSuffix prefix :: !l
  5229:       | _ -> ());
  5230:       H.add alphaTable prefix (ref (numsuffix, [ (suffix, !currentLoc) ]));
  5231:       if debugAlpha prefix then ignore (E.log " First seen. ");
  5232:       lookupname, !currentLoc  (* Return the original name *)
  5233:     end
  5234:   in
  5235:   if debugAlpha prefix then
  5236:     ignore (E.log " Res=: %s (%a)\n" newname d_loc oldloc);
  5237:   newname, oldloc
  5238: 
  5239: (* Strip the suffix. Return the prefix, the suffix (including the separator
  5240:  * and the numeric value, possibly empty), and the
  5241:  * numeric value of the suffix (possibly -1 if missing) *)
  5242: and splitNameForAlpha ~(lookupname: string) : (string * string * int) =
  5243:   let len = String.length lookupname in
  5244:   (* Search backward for the numeric suffix. Return the first digit of the
  5245:    * suffix. Returns len if no numeric suffix *)
  5246:   let rec skipSuffix (i: int) =
  5247:     if i = -1 then -1 else
  5248:     let c = Char.code (String.get lookupname i) - Char.code '0' in
  5249:     if c >= 0 && c <= 9 then
  5250:       skipSuffix (i - 1)
  5251:     else (i + 1)
  5252:   in
  5253:   let startSuffix = skipSuffix (len - 1) in
  5254: 
  5255:   if startSuffix >= len (* No digits at all at the end *) ||
  5256:      startSuffix <= alphaSeparatorLen     (* Not enough room for a prefix and
  5257:                                            * the separator before suffix *) ||
  5258:      (* Suffix starts with a 0 and has more characters after that *)
  5259:      (startSuffix < len - 1 && String.get lookupname startSuffix = '0')  ||
  5260:      alphaSeparator <> String.sub lookupname
  5261:                                  (startSuffix - alphaSeparatorLen)
  5262:                                  alphaSeparatorLen
  5263:   then
  5264:     (lookupname, "", -1)  (* No valid suffix in the name *)
  5265:   else
  5266:     (String.sub lookupname 0 (startSuffix - alphaSeparatorLen),
  5267:      String.sub lookupname (startSuffix - alphaSeparatorLen)
  5268:                            (len - startSuffix + alphaSeparatorLen),
  5269:      int_of_string (String.sub lookupname startSuffix (len - startSuffix)))
  5270: 
  5271: 
  5272: let getAlphaPrefix ~(lookupname:string) : string =
  5273:   let p, _, _ = splitNameForAlpha ~lookupname:lookupname in
  5274:   p
  5275: 
  5276: (* Undoes the changes as specified by the undolist *)
  5277: let undoAlphaChanges ~(alphaTable: (string, alphaTableData ref) H.t)
  5278:                      ~(undolist: undoAlphaElement list) =
  5279:   List.iter
  5280:     (function
  5281:         AlphaChangedSuffix (where, old) ->
  5282:           where := old
  5283:       | AlphaAddedSuffix name ->
  5284:           if debugAlpha name then
  5285:             ignore (E.log "Removing %s from alpha table\n" name);
  5286:           H.remove alphaTable name)
  5287:     undolist
  5288: 
  5289: let docAlphaTable () (alphaTable: (string, alphaTableData ref) H.t) =
  5290:   let acc : (string * (int * (string * location) list)) list ref = ref [] in
  5291:   H.iter (fun k d -> acc := (k, !d) :: !acc) alphaTable;
  5292:   docList line (fun (k, (d, _)) -> dprintf "  %s -> %d" k d) () !acc
  5293: 
  5294: 
  5295: (** Uniquefy the variable names *)
  5296: let uniqueVarNames (f: file) : unit =
  5297:   (* Setup the alpha conversion table for globals *)
  5298:   let gAlphaTable: (string, alphaTableData ref) H.t = H.create 113 in
  5299:   (* Keep also track of the global names that we have used. Map them to the
  5300:    * variable ID. We do this only to check that we do not have two globals
  5301:    * with the same name. *)
  5302:   let globalNames: (string, int) H.t = H.create 113 in
  5303:   (* Scan the file and add the global names to the table *)
  5304:   iterGlobals f
  5305:     (function
  5306:         GVarDecl(vi, l)
  5307:       | GVar(vi, _, l)
  5308:       | GFun({svar = vi}, l) ->
  5309:           (* See if we have used this name already for something else *)
  5310:           (try
  5311:             let oldid = H.find globalNames vi.vname in
  5312:             if oldid <> vi.vid then
  5313:               ignore (warn "The name %s is used for two distinct globals"
  5314:                         vi.vname);
  5315:             (* Here if we have used this name already. Go ahead *)
  5316:             ()
  5317:           with Not_found -> begin
  5318:             (* Here if this is the first time we define a name *)
  5319:             H.add globalNames vi.vname vi.vid;
  5320:             (* And register it *)
  5321:             registerAlphaName gAlphaTable None vi.vname;
  5322:             ()
  5323:           end)
  5324:       | _ -> ());
  5325: 
  5326:   (* Now we must scan the function bodies and rename the locals *)
  5327:   iterGlobals f
  5328:     (function
  5329:         GFun(fdec, l) -> begin
  5330:           currentLoc := l;
  5331:           (* Setup an undo list to be able to revert the changes to the
  5332:            * global alpha table *)
  5333:           let undolist = ref [] in
  5334:           (* Process one local variable *)
  5335:           let processLocal (v: varinfo) =
  5336:             let newname, oldloc =
  5337:               newAlphaName gAlphaTable (Some undolist) v.vname in
  5338:             if false && newname <> v.vname then (* Disable this warning *)
  5339:               ignore (warn "uniqueVarNames: Changing the name of local %s in %s to %s (due to duplicate at %a)\n"
  5340:                         v.vname fdec.svar.vname newname d_loc oldloc);
  5341:             v.vname <- newname
  5342:           in
  5343:           (* Do the formals first *)
  5344:           List.iter processLocal fdec.sformals;
  5345:           (* Fix the type again *)
  5346:           setFormals fdec fdec.sformals;
  5347:           (* And now the locals *)
  5348:           List.iter processLocal fdec.slocals;
  5349:           (* Undo the changes to the global table *)
  5350:           undoAlphaChanges gAlphaTable !undolist;
  5351:           ()
  5352:         end
  5353:       | _ -> ());
  5354:   ()
  5355: 
  5356: 
  5357: (* A visitor that makes a deep copy of a function body *)
  5358: class copyFunctionVisitor (newname: string) = object (self)
  5359:   inherit nopCilVisitor
  5360: 
  5361:       (* Keep here a maping from locals to their copies *)
  5362:   val map : (string, varinfo) H.t = H.create 113
  5363:       (* Keep here a maping from statements to their copies *)
  5364:   val stmtmap : (int, stmt) H.t = H.create 113
  5365:   val sid = ref 0 (* Will have to assign ids to statements *)
  5366:       (* Keep here a list of statements to be patched *)
  5367:   val patches : stmt list ref = ref []
  5368: 
  5369:   val argid = ref 0
  5370: 
  5371:       (* This is the main function *)
  5372:   method vfunc (f: fundec) : fundec visitAction =
  5373:     (* We need a map from the old locals/formals to the new ones *)
  5374:     H.clear map;
  5375:     argid := 0;
  5376:      (* Make a copy of the fundec. *)
  5377:     let f' = {f with svar = f.svar} in
  5378:     let patchfunction (f' : fundec) =
  5379:       (* Change the name. Only this late to allow the visitor to copy the
  5380:        * svar  *)
  5381:       f'.svar.vname <- newname;
  5382:       let findStmt (i: int) =
  5383:         try H.find stmtmap i
  5384:         with Not_found -> E.s (bug "Cannot find the copy of stmt#%d" i)
  5385:       in
  5386:       let patchstmt (s: stmt) =
  5387:         match s.skind with
  5388:           Goto (sr, l) ->
  5389:             (* Make a copy of the reference *)
  5390:             let sr' = ref (findStmt !sr.sid) in
  5391:             s.skind <- Goto (sr',l)
  5392:         | Switch (e, body, cases, l) ->
  5393:             s.skind <- Switch (e, body,
  5394:                                List.map (fun cs -> findStmt cs.sid) cases, l)
  5395:         | _ -> ()
  5396:       in
  5397:       List.iter patchstmt !patches;
  5398:       f'
  5399:     in
  5400:     patches := [];
  5401:     sid := 0;
  5402:     H.clear stmtmap;
  5403:     ChangeDoChildrenPost (f', patchfunction)
  5404: 
  5405:       (* We must create a new varinfo for each declaration. Memoize to
  5406:        * maintain sharing *)
  5407:   method vvdec (v: varinfo) =
  5408:     (* Some varinfo have empty names. Give them some name *)
  5409:     if v.vname = "" then begin
  5410:       v.vname <- "arg" ^ string_of_int !argid; incr argid
  5411:     end;
  5412:     try
  5413:       ChangeTo (H.find map v.vname)
  5414:     with Not_found -> begin
  5415:       let v' = {v with vid = !nextGlobalVID} in
  5416:       incr nextGlobalVID;
  5417:       H.add map v.vname v';
  5418:       ChangeDoChildrenPost (v', fun x -> x)
  5419:     end
  5420: 
  5421:       (* We must replace references to local variables *)
  5422:   method vvrbl (v: varinfo) =
  5423:     if v.vglob then SkipChildren else
  5424:     try
  5425:       ChangeTo (H.find map v.vname)
  5426:     with Not_found ->
  5427:       E.s (bug "Cannot find the new copy of local variable %s" v.vname)
  5428: 
  5429: 
  5430:         (* Replace statements. *)
  5431:   method vstmt (s: stmt) : stmt visitAction =
  5432:     s.sid <- !sid; incr sid;
  5433:     let s' = {s with sid = s.sid} in
  5434:     H.add stmtmap s.sid s'; (* Remember where we copied this *)
  5435:     (* if we have a Goto or a Switch remember them to fixup at end *)
  5436:     (match s'.skind with
  5437:       (Goto _ | Switch _) -> patches := s' :: !patches
  5438:     | _ -> ());
  5439:     (* Do the children *)
  5440:     ChangeDoChildrenPost (s', fun x -> x)
  5441: 
  5442:       (* Copy blocks since they are mutable *)
  5443:   method vblock (b: block) =
  5444:     ChangeDoChildrenPost ({b with bstmts = b.bstmts}, fun x -> x)
  5445: 
  5446: 
  5447:   method vglob _ = E.s (bug "copyFunction should not be used on globals")
  5448: end
  5449: 
  5450: (* We need a function that copies a CIL function. *)
  5451: let copyFunction (f: fundec) (newname: string) : fundec =
  5452:   visitCilFunction (new copyFunctionVisitor(newname)) f
  5453: 
  5454: (********* Compute the CFG ********)
  5455: let sid_counter = ref 0
  5456: let statements : stmt list ref = ref []
  5457: (* Clear all info about the CFG in statements *)
  5458: class clear : cilVisitor = object
  5459:   inherit nopCilVisitor
  5460:   method vstmt s = begin
  5461:     s.sid <- !sid_counter ;
  5462:     incr sid_counter ;
  5463:     statements := s :: !statements;
  5464:     s.succs <- [] ;
  5465:     s.preds <- [] ;
  5466:     DoChildren
  5467:   end
  5468:   method vexpr _ = SkipChildren
  5469:   method vtype _ = SkipChildren
  5470:   method vinst _ = SkipChildren
  5471: end
  5472: 
  5473: let link source dest = begin
  5474:   if not (List.mem dest source.succs) then
  5475:     source.succs <- dest :: source.succs ;
  5476:   if not (List.mem source dest.preds) then
  5477:     dest.preds <- source :: dest.preds
  5478: end
  5479: let trylink source dest_option = match dest_option with
  5480:   None -> ()
  5481: | Some(dest) -> link source dest
  5482: 
  5483: let rec succpred_block b fallthrough =
  5484:   let rec handle sl = match sl with
  5485:     [] -> ()
  5486:   | [a] -> succpred_stmt a fallthrough
  5487:   | hd :: tl -> succpred_stmt hd (Some(List.hd tl)) ;
  5488:                 handle tl
  5489:   in handle b.bstmts
  5490: and succpred_stmt s fallthrough =
  5491:   match s.skind with
  5492:     Instr _ -> trylink s fallthrough
  5493:   | Return _ -> ()
  5494:   | Goto(dest,l) -> link s !dest
  5495:   | Break _
  5496:   | Continue _
  5497:   | Switch _ ->
  5498:     failwith "computeCFGInfo: cannot be called on functions with break, continue or switch statements. Use prepareCFG first to remove them."
  5499:   | If(e1,b1,b2,l) ->
  5500:       (match b1.bstmts with
  5501:         [] -> trylink s fallthrough
  5502:       | hd :: tl -> (link s hd ; succpred_block b1 fallthrough )) ;
  5503:       (match b2.bstmts with
  5504:         [] -> trylink s fallthrough
  5505:       | hd :: tl -> (link s hd ; succpred_block b2 fallthrough ))
  5506:   | Loop(b,l,_,_) -> begin match b.bstmts with
  5507:                    [] -> failwith "computeCFGInfo: empty loop"
  5508:                  | hd :: tl ->
  5509:                     link s hd ;
  5510:                     succpred_block b (Some(hd))
  5511:                  end
  5512:   | Block(b) -> begin match b.bstmts with
  5513:                   [] -> trylink s fallthrough
  5514:                 | hd :: tl -> link s hd ;
  5515:                     succpred_block b fallthrough
  5516:                 end
  5517:   | TryExcept _ | TryFinally _ ->
  5518:       failwith "computeCFGInfo: structured exception handling not implemented"
  5519: 
  5520: (* [weimer] Sun May  5 12:25:24 PDT 2002
  5521:  * This code was pulled from ext/switch.ml because it looks like we really
  5522:  * want it to be part of CIL.
  5523:  *
  5524:  * Here is the magic handling to
  5525:  *  (1) replace switch statements with if/goto
  5526:  *  (2) remove "break"
  5527:  *  (3) remove "default"
  5528:  *  (4) remove "continue"
  5529:  *)
  5530: let is_case_label l = match l with
  5531:   | Case _ | Default _ -> true
  5532:   | _ -> false
  5533: 
  5534: let switch_count = ref (-1)
  5535: let get_switch_count () =
  5536:   switch_count := 1 + !switch_count ;
  5537:   !switch_count
  5538: 
  5539: let switch_label = ref (-1)
  5540: 
  5541: let rec xform_switch_stmt s break_dest cont_dest label_index = begin
  5542:   s.labels <- List.map (fun lab -> match lab with
  5543:     Label _ -> lab
  5544:   | Case(e,l) ->
  5545:       let suffix =
  5546:         match isInteger e with
  5547:         | Some value ->
  5548:             if value < Int64.zero then
  5549:               "neg_" ^ Int64.to_string (Int64.neg value)
  5550:             else
  5551:               Int64.to_string value
  5552:         | None ->
  5553:             incr switch_label;
  5554:             "exp_" ^ string_of_int !switch_label
  5555:       in
  5556:       let str = Flx_cil_pretty.sprint 80
  5557:           (Flx_cil_pretty.dprintf "switch_%d_%s" label_index suffix) in
  5558:       (Label(str,l,false))
  5559:   | Default(l) -> (Label(Printf.sprintf
  5560:                   "switch_%d_default" label_index,l,false))
  5561:   ) s.labels ;
  5562:   match s.skind with
  5563:   | Instr _ | Return _ | Goto _ -> ()
  5564:   | Break(l) -> begin try
  5565:                   s.skind <- Goto(break_dest (),l)
  5566:                 with e ->
  5567:                   ignore (error "prepareCFG: break: %a@!" d_stmt s) ;
  5568:                   raise e
  5569:                 end
  5570:   | Continue(l) -> begin try
  5571:                   s.skind <- Goto(cont_dest (),l)
  5572:                 with e ->
  5573:                   ignore (error "prepareCFG: continue: %a@!" d_stmt s) ;
  5574:                   raise e
  5575:                 end
  5576:   | If(e,b1,b2,l) -> xform_switch_block b1 break_dest cont_dest label_index ;
  5577:                      xform_switch_block b2 break_dest cont_dest label_index
  5578:   | Switch(e,b,sl,l) -> begin
  5579:       (* change
  5580:        * switch (se) {
  5581:        *   case 0: s0 ;
  5582:        *   case 1: s1 ; break;
  5583:        *   ...
  5584:        * }
  5585:        *
  5586:        * into:
  5587:        *
  5588:        * if (se == 0) goto label_0;
  5589:        * else if (se == 1) goto label_1;
  5590:        * ...
  5591:        * else if (0) { // body_block
  5592:        *  label_0: s0;
  5593:        *  label_1: s1; goto label_break;
  5594:        *  ...
  5595:        * } else if (0) { // break_block
  5596:        *  label_break: ; // break_stmt
  5597:        * }
  5598:        *)
  5599:       let i = get_switch_count () in
  5600:       let break_stmt = mkStmt (Instr []) in
  5601:       break_stmt.labels <-
  5602:                                 [Label((Printf.sprintf "switch_%d_break" i),l,false)] ;
  5603:       let break_block = mkBlock [ break_stmt ] in
  5604:       let body_block = b in
  5605:       let body_if_stmtkind = (If(zero,body_block,break_block,l)) in
  5606: 
  5607:       (* The default case, if present, must be used only if *all*
  5608:       non-default cases fail [ISO/IEC 9899:1999, §6.8.4.2, ¶5]. As a
  5609:       result, we sort the order in which we handle the labels (but not the
  5610:       order in which we print out the statements, so fall-through still
  5611:       works as expected). *)
  5612:       let compare_choices s1 s2 = match s1.labels, s2.labels with
  5613:       | (Default(_) :: _), _ -> 1
  5614:       | _, (Default(_) :: _) -> -1
  5615:       | _, _ -> 0
  5616:       in
  5617: 
  5618:       let rec handle_choices sl = match sl with
  5619:         [] -> body_if_stmtkind
  5620:       | stmt_hd :: stmt_tl -> begin
  5621:         let rec handle_labels lab_list = begin
  5622:           match lab_list with
  5623:             [] -> handle_choices stmt_tl
  5624:           | Case(ce,cl) :: lab_tl ->
  5625:               let pred = BinOp(Eq,e,ce,intType) in
  5626:               let then_block = mkBlock [ mkStmt (Goto(ref stmt_hd,cl)) ] in
  5627:               let else_block = mkBlock [ mkStmt (handle_labels lab_tl) ] in
  5628:               If(pred,then_block,else_block,cl)
  5629:           | Default(dl) :: lab_tl ->
  5630:               (* ww: before this was 'if (1) goto label', but as Ben points
  5631:               out this might confuse someone down the line who doesn't have
  5632:               special handling for if(1) into thinking that there are two
  5633:               paths here. The simpler 'goto label' is what we want. *)
  5634:               Block(mkBlock [ mkStmt (Goto(ref stmt_hd,dl)) ;
  5635:                               mkStmt (handle_labels lab_tl) ])
  5636:           | Label(_,_,_) :: lab_tl -> handle_labels lab_tl
  5637:         end in
  5638:         handle_labels stmt_hd.labels
  5639:       end in
  5640:       s.skind <- handle_choices (List.sort compare_choices sl) ;
  5641:       xform_switch_block b (fun () -> ref break_stmt) cont_dest i
  5642:     end
  5643:   | Loop(b,l,_,_) ->
  5644:           let i = get_switch_count () in
  5645:           let break_stmt = mkStmt (Instr []) in
  5646:           break_stmt.labels <-
  5647:                                                 [Label((Printf.sprintf "while_%d_break" i),l,false)] ;
  5648:           let cont_stmt = mkStmt (Instr []) in
  5649:           cont_stmt.labels <-
  5650:                                                 [Label((Printf.sprintf "while_%d_continue" i),l,false)] ;
  5651:           b.bstmts <- cont_stmt :: b.bstmts ;
  5652:           let this_stmt = mkStmt
  5653:             (Loop(b,l,Some(cont_stmt),Some(break_stmt))) in
  5654:           let break_dest () = ref break_stmt in
  5655:           let cont_dest () = ref cont_stmt in
  5656:           xform_switch_block b break_dest cont_dest label_index ;
  5657:           break_stmt.succs <- s.succs ;
  5658:           let new_block = mkBlock [ this_stmt ; break_stmt ] in
  5659:           s.skind <- Block new_block
  5660:   | Block(b) -> xform_switch_block b break_dest cont_dest label_index
  5661: 
  5662:   | TryExcept _ | TryFinally _ ->
  5663:       failwith "xform_switch_statement: structured exception handling not implemented"
  5664: 
  5665: end and xform_switch_block b break_dest cont_dest label_index =
  5666:   try
  5667:     let rec link_succs sl = match sl with
  5668:     | [] -> ()
  5669:     | hd :: tl -> (if hd.succs = [] then hd.succs <- tl) ; link_succs tl
  5670:     in
  5671:     link_succs b.bstmts ;
  5672:     List.iter (fun stmt ->
  5673:       xform_switch_stmt stmt break_dest cont_dest label_index) b.bstmts ;
  5674:   with e ->
  5675:     List.iter (fun stmt -> ignore
  5676:       (warn "prepareCFG: %a@!" d_stmt stmt)) b.bstmts ;
  5677:     raise e
  5678: 
  5679: (* prepare a function for computeCFGInfo by removing break, continue,
  5680:  * default and switch statements/labels and replacing them with Ifs and
  5681:  * Gotos. *)
  5682: let prepareCFG (fd : fundec) : unit =
  5683:   xform_switch_block fd.sbody
  5684:       (fun () -> failwith "prepareCFG: break with no enclosing loop")
  5685:       (fun () -> failwith "prepareCFG: continue with no enclosing loop") (-1)
  5686: 
  5687: (* make the cfg and return a list of statements *)
  5688: let computeCFGInfo (f : fundec) (global_numbering : bool) : stmt list =
  5689:   let clear_it = new clear in
  5690:   if not global_numbering then
  5691:     sid_counter := 0 ;
  5692:   statements := [];
  5693:   ignore (visitCilBlock clear_it f.sbody) ;
  5694:   f.smaxstmtid <- Some (!sid_counter) ;
  5695:   succpred_block f.sbody (None);
  5696:   let res = !statements in
  5697:   statements := [];
  5698:   res
  5699: 
  5700: let initCIL () =
  5701:   (* Set the machine *)
  5702:   theMachine := if !msvcMode then M.msvc else M.gcc;
  5703:   (* Pick type for string literals *)
  5704:   stringLiteralType := if !theMachine.const_string_literals then
  5705:     charConstPtrType
  5706:   else
  5707:     charPtrType;
  5708:   (* Find the right ikind given the size *)
  5709:   let findIkind (unsigned: bool) (sz: int) : ikind =
  5710:     (* Test the most common sizes first *)
  5711:     if sz = !theMachine.sizeof_int then
  5712:       if unsigned then IUInt else IInt
  5713:     else if sz = !theMachine.sizeof_long then
  5714:       if unsigned then IULong else ILong
  5715:     else if sz = 1 then
  5716:       if unsigned then IUChar else IChar
  5717:     else if sz = !theMachine.sizeof_short then
  5718:       if unsigned then IUShort else IShort
  5719:     else if sz = !theMachine.sizeof_longlong then
  5720:       if unsigned then IULongLong else ILongLong
  5721:     else
  5722:       E.s(E.unimp "initCIL: cannot find the right ikind for size %d\n" sz)
  5723:   in
  5724:   upointType := TInt(findIkind true !theMachine.sizeof_ptr, []);
  5725:   kindOfSizeOf := findIkind true !theMachine.sizeof_size;
  5726:   typeOfSizeOf := TInt(!kindOfSizeOf, []);
  5727:   H.add gccBuiltins "__builtin_memset"
  5728:     (voidPtrType, [ voidPtrType; intType; intType ], false);
  5729:   wcharKind := findIkind false !theMachine.sizeof_wchar;
  5730:   wcharType := TInt(!wcharKind, []);
  5731:   char_is_unsigned := !theMachine.char_is_unsigned;
  5732:   little_endian := !theMachine.little_endian;
  5733:   nextGlobalVID := 1;
  5734:   nextCompinfoKey := 1
  5735: 
  5736: 
  5737: (* We want to bring all type declarations before the data declarations. This
  5738:  * is needed for code of the following form:
  5739: 
  5740:    int f(); // Prototype without arguments
  5741:    typedef int FOO;
  5742:    int f(FOO x) { ... }
  5743: 
  5744:    In CIL the prototype also lists the type of the argument as being FOO,
  5745:    which is undefined.
  5746: 
  5747:    There is one catch with this scheme. If the type contains an array whose
  5748:    length refers to variables then those variables must be declared before
  5749:    the type *)
  5750: 
  5751: let pullTypesForward = true
  5752: 
  5753: 
  5754:     (* Scan a type and collect the variables that are refered *)
  5755: class getVarsInGlobalClass (pacc: varinfo list ref) = object
  5756:   inherit nopCilVisitor
  5757:   method vvrbl (vi: varinfo) =
  5758:     pacc := vi :: !pacc;
  5759:     SkipChildren
  5760: 
  5761:   method vglob = function
  5762:       GType _ | GCompTag _ -> DoChildren
  5763:     | _ -> SkipChildren
  5764: 
  5765: end
  5766: 
  5767: let getVarsInGlobal (g : global) : varinfo list =
  5768:   let pacc : varinfo list ref = ref [] in
  5769:   let v : cilVisitor = new getVarsInGlobalClass pacc in
  5770:   ignore (visitCilGlobal v g);
  5771:   !pacc
  5772: 
  5773: let hasPrefix p s =
  5774:   let pl = String.length p in
  5775:   (String.length s >= pl) && String.sub s 0 pl = p
  5776: 
  5777: let pushGlobal (g: global)
  5778:                ~(types:global list ref)
  5779:                ~(variables: global list ref) =
  5780:   if not pullTypesForward then
  5781:     variables := g :: !variables
  5782:   else
  5783:     begin
  5784:       (* Collect a list of variables that are refered from the type. Return
  5785:        * Some if the global should go with the types and None if it should go
  5786:        * to the variables. *)
  5787:       let varsintype : (varinfo list * location) option =
  5788:         match g with
  5789:           GType (_, l) | GCompTag (_, l) -> Some (getVarsInGlobal g, l)
  5790:         | GEnumTag (_, l) | GPragma (Attr("pack", _), l)
  5791:         | GCompTagDecl (_, l) | GEnumTagDecl (_, l) -> Some ([], l)
  5792:           (** Move the warning pragmas early
  5793:         | GPragma(Attr(s, _), l) when hasPrefix "warning" s -> Some ([], l)
  5794:           *)
  5795:         | _ -> None (* Does not go with the types *)
  5796:       in
  5797:       match varsintype with
  5798:       None -> variables := g :: !variables
  5799:     | Some (vl, loc) ->
  5800:         types :=
  5801:            (* insert declarations for referred variables ('vl'), before
  5802:             * the type definition 'g' itself *)
  5803:            g :: (List.fold_left (fun acc v -> GVarDecl(v, loc) :: acc)
  5804:                                 !types vl)
  5805:   end
  5806: 
  5807: 
  5808: type formatArg =
  5809:     Fe of exp
  5810:   | Feo of exp option  (** For array lengths *)
  5811:   | Fu of unop
  5812:   | Fb of binop
  5813:   | Fk of ikind
  5814:   | FE of exp list (** For arguments in a function call *)
  5815:   | Ff of (string * typ * attributes) (** For a formal argument *)
  5816:   | FF of (string * typ * attributes) list (* For formal argument lists *)
  5817:   | Fva of bool (** For the ellipsis in a function type *)
  5818:   | Fv of varinfo
  5819:   | Fl of lval
  5820:   | Flo of lval option (** For the result of a function call *)
  5821:   | Fo of offset
  5822:   | Fc of compinfo
  5823:   | Fi of instr
  5824:   | FI of instr list
  5825:   | Ft of typ
  5826:   | Fd of int
  5827:   | Fg of string
  5828:   | Fs of stmt
  5829:   | FS of stmt list
  5830:   | FA of attributes
  5831: 
  5832:   | Fp of attrparam
  5833:   | FP of attrparam list
  5834: 
  5835:   | FX of string
  5836: 
  5837: let d_formatarg () = function
  5838:     Fe e -> dprintf "Fe(%a)" d_exp e
  5839:   | Feo None -> dprintf "Feo(None)"
  5840:   | Feo (Some e) -> dprintf "Feo(%a)" d_exp e
  5841:   | FE _ -> dprintf "FE()"
  5842:   | Fk ik -> dprintf "Fk()"
  5843:   | Fva b -> dprintf "Fva(%b)" b
  5844:   | Ff (an, _, _) -> dprintf "Ff(%s)" an
  5845:   | FF _ -> dprintf "FF(...)"
  5846:   | FA _ -> dprintf "FA(...)"
  5847:   | Fu uo -> dprintf "Fu()"
  5848:   | Fb bo -> dprintf "Fb()"
  5849:   | Fv v -> dprintf "Fv(%s)" v.vname
  5850:   | Fl l -> dprintf "Fl(%a)" d_lval l
  5851:   | Flo None -> dprintf "Flo(None)"
  5852:   | Flo (Some l) -> dprintf "Flo(%a)" d_lval l
  5853:   | Fo o -> dprintf "Fo"
  5854:   | Fc ci -> dprintf "Fc(%s)" ci.cname
  5855:   | Fi i -> dprintf "Fi(...)"
  5856:   | FI i -> dprintf "FI(...)"
  5857:   | Ft t -> dprintf "Ft(%a)" d_type t
  5858:   | Fd n -> dprintf "Fd(%d)" n
  5859:   | Fg s -> dprintf "Fg(%s)" s
  5860:   | Fp _ -> dprintf "Fp(...)"
  5861:   | FP n -> dprintf "FP(...)"
  5862:   | Fs _ -> dprintf "FS"
  5863:   | FS _ -> dprintf "FS"
  5864: 
  5865:   | FX _ -> dprintf "FX()"
  5866: 
  5867: 
  5868: 
End ocaml section to src/flx_cil_cil.ml[1]
Start ocaml section to src/flx_cil_cil.mli[1 /1 ]
     1: # 7000 "./lpsrc/flx_cil.ipk"
     2: 
     3: (*
     4:  * CIL: An intermediate language for analyzing C programs.
     5:  *
     6:  * George Necula
     7:  *
     8:  *)
     9: 
    10: (** CIL API Documentation. An html version of this document can be found at
    11:  * http://manju.cs.berkeley.edu/cil. *)
    12: 
    13: (** Call this function to perform some initialization. Call if after you have
    14:  * set {!Flx_cil_cil.msvcMode}.  *)
    15: val initCIL: unit -> unit
    16: 
    17: 
    18: (** This are the CIL version numbers. A CIL version is a number of the form
    19:  * M.m.r (major, minor and release) *)
    20: val cilVersion: string
    21: val cilVersionMajor: int
    22: val cilVersionMinor: int
    23: val cilVersionRevision: int
    24: 
    25: (** This module defines the abstract syntax of CIL. It also provides utility
    26:  * functions for traversing the CIL data structures, and pretty-printing
    27:  * them. The parser for both the GCC and MSVC front-ends can be invoked as
    28:  * [Flx_cil_frontc.parse: string -> unit ->] {!Flx_cil_cil.file}. This function must be given
    29:  * the name of a preprocessed C file and will return the top-level data
    30:  * structure that describes a whole source file. By default the parsing and
    31:  * elaboration into CIL is done as for GCC source. If you want to use MSVC
    32:  * source you must set the {!Flx_cil_cil.msvcMode} to [true] and must also invoke the
    33:  * function [Flx_cil_frontc.setMSVCMode: unit -> unit]. *)
    34: 
    35: 
    36: (** {b The Abstract Syntax of CIL} *)
    37: 
    38: 
    39: (** The top-level representation of a CIL source file (and the result of the
    40:  * parsing and elaboration). Its main contents is the list of global
    41:  * declarations and definitions. You can iterate over the globals in a
    42:  * {!Flx_cil_cil.file} using the following iterators: {!Flx_cil_cil.mapGlobals},
    43:  * {!Flx_cil_cil.iterGlobals} and {!Flx_cil_cil.foldGlobals}. You can also use the
    44:  * {!Flx_cil_cil.dummyFile} when you need a {!Flx_cil_cil.file} as a placeholder. For each
    45:  * global item CIL stores the source location where it appears (using the
    46:  * type {!Flx_cil_cil.location}) *)
    47: 
    48: type file =
    49:     { mutable fileName: string;   (** The complete file name *)
    50:       mutable globals: global list; (** List of globals as they will appear
    51:                                         in the printed file *)
    52:       mutable globinit: fundec option;
    53:       (** An optional global initializer function. This is a function where
    54:        * you can put stuff that must be executed before the program is
    55:        * started. This function, is conceptually at the end of the file,
    56:        * although it is not part of the globals list. Use {!Flx_cil_cil.getGlobInit}
    57:        * to create/get one. *)
    58:       mutable globinitcalled: bool;
    59:       (** Whether the global initialization function is called in main. This
    60:           should always be false if there is no global initializer. When
    61:           you create a global initialization CIL will try to insert code in
    62:           main to call it. *)
    63:     }
    64: (** Top-level representation of a C source file *)
    65: 
    66: (** {b Globals}. The main type for representing global declarations and
    67:  * definitions. A list of these form a CIL file. The order of globals in the
    68:  * file is generally important. *)
    69: 
    70: (** A global declaration or definition *)
    71: and global =
    72:   | GType of typeinfo * location
    73:     (** A typedef. All uses of type names (through the [TNamed] constructor)
    74:         must be preceded in the file by a definition of the name. The string
    75:         is the defined name and always not-empty. *)
    76: 
    77:   | GCompTag of compinfo * location
    78:     (** Defines a struct/union tag with some fields. There must be one of
    79:         these for each struct/union tag that you use (through the [TComp]
    80:         constructor) since this is the only context in which the fields are
    81:         printed. Consequently nested structure tag definitions must be
    82:         broken into individual definitions with the innermost structure
    83:         defined first. *)
    84: 
    85:   | GCompTagDecl of compinfo * location
    86:     (** Declares a struct/union tag. Use as a forward declaration. This is
    87:       * printed without the fields.  *)
    88: 
    89:   | GEnumTag of enuminfo * location
    90:    (** Declares an enumeration tag with some fields. There must be one of
    91:       these for each enumeration tag that you use (through the [TEnum]
    92:       constructor) since this is the only context in which the items are
    93:       printed. *)
    94: 
    95:   | GEnumTagDecl of enuminfo * location
    96:     (** Declares an enumeration tag. Use as a forward declaration. This is
    97:       * printed without the items.  *)
    98: 
    99:   | GVarDecl of varinfo * location
   100:    (** A variable declaration (not a definition). If the variable has a
   101:        function type then this is a prototype. There can be several
   102:        declarations and at most one definition for a given variable. If both
   103:        forms appear then they must share the same varinfo structure. A
   104:        prototype shares the varinfo with the fundec of the definition. Either
   105:        has storage Extern or there must be a definition in this file *)
   106: 
   107:   | GVar  of varinfo * initinfo * location
   108:      (** A variable definition. Can have an initializer. The initializer is
   109:       * updateable so that you can change it without requiring to recreate
   110:       * the list of globals. There can be at most one definition for a
   111:       * variable in an entire program. Cannot have storage Extern or function
   112:       * type. *)
   113: 
   114:   | GFun of fundec * location
   115:      (** A function definition. *)
   116: 
   117:   | GAsm of string * location           (** Global asm statement. These ones
   118:                                             can contain only a template *)
   119:   | GPragma of attribute * location     (** Pragmas at top level. Use the same
   120:                                             syntax as attributes *)
   121:   | GText of string                     (** Some text (printed verbatim) at
   122:                                             top level. E.g., this way you can
   123:                                             put comments in the output.  *)
   124: 
   125: (** {b Types}. A C type is represented in CIL using the type {!Flx_cil_cil.typ}.
   126:  * Among types we differentiate the integral types (with different kinds
   127:  * denoting the sign and precision), floating point types, enumeration types,
   128:  * array and pointer types, and function types. Every type is associated with
   129:  * a list of attributes, which are always kept in sorted order. Use
   130:  * {!Flx_cil_cil.addAttribute} and {!Flx_cil_cil.addAttributes} to construct list of
   131:  * attributes. If you want to inspect a type, you should use
   132:  * {!Flx_cil_cil.unrollType} or {!Flx_cil_cil.unrollTypeDeep} to see through the uses of
   133:  * named types. *)
   134: (** CIL is configured at build-time with the sizes and alignments of the
   135:  * underlying compiler (GCC or MSVC). CIL contains functions that can compute
   136:  * the size of a type (in bits) {!Flx_cil_cil.bitsSizeOf}, the alignment of a type
   137:  * (in bytes) {!Flx_cil_cil.alignOf_int}, and can convert an offset into a start and
   138:  * width (both in bits) using the function {!Flx_cil_cil.bitsOffset}. At the moment
   139:  * these functions do not take into account the [packed] attributes and
   140:  * pragmas. *)
   141: 
   142: and typ =
   143:     TVoid of attributes   (** Void type. Also predefined as {!Flx_cil_cil.voidType} *)
   144:   | TInt of ikind * attributes
   145:      (** An integer type. The kind specifies the sign and width. Several
   146:       * useful variants are predefined as {!Flx_cil_cil.intType}, {!Flx_cil_cil.uintType},
   147:       * {!Flx_cil_cil.longType}, {!Flx_cil_cil.charType}. *)
   148: 
   149: 
   150:   | TFloat of fkind * attributes
   151:      (** A floating-point type. The kind specifies the precision. You can
   152:       * also use the predefined constant {!Flx_cil_cil.doubleType}. *)
   153: 
   154:   | TPtr of typ * attributes
   155:            (** Pointer type. Several useful variants are predefined as
   156:             * {!Flx_cil_cil.charPtrType}, {!Flx_cil_cil.charConstPtrType} (pointer to a
   157:             * constant character), {!Flx_cil_cil.voidPtrType},
   158:             * {!Flx_cil_cil.intPtrType}  *)
   159: 
   160:   | TArray of typ * exp option * attributes
   161:            (** Array type. It indicates the base type and the array length. *)
   162: 
   163:   | TFun of typ * (string * typ * attributes) list option * bool * attributes
   164:           (** Function type. Indicates the type of the result, the name, type
   165:            * and name attributes of the formal arguments ([None] if no
   166:            * arguments were specified, as in a function whose definition or
   167:            * prototype we have not seen; [Some \[\]] means void). Use
   168:            * {!Flx_cil_cil.argsToList} to obtain a list of arguments. The boolean
   169:            * indicates if it is a variable-argument function. If this is the
   170:            * type of a varinfo for which we have a function declaration then
   171:            * the information for the formals must match that in the
   172:            * function's sformals. Use {!Flx_cil_cil.setFormals} or
   173:            * {!Flx_cil_cil.setFunctionType} for this purpose. *)
   174: 
   175:   | TNamed of typeinfo * attributes
   176:           (* The use of a named type. Each such type name must be preceded
   177:            * in the file by a [GType] global. This is printed as just the
   178:            * type name. The actual referred type is not printed here and is
   179:            * carried only to simplify processing. To see through a sequence
   180:            * of named type references, use {!Flx_cil_cil.unrollType} or
   181:            * {!Flx_cil_cil.unrollTypeDeep}. The attributes are in addition to those
   182:            * given when the type name was defined. *)
   183: 
   184:   | TComp of compinfo * attributes
   185: (** The most delicate issue for C types is that recursion that is possible by
   186:  * using structures and pointers. To address this issue we have a more
   187:  * complex representation for structured types (struct and union). Each such
   188:  * type is represented using the {!Flx_cil_cil.compinfo} type. For each composite
   189:  * type the {!Flx_cil_cil.compinfo} structure must be declared at top level using
   190:  * [GCompTag] and all references to it must share the same copy of the
   191:  * structure. The attributes given are those pertaining to this use of the
   192:  * type and are in addition to the attributes that were given at the
   193:  * definition of the type and which are stored in the {!Flx_cil_cil.compinfo}. *)
   194: 
   195:   | TEnum of enuminfo * attributes
   196:            (** A reference to an enumeration type. All such references must
   197:                share the enuminfo among them and with a [GEnumTag] global that
   198:                precedes all uses. The attributes refer to this use of the
   199:                enumeration and are in addition to the attributes of the
   200:                enumeration itself, which are stored inside the enuminfo  *)
   201: 
   202: 
   203:   | TBuiltin_va_list of attributes
   204:             (** This is the same as the gcc's type with the same name *)
   205: 
   206: (**
   207:  There are a number of functions for querying the kind of a type. These are
   208:  {!Flx_cil_cil.isIntegralType},
   209:  {!Flx_cil_cil.isArithmeticType},
   210:  {!Flx_cil_cil.isPointerType},
   211:  {!Flx_cil_cil.isFunctionType},
   212:  {!Flx_cil_cil.isArrayType}.
   213: 
   214:  There are two easy ways to scan a type. First, you can use the
   215: {!Flx_cil_cil.existsType} to return a boolean answer about a type. This function
   216: is controlled by a user-provided function that is queried for each type that is
   217: used to construct the current type. The function can specify whether to
   218: terminate the scan with a boolean result or to continue the scan for the
   219: nested types.
   220: 
   221:  The other method for scanning types is provided by the visitor interface (see
   222:  {!Flx_cil_cil.cilVisitor}).
   223: 
   224:  If you want to compare types (or to use them as hash-values) then you should
   225: use instead type signatures (represented as {!Flx_cil_cil.typsig}). These
   226: contain the same information as types but canonicalized such that simple Ocaml
   227: structural equality will tell whether two types are equal. Use
   228: {!Flx_cil_cil.typeSig} to compute the signature of a type. If you want to ignore
   229: certain type attributes then use {!Flx_cil_cil.typeSigWithAttrs}.
   230: 
   231: *)
   232: 
   233: 
   234: (** Various kinds of integers *)
   235: and ikind =
   236:     IBool       (** [_Bool] *)
   237:   | IChar       (** [char] *)
   238:   | ISChar      (** [signed char] *)
   239:   | IUChar      (** [unsigned char] *)
   240:   | IInt        (** [int] *)
   241:   | IUInt       (** [unsigned int] *)
   242:   | IShort      (** [short] *)
   243:   | IUShort     (** [unsigned short] *)
   244:   | ILong       (** [long] *)
   245:   | IULong      (** [unsigned long] *)
   246:   | ILongLong   (** [long long] (or [_int64] on Microsoft Visual C) *)
   247:   | IULongLong  (** [unsigned long long] (or [unsigned _int64] on Microsoft
   248:                     Visual C) *)
   249: 
   250: (** Various kinds of floating-point numbers*)
   251: and fkind =
   252:   | FFloat      (** [float] *)
   253:   | FDouble     (** [double] *)
   254:   | FLongDouble (** [long double] *)
   255: 
   256:   | CFloat      (** [float _Complex] *)
   257:   | CDouble     (** [double _Complex] *)
   258:   | CLongDouble (** [long double _Complex] *)
   259: 
   260:   | IFloat      (** [float _Imaginary] *)
   261:   | IDouble     (** [double _Imaginary] *)
   262:   | ILongDouble (** [long double _Imaginary] *)
   263: 
   264: 
   265: (** {b Attributes.} *)
   266: 
   267: and attribute = Attr of string * attrparam list
   268: (** An attribute has a name and some optional parameters. The name should not
   269:  * start or end with underscore. When CIL parses attribute names it will
   270:  * strip leading and ending underscores (to ensure that the multitude of GCC
   271:  * attributes such as const, __const and __const__ all mean the same thing.) *)
   272: 
   273: (** Attributes are lists sorted by the attribute name. Use the functions
   274:  * {!Flx_cil_cil.addAttribute} and {!Flx_cil_cil.addAttributes} to insert attributes in an
   275:  * attribute list and maintain the sortedness. *)
   276: and attributes = attribute list
   277: 
   278: (** The type of parameters of attributes *)
   279: and attrparam =
   280:   | AInt of int                          (** An integer constant *)
   281:   | AStr of string                       (** A string constant *)
   282:   | ACons of string * attrparam list       (** Constructed attributes. These
   283:                                              are printed [foo(a1,a2,...,an)].
   284:                                              The list of parameters can be
   285:                                              empty and in that case the
   286:                                              parentheses are not printed. *)
   287:   | ASizeOf of typ                       (** A way to talk about types *)
   288:   | ASizeOfE of attrparam
   289:   | AAlignOf of typ
   290:   | AAlignOfE of attrparam
   291:   | AUnOp of unop * attrparam
   292:   | ABinOp of binop * attrparam * attrparam
   293:   | ADot of attrparam * string           (** a.foo **)
   294: 
   295: (** {b Structures.} The {!Flx_cil_cil.compinfo} describes the definition of a
   296:  * structure or union type. Each such {!Flx_cil_cil.compinfo} must be defined at the
   297:  * top-level using the [GCompTag] constructor and must be shared by all
   298:  * references to this type (using either the [TComp] type constructor or from
   299:  * the definition of the fields.
   300: 
   301:    If all you need is to scan the definition of each
   302:  * composite type once, you can do that by scanning all top-level [GCompTag].
   303: 
   304:  * Constructing a {!Flx_cil_cil.compinfo} can be tricky since it must contain fields
   305:  * that might refer to the host {!Flx_cil_cil.compinfo} and furthermore the type of
   306:  * the field might need to refer to the {!Flx_cil_cil.compinfo} for recursive types.
   307:  * Use the {!Flx_cil_cil.mkCompInfo} function to create a {!Flx_cil_cil.compinfo}. You can
   308:  * easily fetch the {!Flx_cil_cil.fieldinfo} for a given field in a structure with
   309:  * {!Flx_cil_cil.getCompField}. *)
   310: 
   311: (** The definition of a structure or union type. Use {!Flx_cil_cil.mkCompInfo} to
   312:  * make one and use {!Flx_cil_cil.copyCompInfo} to copy one (this ensures that a new
   313:  * key is assigned and that the fields have the right pointers to parents.). *)
   314: and compinfo = {
   315:     mutable cstruct: bool;
   316:    (** True if struct, False if union *)
   317:     mutable cname: string;
   318:    (** The name. Always non-empty. Use {!Flx_cil_cil.compFullName} to get the full
   319:     * name of a comp (along with the struct or union) *)
   320:     mutable ckey: int;
   321:     (** A unique integer. This is assigned by {!Flx_cil_cil.mkCompInfo} using a
   322:      * global variable in the Flx_cil_cil module. Thus two identical structs in two
   323:      * different files might have different keys. Use {!Flx_cil_cil.copyCompInfo} to
   324:      * copy structures so that a new key is assigned. *)
   325:     mutable cfields: fieldinfo list;
   326:     (** Information about the fields. Notice that each fieldinfo has a
   327:       * pointer back to the host compinfo. This means that you should not
   328:       * share fieldinfo's between two compinfo's *)
   329:     mutable cattr:   attributes;
   330:     (** The attributes that are defined at the same time as the composite
   331:      * type. These attributes can be supplemented individually at each
   332:      * reference to this [compinfo] using the [TComp] type constructor. *)
   333:     mutable cdefined: bool;
   334:     (** This boolean flag can be used to distinguish between structures
   335:      that have not been defined and those that have been defined but have
   336:      no fields (such things are allowed in gcc). *)
   337:     mutable creferenced: bool;
   338:     (** True if used. Initially set to false. *)
   339:   }
   340: 
   341: (** {b Structure fields.} The {!Flx_cil_cil.fieldinfo} structure is used to describe
   342:  * a structure or union field. Fields, just like variables, can have
   343:  * attributes associated with the field itself or associated with the type of
   344:  * the field (stored along with the type of the field). *)
   345: 
   346: (** Information about a struct/union field *)
   347: and fieldinfo = {
   348:     mutable fcomp: compinfo;
   349:      (** The host structure that contains this field. There can be only one
   350:       * [compinfo] that contains the field. *)
   351:     mutable fname: string;
   352:     (** The name of the field. Might be the value of {!Flx_cil_cil.missingFieldName}
   353:      * in which case it must be a bitfield and is not printed and it does not
   354:      * participate in initialization *)
   355:     mutable ftype: typ;
   356:     (** The type *)
   357:     mutable fbitfield: int option;
   358:     (** If a bitfield then ftype should be an integer type and the width of
   359:      * the bitfield must be 0 or a positive integer smaller or equal to the
   360:      * width of the integer type. A field of width 0 is used in C to control
   361:      * the alignment of fields. *)
   362:     mutable fattr: attributes;
   363:     (** The attributes for this field (not for its type) *)
   364:     mutable floc: location;
   365:     (** The location where this field is defined *)
   366:     mutable fstorage: storage;
   367:     (** Must be NoStorage or Static,
   368:       * indicates nonstatic or static member *)
   369: }
   370: 
   371: 
   372: 
   373: (** {b Enumerations.} Information about an enumeration. This is shared by all
   374:  * references to an enumeration. Make sure you have a [GEnumTag] for each of
   375:  * of these. *)
   376: 
   377: (** Information about an enumeration *)
   378: and enuminfo = {
   379:     mutable ename: string;
   380:     (** The name. Always non-empty. *)
   381:     mutable eitems: (string * exp * location) list;
   382:     (** Items with names and values. This list should be non-empty. The item
   383:      * values must be compile-time constants. *)
   384:     mutable eattr: attributes;
   385:     (** The attributes that are defined at the same time as the enumeration
   386:      * type. These attributes can be supplemented individually at each
   387:      * reference to this [enuminfo] using the [TEnum] type constructor. *)
   388:     mutable ereferenced: bool;
   389:     (** True if used. Initially set to false*)
   390: }
   391: 
   392: (** {b Enumerations.} Information about an enumeration. This is shared by all
   393:  * references to an enumeration. Make sure you have a [GEnumTag] for each of
   394:  * of these. *)
   395: 
   396: (** Information about a defined type *)
   397: and typeinfo = {
   398:     mutable tname: string;
   399:     (** The name. Can be empty only in a [GType] when introducing a composite
   400:      * or enumeration tag. If empty cannot be referred to from the file *)
   401:     mutable ttype: typ;
   402:     (** The actual type. This includes the attributes that were present in
   403:      * the typedef *)
   404:     mutable treferenced: bool;
   405:     (** True if used. Initially set to false*)
   406: }
   407: 
   408: (** {b Variables.}
   409:  Each local or global variable is represented by a unique {!Flx_cil_cil.varinfo}
   410: structure. A global {!Flx_cil_cil.varinfo} can be introduced with the [GVarDecl] or
   411: [GVar] or [GFun] globals. A local varinfo can be introduced as part of a
   412: function definition {!Flx_cil_cil.fundec}.
   413: 
   414:  All references to a given global or local variable must refer to the same
   415: copy of the [varinfo]. Each [varinfo] has a globally unique identifier that
   416: can be used to index maps and hashtables (the name can also be used for this
   417: purpose, except for locals from different functions). This identifier is
   418: constructor using a global counter.
   419: 
   420:  It is very important that you construct [varinfo] structures using only one
   421:  of the following functions:
   422: - {!Flx_cil_cil.makeGlobalVar} : to make a global variable
   423: - {!Flx_cil_cil.makeTempVar} : to make a temporary local variable whose name
   424: will be generated so that to avoid conflict with other locals.
   425: - {!Flx_cil_cil.makeLocalVar} : like {!Flx_cil_cil.makeTempVar} but you can specify the
   426: exact name to be used.
   427: - {!Flx_cil_cil.copyVarinfo}: make a shallow copy of a varinfo assigning a new name
   428: and a new unique identifier
   429: 
   430:  A [varinfo] is also used in a function type to denote the list of formals.
   431: 
   432: *)
   433: 
   434: (** Information about a variable. *)
   435: and varinfo = {
   436:     mutable vname: string;
   437:     (** The name of the variable. Cannot be empty. It is primarily your
   438:      * responsibility to ensure the uniqueness of a variable name. For local
   439:      * variables {!Flx_cil_cil.makeTempVar} helps you ensure that the name is unique.
   440:      *)
   441: 
   442:     mutable vtype: typ;
   443:     (** The declared type of the variable. *)
   444: 
   445:     mutable vattr: attributes;
   446:     (** A list of attributes associated with the variable.*)
   447:     mutable vstorage: storage;
   448:     (** The storage-class *)
   449: 
   450:     mutable vglob: bool;
   451:     (** True if this is a global variable*)
   452: 
   453:     mutable vinline: bool;
   454:     (** Whether this varinfo is for an inline function. *)
   455: 
   456:     mutable vdecl: location;
   457:     (** Location of variable declaration. *)
   458: 
   459:     mutable vid: int;
   460:     (** A unique integer identifier. This field will be
   461:      * set for you if you use one of the {!Flx_cil_cil.makeFormalVar},
   462:      * {!Flx_cil_cil.makeLocalVar}, {!Flx_cil_cil.makeTempVar}, {!Flx_cil_cil.makeGlobalVar}, or
   463:      * {!Flx_cil_cil.copyVarinfo}. *)
   464: 
   465:     mutable vaddrof: bool;
   466:     (** True if the address of this variable is taken. CIL will set these
   467:      * flags when it parses C, but you should make sure to set the flag
   468:      * whenever your transformation create [AddrOf] expression. *)
   469: 
   470:     mutable vreferenced: bool;
   471:     (** True if this variable is ever referenced. This is computed by
   472:      * [removeUnusedVars]. It is safe to just initialize this to False *)
   473: }
   474: 
   475: (** Storage-class information *)
   476: and storage =
   477:     | NoStorage                          (** The default storage. Nothing is
   478:                                          * printed  *)
   479:     | Static
   480:     | Register
   481:     | Extern
   482: 
   483: 
   484: (** {b Expressions.} The CIL expression language contains only the side-effect free expressions of
   485: C. They are represented as the type {!Flx_cil_cil.exp}. There are several
   486: interesting aspects of CIL expressions:
   487: 
   488:  Integer and floating point constants can carry their textual representation.
   489: This way the integer 15 can be printed as 0xF if that is how it occurred in the
   490: source.
   491: 
   492:  CIL uses 64 bits to represent the integer constants and also stores the width
   493: of the integer type. Care must be taken to ensure that the constant is
   494: representable with the given width. Use the functions {!Flx_cil_cil.kinteger},
   495: {!Flx_cil_cil.kinteger64} and {!Flx_cil_cil.integer} to construct constant
   496: expressions. CIL predefines the constants {!Flx_cil_cil.zero},
   497: {!Flx_cil_cil.one} and {!Flx_cil_cil.mone} (for -1).
   498: 
   499:  Use the functions {!Flx_cil_cil.isConstant} and {!Flx_cil_cil.isInteger} to test if
   500: an expression is a constant and a constant integer respectively.
   501: 
   502:  CIL keeps the type of all unary and binary expressions. You can think of that
   503: type qualifying the operator. Furthermore there are different operators for
   504: arithmetic and comparisons on arithmetic types and on pointers.
   505: 
   506:  Another unusual aspect of CIL is that the implicit conversion between an
   507: expression of array type and one of pointer type is made explicit, using the
   508: [StartOf] expression constructor (which is not printed). If you apply the
   509: [AddrOf}]constructor to an lvalue of type [T] then you will be getting an
   510: expression of type [TPtr(T)].
   511: 
   512:  You can find the type of an expression with {!Flx_cil_cil.typeOf}.
   513: 
   514:  You can perform constant folding on expressions using the function
   515: {!Flx_cil_cil.constFold}.
   516: *)
   517: 
   518: (** Expressions (Side-effect free)*)
   519: and exp =
   520:     Const      of constant              (** Constant *)
   521:   | Lval       of lval                  (** Lvalue *)
   522:   | SizeOf     of typ
   523:     (** sizeof(<type>). Has [unsigned int] type (ISO 6.5.3.4). This is not
   524:      * turned into a constant because some transformations might want to
   525:      * change types *)
   526: 
   527:   | SizeOfE    of exp
   528:     (** sizeof(<expression>) *)
   529: 
   530:   | SizeOfStr  of string
   531:     (** sizeof(string_literal). We separate this case out because this is the
   532:       * only instance in which a string literal should not be treated as
   533:       * having type pointer to character. *)
   534: 
   535:   | AlignOf    of typ
   536:     (** This corresponds to the GCC __alignof_. Has [unsigned int] type *)
   537:   | AlignOfE   of exp
   538: 
   539: 
   540:   | UnOp       of unop * exp * typ
   541:     (** Unary operation. Includes the type of the result. *)
   542: 
   543:   | BinOp      of binop * exp * exp * typ
   544:     (** Binary operation. Includes the type of the result. The arithmetic
   545:      * conversions are made explicit for the arguments. *)
   546: 
   547:   | CastE      of typ * exp
   548:     (** Use {!Flx_cil_cil.mkCast} to make casts.  *)
   549: 
   550:   | AddrOf     of lval
   551:     (** Always use {!Flx_cil_cil.mkAddrOf} to construct one of these. Apply to an
   552:      * lvalue of type [T] yields an expression of type [TPtr(T)] *)
   553: 
   554:   | StartOf    of lval
   555:     (** Conversion from an array to a pointer to the beginning of the array.
   556:      * Given an lval of type [TArray(T)] produces an expression of type
   557:      * [TPtr(T)]. In C this operation is implicit, the [StartOf] operator is
   558:      * not printed. We have it in CIL because it makes the typing rules
   559:      * simpler. *)
   560: 
   561: (** {b Constants.} *)
   562: 
   563: (** Literal constants *)
   564: and constant =
   565:   | CInt64 of int64 * ikind * string option
   566:     (** Integer constant. Give the ikind (see ISO9899 6.1.3.2) and the
   567:      * textual representation, if available. (This allows us to print a
   568:      * constant as, for example, 0xF instead of 15.) Use {!Flx_cil_cil.integer} or
   569:      * {!Flx_cil_cil.kinteger} to create these. Watch out for integers that cannot be
   570:      * represented on 64 bits. OCAML does not give Overflow exceptions. *)
   571:   | CStr of string
   572:     (* String constant. The escape characters inside the string have been
   573:      * already interpreted. This constant has pointer to character type! The
   574:      * only case when you would like a string literal to have an array type
   575:      * is when it is an argument to sizeof. In that case you should use
   576:      * SizeOfStr. *)
   577:   | CWStr of int64 list
   578:     (* Wide character string constant. Note that the local interpretation
   579:      * of such a literal depends on {!Flx_cil_cil.wcharType} and {!Flx_cil_cil.wcharKind}.
   580:      * Such a constant has type pointer to {!Flx_cil_cil.wcharType}. The
   581:      * escape characters in the string have not been "interpreted" in
   582:      * the sense that L"A\xabcd" remains "A\xabcd" rather than being
   583:      * represented as the wide character list with two elements: 65 and
   584:      * 43981. That "interpretation" depends on the underlying wide
   585:      * character type. *)
   586:   | CChr of char
   587:     (** Character constant *)
   588:   | CReal of float * fkind * string option
   589:      (** Floating point constant. Give the fkind (see ISO 6.4.4.2) and also
   590:       * the textual representation, if available. *)
   591: 
   592: (** Unary operators *)
   593: and unop =
   594:     Neg                                 (** Unary minus *)
   595:   | BNot                                (** Bitwise complement (~) *)
   596:   | LNot                                (** Logical Not (!) *)
   597: 
   598: (** Binary operations *)
   599: and binop =
   600:     PlusA                               (** arithmetic + *)
   601:   | PlusPI                              (** pointer + integer *)
   602:   | IndexPI                             (** pointer + integer but only when
   603:                                          * it arises from an expression
   604:                                          * [e\[i\]] when [e] is a pointer and
   605:                                          * not an array. This is semantically
   606:                                          * the same as PlusPI but CCured uses
   607:                                          * this as a hint that the integer is
   608:                                          * probably positive. *)
   609:   | MinusA                              (** arithmetic - *)
   610:   | MinusPI                             (** pointer - integer *)
   611:   | MinusPP                             (** pointer - pointer *)
   612:   | Mult                                (** * *)
   613:   | Div                                 (** / *)
   614:   | Mod                                 (** % *)
   615:   | Shiftlt                             (** shift left *)
   616:   | Shiftrt                             (** shift right *)
   617: 
   618:   | Lt                                  (** <  (arithmetic comparison) *)
   619:   | Gt                                  (** >  (arithmetic comparison) *)
   620:   | Le                                  (** <= (arithmetic comparison) *)
   621:   | Ge                                  (** >  (arithmetic comparison) *)
   622:   | Eq                                  (** == (arithmetic comparison) *)
   623:   | Ne                                  (** != (arithmetic comparison) *)
   624:   | BAnd                                (** bitwise and *)
   625:   | BXor                                (** exclusive-or *)
   626:   | BOr                                 (** inclusive-or *)
   627: 
   628:   | LAnd                                (** logical and. Unlike other
   629:                                          * expressions this one does not
   630:                                          * always evaluate both operands. If
   631:                                          * you want to use these, you must
   632:                                          * set {!Flx_cil_cil.useLogicalOperators}. *)
   633:   | LOr                                 (** logical or. Unlike other
   634:                                          * expressions this one does not
   635:                                          * always evaluate both operands.  If
   636:                                          * you want to use these, you must
   637:                                          * set {!Flx_cil_cil.useLogicalOperators}. *)
   638: 
   639: (** {b Lvalues.} Lvalues are the sublanguage of expressions that can appear at the left of an assignment or as operand to the address-of operator.
   640: In C the syntax for lvalues is not always a good indication of the meaning
   641: of the lvalue. For example the C value
   642: {v
   643: a[0][1][2]
   644:  v}
   645:  might involve 1, 2 or 3 memory reads when used in an expression context,
   646: depending on the declared type of the variable [a]. If [a] has type [int
   647: \[4\]\[4\]\[4\]] then we have one memory read from somewhere inside the area
   648: that stores the array [a]. On the other hand if [a] has type [int ***] then
   649: the expression really means [* ( * ( * (a + 0) + 1) + 2)], in which case it is
   650: clear that it involves three separate memory operations.
   651: 
   652: An lvalue denotes the contents of a range of memory addresses. This range
   653: is denoted as a host object along with an offset within the object. The
   654: host object can be of two kinds: a local or global variable, or an object
   655: whose address is in a pointer expression. We distinguish the two cases so
   656: that we can tell quickly whether we are accessing some component of a
   657: variable directly or we are accessing a memory location through a pointer.
   658: To make it easy to
   659: tell what an lvalue means CIL represents lvalues as a host object and an
   660: offset (see {!Flx_cil_cil.lval}). The host object (represented as
   661: {!Flx_cil_cil.lhost}) can be a local or global variable or can be the object
   662: pointed-to by a pointer expression. The offset (represented as
   663: {!Flx_cil_cil.offset}) is a sequence of field or array index designators.
   664: 
   665:  Both the typing rules and the meaning of an lvalue is very precisely
   666: specified in CIL.
   667: 
   668:  The following are a few useful function for operating on lvalues:
   669: - {!Flx_cil_cil.mkMem} - makes an lvalue of [Mem] kind. Use this to ensure
   670: that certain equivalent forms of lvalues are canonized.
   671: For example, [*&x = x].
   672: - {!Flx_cil_cil.typeOfLval} - the type of an lvalue
   673: - {!Flx_cil_cil.typeOffset} - the type of an offset, given the type of the
   674: host.
   675: - {!Flx_cil_cil.addOffset} and {!Flx_cil_cil.addOffsetLval} - extend sequences
   676: of offsets.
   677: - {!Flx_cil_cil.removeOffset} and {!Flx_cil_cil.removeOffsetLval} - shrink sequences
   678: of offsets.
   679: 
   680: The following equivalences hold {v
   681: Mem(AddrOf(Mem a, aoff)), off   = Mem a, aoff + off
   682: Mem(AddrOf(Var v, aoff)), off   = Var v, aoff + off
   683: AddrOf (Mem a, NoOffset)        = a
   684:  v}
   685: 
   686: *)
   687: (** An lvalue *)
   688: and lval =
   689:     lhost * offset
   690: 
   691: (** The host part of an {!Flx_cil_cil.lval}. *)
   692: and lhost =
   693:   | Var        of varinfo
   694:     (** The host is a variable. *)
   695: 
   696:   | Mem        of exp
   697:     (** The host is an object of type [T] when the expression has pointer
   698:      * [TPtr(T)]. *)
   699: 
   700: 
   701: (** The offset part of an {!Flx_cil_cil.lval}. Each offset can be applied to certain
   702:   * kinds of lvalues and its effect is that it advances the starting address
   703:   * of the lvalue and changes the denoted type, essentially focusing to some
   704:   * smaller lvalue that is contained in the original one. *)
   705: and offset =
   706:   | NoOffset          (** No offset. Can be applied to any lvalue and does
   707:                         * not change either the starting address or the type.
   708:                         * This is used when the lval consists of just a host
   709:                         * or as a terminator in a list of other kinds of
   710:                         * offsets. *)
   711: 
   712:   | Field      of fieldinfo * offset
   713:                       (** A field offset. Can be applied only to an lvalue
   714:                        * that denotes a structure or a union that contains
   715:                        * the mentioned field. This advances the offset to the
   716:                        * beginning of the mentioned field and changes the
   717:                        * type to the type of the mentioned field. *)
   718: 
   719:   | Index    of exp * offset
   720:                      (** An array index offset. Can be applied only to an
   721:                        * lvalue that denotes an array. This advances the
   722:                        * starting address of the lval to the beginning of the
   723:                        * mentioned array element and changes the denoted type
   724:                        * to be the type of the array element *)
   725: 
   726: 
   727: (** {b Initializers.}
   728: A special kind of expressions are those that can appear as initializers for
   729: global variables (initialization of local variables is turned into
   730: assignments). The initializers are represented as type {!Flx_cil_cil.init}. You
   731: can create initializers with {!Flx_cil_cil.makeZeroInit} and you can conveniently
   732: scan compound initializers them with {!Flx_cil_cil.foldLeftCompound} or with {!Flx_cil_cil.foldLeftCompoundAll}.
   733: *)
   734: (** Initializers for global variables. *)
   735: and init =
   736:   | SingleInit   of exp   (** A single initializer *)
   737:   | CompoundInit   of typ * (offset * init) list
   738:     (** Used only for initializers of structures, unions and arrays. The
   739:      * offsets are all of the form [Field(f, NoOffset)] or [Index(i,
   740:      * NoOffset)] and specify the field or the index being initialized. For
   741:      * structures all fields must have an initializer (except the unnamed
   742:      * bitfields), in the proper order. This is necessary since the offsets
   743:      * are not printed. For unions there must be exactly one initializer. If
   744:      * the initializer is not for the first field then a field designator is
   745:      * printed, so you better be on GCC since MSVC does not understand this.
   746:      * For arrays, however, we allow you to give only a prefix of the
   747:      * initializers. You can scan an initializer list with
   748:      * {!Flx_cil_cil.foldLeftCompound} or with {!Flx_cil_cil.foldLeftCompoundAll}. *)
   749: 
   750: 
   751: (** We want to be able to update an initializer in a global variable, so we
   752:  * define it as a mutable field *)
   753: and initinfo = {
   754:     mutable init : init option;
   755:   }
   756: 
   757: (** {b Function definitions.}
   758: A function definition is always introduced with a [GFun] constructor at the
   759: top level. All the information about the function is stored into a
   760: {!Flx_cil_cil.fundec}. Some of the information (e.g. its name, type,
   761: storage, attributes) is stored as a {!Flx_cil_cil.varinfo} that is a field of the
   762: [fundec]. To refer to the function from the expression language you must use
   763: the [varinfo].
   764: 
   765:  The function definition contains, in addition to the body, a list of all the
   766: local variables and separately a list of the formals. Both kind of variables
   767: can be referred to in the body of the function. The formals must also be shared
   768: with the formals that appear in the function type. For that reason, to
   769: manipulate formals you should use the provided functions
   770: {!Flx_cil_cil.makeFormalVar} and {!Flx_cil_cil.setFormals}.
   771: *)
   772: (** Function definitions. *)
   773: and fundec =
   774:     { mutable svar:     varinfo;
   775:          (** Holds the name and type as a variable, so we can refer to it
   776:           * easily from the program. All references to this function either
   777:           * in a function call or in a prototype must point to the same
   778:           * [varinfo]. *)
   779:       mutable sformals: varinfo list;
   780:         (** Formals. These must be in the same order and with the same
   781:          * information as the formal information in the type of the function.
   782:          * Use {!Flx_cil_cil.setFormals} or
   783:          * {!Flx_cil_cil.setFunctionType} to set these formals and ensure that they
   784:          * are reflected in the function type. Do not make copies of these
   785:          * because the body refers to them. *)
   786:       mutable slocals: varinfo list;
   787:         (** Locals. Does NOT include the sformals. Do not make copies of
   788:          * these because the body refers to them. *)
   789:       mutable smaxid: int;           (** Max local id. Starts at 0. Used for
   790:                                       * creating the names of new temporary
   791:                                       * variables. Updated by
   792:                                       * {!Flx_cil_cil.makeLocalVar} and
   793:                                       * {!Flx_cil_cil.makeTempVar}. You can also use
   794:                                       * {!Flx_cil_cil.setMaxId} to set it after you
   795:                                       * have added the formals and locals. *)
   796:       mutable sbody: block;          (** The function body. *)
   797:       mutable smaxstmtid: int option;  (** max id of a (reachable) statement
   798:                                         * in this function, if we have
   799:                                         * computed it. range = 0 ...
   800:                                         * (smaxstmtid-1) *)
   801:     }
   802: 
   803: 
   804: (** A block is a sequence of statements with the control falling through from
   805:     one element to the next *)
   806: and block =
   807:    { mutable battrs: attributes;      (** Attributes for the block *)
   808:      mutable bstmts: stmt list;       (** The statements comprising the block*)
   809:    }
   810: 
   811: 
   812: (** {b Statements}.
   813: CIL statements are the structural elements that make the CFG. They are
   814: represented using the type {!Flx_cil_cil.stmt}. Every
   815: statement has a (possibly empty) list of labels. The
   816: {!Flx_cil_cil.stmtkind} field of a statement indicates what kind of statement it
   817: is.
   818: 
   819:  Use {!Flx_cil_cil.mkStmt} to make a statement and the fill-in the fields.
   820: 
   821: CIL also comes with support for control-flow graphs. The [sid] field in
   822: [stmt] can be used to give unique numbers to statements, and the [succs]
   823: and [preds] fields can be used to maintain a list of successors and
   824: predecessors for every statement. The CFG information is not computed by
   825: default. Instead you must explicitly use the functions
   826: {!Flx_cil_cil.prepareCFG} and {!Flx_cil_cil.computeCFGInfo} to do it.
   827: 
   828: *)
   829: (** Statements. *)
   830: and stmt = {
   831:     mutable labels: label list;
   832:     (** Whether the statement starts with some labels, case statements or
   833:      * default statements. *)
   834: 
   835:     mutable skind: stmtkind;
   836:     (** The kind of statement *)
   837: 
   838:     mutable sid: int;
   839:     (** A number (>= 0) that is unique in a function. Filled in only after
   840:      * the CFG is computed. *)
   841:     mutable succs: stmt list;
   842:     (** The successor statements. They can always be computed from the skind
   843:      * and the context in which this statement appears. Filled in only after
   844:      * the CFG is computed. *)
   845:     mutable preds: stmt list;
   846:     (** The inverse of the succs function. *)
   847:   }
   848: 
   849: (** Labels *)
   850: and label =
   851:     Label of string * location * bool
   852:           (** A real label. If the bool is "true", the label is from the
   853:            * input source program. If the bool is "false", the label was
   854:            * created by CIL or some other transformation *)
   855:   | Case of exp * location              (** A case statement *)
   856:   | Default of location                 (** A default statement *)
   857: 
   858: 
   859: 
   860: (** The various kinds of control-flow statements statements *)
   861: and stmtkind =
   862:   | Instr  of instr list
   863:   (** A group of instructions that do not contain control flow. Control
   864:    * implicitly falls through. *)
   865: 
   866:   | Return of exp option * location
   867:    (** The return statement. This is a leaf in the CFG. *)
   868: 
   869:   | Goto of stmt ref * location
   870:    (** A goto statement. Appears from actual goto's in the code or from
   871:     * goto's that have been inserted during elaboration. The reference
   872:     * points to the statement that is the target of the Goto. This means that
   873:     * you have to update the reference whenever you replace the target
   874:     * statement. The target statement MUST have at least a label. *)
   875: 
   876:   | Break of location
   877:    (** A break to the end of the nearest enclosing Loop or Switch *)
   878: 
   879:   | Continue of location
   880:    (** A continue to the start of the nearest enclosing [Loop] *)
   881:   | If of exp * block * block * location
   882:    (** A conditional. Two successors, the "then" and the "else" branches.
   883:     * Both branches fall-through to the successor of the If statement. *)
   884: 
   885:   | Switch of exp * block * (stmt list) * location
   886:    (** A switch statement. The statements that implement the cases can be
   887:     * reached through the provided list. For each such target you can find
   888:     * among its labels what cases it implements. The statements that
   889:     * implement the cases are somewhere within the provided [block]. *)
   890: 
   891:   | Loop of block * location * (stmt option) * (stmt option)
   892:     (** A [while(1)] loop. The termination test is implemented in the body of
   893:      * a loop using a [Break] statement. If prepareCFG has been called,
   894:      * the first stmt option will point to the stmt containing the continue
   895:      * label for this loop and the second will point to the stmt containing
   896:      * the break label for this loop. *)
   897: 
   898:   | Block of block
   899:     (** Just a block of statements. Use it as a way to keep some block
   900:      * attributes local *)
   901: 
   902:     (** On MSVC we support structured exception handling. This is what you
   903:      * might expect. Control can get into the finally block either from the
   904:      * end of the body block, or if an exception is thrown. *)
   905:   | TryFinally of block * block * location
   906: 
   907:     (** On MSVC we support structured exception handling. The try/except
   908:      * statement is a bit tricky:
   909:          [__try { blk }
   910:          __except (e) {
   911:             handler
   912:          }]
   913: 
   914:          The argument to __except  must be an expression. However, we keep a
   915:          list of instructions AND an expression in case you need to make
   916:          function calls. We'll print those as a comma expression. The control
   917:          can get to the __except expression only if an exception is thrown.
   918:          After that, depending on the value of the expression the control
   919:          goes to the handler, propagates the exception, or retries the
   920:          exception !!!
   921:      *)
   922:   | TryExcept of block * (instr list * exp) * block * location
   923: 
   924: 
   925: (** {b Instructions}.
   926:  An instruction {!Flx_cil_cil.instr} is a statement that has no local
   927: (intraprocedural) control flow. It can be either an assignment,
   928: function call, or an inline assembly instruction. *)
   929: 
   930: (** Instructions. *)
   931: and instr =
   932:     Set        of lval * exp * location
   933:    (** An assignment. The type of the expression is guaranteed to be the same
   934:     * with that of the lvalue *)
   935:   | Call       of lval option * exp * exp list * location
   936:    (** A function call with the (optional) result placed in an lval. It is
   937:     * possible that the returned type of the function is not identical to
   938:     * that of the lvalue. In that case a cast is printed. The type of the
   939:     * actual arguments are identical to those of the declared formals. The
   940:     * number of arguments is the same as that of the declared formals, except
   941:     * for vararg functions. This construct is also used to encode a call to
   942:     * "__builtin_va_arg". In this case the second argument (which should be a
   943:     * type T) is encoded SizeOf(T) *)
   944: 
   945:   | Asm        of attributes * (* Really only const and volatile can appear
   946:                                * here *)
   947:                   string list *         (* templates (CR-separated) *)
   948:                   (string * lval) list * (* outputs must be lvals with
   949:                                           * constraints. I would like these
   950:                                           * to be actually variables, but I
   951:                                           * run into some trouble with ASMs
   952:                                           * in the Linux sources  *)
   953:                   (string * exp) list * (* inputs with constraints *)
   954:                   string list *         (* register clobbers *)
   955:                   location
   956:     (** There are for storing inline assembly. They follow the GCC
   957:       * specification:
   958: {v
   959:   asm [volatile] ("...template..." "..template.."
   960:                   : "c1" (o1), "c2" (o2), ..., "cN" (oN)
   961:                   : "d1" (i1), "d2" (i2), ..., "dM" (iM)
   962:                   : "r1", "r2", ..., "nL" );
   963:  v}
   964: 
   965: where the parts are
   966: 
   967:   - [volatile] (optional): when present, the assembler instruction
   968:     cannot be removed, moved, or otherwise optimized
   969:   - template: a sequence of strings, with %0, %1, %2, etc. in the string to
   970:     refer to the input and output expressions. I think they're numbered
   971:     consecutively, but the docs don't specify. Each string is printed on
   972:     a separate line. This is the only part that is present for MSVC inline
   973:     assembly.
   974:   - "ci" (oi): pairs of constraint-string and output-lval; the
   975:     constraint specifies that the register used must have some
   976:     property, like being a floating-point register; the constraint
   977:     string for outputs also has "=" to indicate it is written, or
   978:     "+" to indicate it is both read and written; 'oi' is the
   979:     name of a C lvalue (probably a variable name) to be used as
   980:     the output destination
   981:   - "dj" (ij): pairs of constraint and input expression; the constraint
   982:     is similar to the "ci"s.  the 'ij' is an arbitrary C expression
   983:     to be loaded into the corresponding register
   984:   - "rk": registers to be regarded as "clobbered" by the instruction;
   985:     "memory" may be specified for arbitrary memory effects
   986: 
   987: an example (from gcc manual):
   988: {v
   989:   asm volatile ("movc3 %0,%1,%2"
   990:                 : /* no outputs */
   991:                 : "g" (from), "g" (to), "g" (count)
   992:                 : "r0", "r1", "r2", "r3", "r4", "r5");
   993:  v}
   994: *)
   995: 
   996: (** Describes a location in a source file *)
   997: and location = {
   998:     line: int;             (** The line number. -1 means "do not know" *)
   999:     file: string;          (** The name of the source file*)
  1000:     byte: int;             (** The byte position in the source file *)
  1001: }
  1002: 
  1003: 
  1004: 
  1005: (** To be able to add/remove features easily, each feature should be package
  1006:    * as an interface with the following interface. These features should be *)
  1007: type featureDescr = {
  1008:     fd_enabled: bool ref;
  1009:     (** The enable flag. Set to default value  *)
  1010: 
  1011:     fd_name: string;
  1012:     (** This is used to construct an option "--doxxx" and "--dontxxx" that
  1013:      * enable and disable the feature  *)
  1014: 
  1015:     fd_description: string;
  1016:     (* A longer name that can be used to document the new options  *)
  1017: 
  1018:     fd_extraopt: (string * Arg.spec * string) list;
  1019:     (** Additional command line options *)
  1020: 
  1021:     fd_doit: (file -> unit);
  1022:     (** This performs the transformation *)
  1023: 
  1024:     fd_post_check: bool;
  1025:     (* Whether to perform a CIL consistency checking after this stage, if
  1026:      * checking is enabled (--check is passed to cilly). Set this to true if
  1027:      * your feature makes any changes for the program. *)
  1028: }
  1029: 
  1030: (** Comparison function for locations.
  1031:  ** Compares first by filename, then line, then byte *)
  1032: val compareLoc: location -> location -> int
  1033: 
  1034: (** {b Values for manipulating globals} *)
  1035: 
  1036: (** Make an empty function *)
  1037: val emptyFunction: string -> fundec
  1038: 
  1039: (** Update the formals of a [fundec] and make sure that the function type
  1040:     has the same information. Will copy the name as well into the type. *)
  1041: val setFormals: fundec -> varinfo list -> unit
  1042: 
  1043: (** Set the types of arguments and results as given by the function type
  1044:  * passed as the second argument. Will not copy the names from the function
  1045:  * type to the formals *)
  1046: val setFunctionType: fundec -> typ -> unit
  1047: 
  1048: (** Update the smaxid after you have populated with locals and formals
  1049:  * (unless you constructed those using {!Flx_cil_cil.makeLocalVar} or
  1050:  * {!Flx_cil_cil.makeTempVar}. *)
  1051: val setMaxId: fundec -> unit
  1052: 
  1053: (** A dummy function declaration handy when you need one as a placeholder. It
  1054:  * contains inside a dummy varinfo. *)
  1055: val dummyFunDec: fundec
  1056: 
  1057: (** A dummy file *)
  1058: val dummyFile: file
  1059: 
  1060: (** Write a {!Flx_cil_cil.file} in binary form to the filesystem. The file can be
  1061:  * read back in later using {!Flx_cil_cil.loadBinaryFile}, possibly saving parsing
  1062:  * time. The second argument is the name of the file that should be
  1063:  * created. *)
  1064: val saveBinaryFile : file -> string -> unit
  1065: 
  1066: (** Write a {!Flx_cil_cil.file} in binary form to the filesystem. The file can be
  1067:  * read back in later using {!Flx_cil_cil.loadBinaryFile}, possibly saving parsing
  1068:  * time. Does not close the channel. *)
  1069: val saveBinaryFileChannel : file -> out_channel -> unit
  1070: 
  1071: (** Read a {!Flx_cil_cil.file} in binary form from the filesystem. The first
  1072:  * argument is the name of a file previously created by
  1073:  * {!Flx_cil_cil.saveBinaryFile}. *)
  1074: val loadBinaryFile : string -> file
  1075: 
  1076: (** Get the global initializer and create one if it does not already exist.
  1077:  * When it creates a global initializer it attempts to place a call to it in
  1078:  * the main function named by the optional argument (default "main")  *)
  1079: val getGlobInit: ?main_name:string -> file -> fundec
  1080: 
  1081: (** Iterate over all globals, including the global initializer *)
  1082: val iterGlobals: file -> (global -> unit) -> unit
  1083: 
  1084: (** Fold over all globals, including the global initializer *)
  1085: val foldGlobals: file -> ('a -> global -> 'a) -> 'a -> 'a
  1086: 
  1087: (** Map over all globals, including the global initializer and change things
  1088:     in place *)
  1089: val mapGlobals: file -> (global -> global) -> unit
  1090: 
  1091: (** Prepare a function for CFG information computation by
  1092:   * {!Flx_cil_cil.computeCFGInfo}. This function converts all [Break], [Switch],
  1093:   * [Default] and [Continue] {!Flx_cil_cil.stmtkind}s and {!Flx_cil_cil.label}s into [If]s
  1094:   * and [Goto]s, giving the function body a very CFG-like character. This
  1095:   * function modifies its argument in place. *)
  1096: val prepareCFG: fundec -> unit
  1097: 
  1098: (** Compute the CFG information for all statements in a fundec and return a
  1099:   * list of the statements. The input fundec cannot have [Break], [Switch],
  1100:   * [Default], or [Continue] {!Flx_cil_cil.stmtkind}s or {!Flx_cil_cil.label}s. Use
  1101:   * {!Flx_cil_cil.prepareCFG} to transform them away.  The second argument should
  1102:   * be [true] if you wish a global statement number, [false] if you wish a
  1103:   * local (per-function) statement numbering. *)
  1104: val computeCFGInfo: fundec -> bool -> stmt list
  1105: 
  1106: 
  1107: (** Create a deep copy of a function. There should be no sharing between the
  1108:  * copy and the original function *)
  1109: val copyFunction: fundec -> string -> fundec
  1110: 
  1111: 
  1112: (** CIL keeps the types at the beginning of the file and the variables at the
  1113:  * end of the file. This function will take a global and add it to the
  1114:  * corresponding stack. Its operation is actually more complicated because if
  1115:  * the global declares a type that contains references to variables (e.g. in
  1116:  * sizeof in an array length) then it will also add declarations for the
  1117:  * variables to the types stack *)
  1118: val pushGlobal: global -> types: global list ref
  1119:                        -> variables: global list ref -> unit
  1120: 
  1121: (** A list of the GCC built-in functions. Maps the name to the result and
  1122:   * argument types, and whether it is vararg *)
  1123: val gccBuiltins: (string, typ * typ list * bool) Hashtbl.t
  1124: 
  1125: 
  1126: (** A list of the MSVC built-in functions. Maps the name to the result and
  1127:  * argument types, and whether it is vararg *)
  1128: val msvcBuiltins: (string, typ * typ list * bool) Hashtbl.t
  1129: 
  1130: (** {b Values for manipulating initializers} *)
  1131: 
  1132: 
  1133: (** Make a initializer for zero-ing a data type *)
  1134: val makeZeroInit: typ -> init
  1135: 
  1136: 
  1137: (** Fold over the list of initializers in a Compound. [doinit] is called on
  1138:  * every present initializer, even if it is of compound type. In the case of
  1139:  * arrays there might be missing zero-initializers at the end of the list.
  1140:  * These are not scanned. This is much like [List.fold_left] except we also
  1141:  * pass the type of the initializer *)
  1142: val foldLeftCompound:
  1143:     doinit: (offset -> init -> typ -> 'a -> 'a) ->
  1144:     ct: typ ->
  1145:     initl: (offset * init) list ->
  1146:     acc: 'a -> 'a
  1147: 
  1148: 
  1149: (** Fold over the list of initializers in a Compound, like
  1150:  * {!Flx_cil_cil.foldLeftCompound} but in the case of an array it scans even missing
  1151:  * zero initializers at the end of the array *)
  1152: val foldLeftCompoundAll:
  1153:     doinit: (offset -> init -> typ -> 'a -> 'a) ->
  1154:     ct: typ ->
  1155:     initl: (offset * init) list ->
  1156:     acc: 'a -> 'a
  1157: 
  1158: 
  1159: 
  1160: (** {b Values for manipulating types} *)
  1161: 
  1162: (** void *)
  1163: val voidType: typ
  1164: 
  1165: (* is the given type "void"? *)
  1166: val isVoidType: typ -> bool
  1167: 
  1168: (* is the given type "void *"? *)
  1169: val isVoidPtrType: typ -> bool
  1170: 
  1171: (** int *)
  1172: val intType: typ
  1173: 
  1174: (** unsigned int *)
  1175: val uintType: typ
  1176: 
  1177: (** long *)
  1178: val longType: typ
  1179: 
  1180: (** unsigned long *)
  1181: val ulongType: typ
  1182: 
  1183: (** char *)
  1184: val charType: typ
  1185: 
  1186: (** char * *)
  1187: val charPtrType: typ
  1188: 
  1189: (** wchar_t (depends on architecture) and is set when you call
  1190:  * {!Flx_cil_cil.initCIL}. *)
  1191: val wcharKind: ikind ref
  1192: val wcharType: typ ref
  1193: 
  1194: (** char const * *)
  1195: val charConstPtrType: typ
  1196: 
  1197: (** void * *)
  1198: val voidPtrType: typ
  1199: 
  1200: (** int * *)
  1201: val intPtrType: typ
  1202: 
  1203: (** unsigned int * *)
  1204: val uintPtrType: typ
  1205: 
  1206: (** double *)
  1207: val doubleType: typ
  1208: 
  1209: (* An unsigned integer type that fits pointers. Depends on {!Flx_cil_cil.msvcMode}
  1210:  *  and is set when you call {!Flx_cil_cil.initCIL}. *)
  1211: val upointType: typ ref
  1212: 
  1213: (* An unsigned integer type that is the type of sizeof. Depends on
  1214:  * {!Flx_cil_cil.msvcMode} and is set when you call {!Flx_cil_cil.initCIL}.  *)
  1215: val typeOfSizeOf: typ ref
  1216: 
  1217: (** Returns true if and only if the given integer type is signed. *)
  1218: val isSigned: ikind -> bool
  1219: 
  1220: (** Creates a a (potentially recursive) composite type. The arguments are:
  1221:  * (1) a boolean indicating whether it is a struct or a union, (2) the name
  1222:  * (always non-empty), (3) a function that when given a representation of the
  1223:  * structure type constructs the type of the fields recursive type (the first
  1224:  * argument is only useful when some fields need to refer to the type of the
  1225:  * structure itself), and (4) a list of attributes to be associated with the
  1226:  * composite type. The resulting compinfo has the field "cdefined" only if
  1227:  * the list of fields is non-empty. *)
  1228: val mkCompInfo: bool ->      (* whether it is a struct or a union *)
  1229:                string ->     (* name of the composite type; cannot be empty *)
  1230:                (compinfo ->
  1231:                   (string * typ * int option * attributes * location * storage) list) ->
  1232:                (* a function that when given a forward
  1233:                   representation of the structure type constructs the type of
  1234:                   the fields. The function can ignore this argument if not
  1235:                   constructing a recursive type.  *)
  1236:                attributes -> compinfo
  1237: 
  1238: (** Makes a shallow copy of a {!Flx_cil_cil.compinfo} changing the name and the key.*)
  1239: val copyCompInfo: compinfo -> string -> compinfo
  1240: 
  1241: (** This is a constant used as the name of an unnamed bitfield. These fields
  1242:     do not participate in initialization and their name is not printed. *)
  1243: val missingFieldName: string
  1244: 
  1245: (** Get the full name of a comp *)
  1246: val compFullName: compinfo -> string
  1247: 
  1248: (** Returns true if this is a complete type.
  1249:    This means that sizeof(t) makes sense.
  1250:    Incomplete types are not yet defined
  1251:    structures and empty arrays. *)
  1252: val isCompleteType: typ -> bool
  1253: 
  1254: (** Unroll a type until it exposes a non
  1255:  * [TNamed]. Will drop the top-level attributes appearing in [TNamed]!!! *)
  1256: val unrollType: typ -> typ   (* Might drop some attributes !! *)
  1257: 
  1258: (** Unroll all the TNamed in a type (even under type constructors such as
  1259:  * [TPtr], [TFun] or [TArray]. Does not unroll the types of fields in [TComp]
  1260:  * types. *)
  1261: val unrollTypeDeep: typ -> typ   (* Might drop some attributes !! *)
  1262: 
  1263: (** True if the argument is an integral type (i.e. integer or enum) *)
  1264: val isIntegralType: typ -> bool
  1265: 
  1266: (** True if the argument is an arithmetic type (i.e. integer, enum or
  1267:     floating point *)
  1268: val isArithmeticType: typ -> bool
  1269: 
  1270: (**True if the argument is a pointer type *)
  1271: val isPointerType: typ -> bool
  1272: 
  1273: (** True if the argument is a function type *)
  1274: val isFunctionType: typ -> bool
  1275: 
  1276: (** Obtain the argument list ([] if None) *)
  1277: val argsToList: (string * typ * attributes) list option
  1278:                   -> (string * typ * attributes) list
  1279: 
  1280: (** True if the argument is an array type *)
  1281: val isArrayType: typ -> bool
  1282: 
  1283: (** Raised when {!Flx_cil_cil.lenOfArray} fails either because the length is [None]
  1284:   * or because it is a non-constant expression *)
  1285: exception LenOfArray
  1286: 
  1287: (** Call to compute the array length as present in the array type, to an
  1288:   * integer. Raises {!Flx_cil_cil.LenOfArray} if not able to compute the length, such
  1289:   * as when there is no length or the length is not a constant. *)
  1290: val lenOfArray: exp option -> int
  1291: 
  1292: (** Return a named fieldinfo in compinfo, or raise Not_found *)
  1293: val getCompField: compinfo -> string -> fieldinfo
  1294: 
  1295: 
  1296: (** A datatype to be used in conjunction with [existsType] *)
  1297: type existsAction =
  1298:     ExistsTrue                          (* We have found it *)
  1299:   | ExistsFalse                         (* Stop processing this branch *)
  1300:   | ExistsMaybe                         (* This node is not what we are
  1301:                                          * looking for but maybe its
  1302:                                          * successors are *)
  1303: 
  1304: (** Scans a type by applying the function on all elements.
  1305:     When the function returns ExistsTrue, the scan stops with
  1306:     true. When the function returns ExistsFalse then the current branch is not
  1307:     scanned anymore. Care is taken to
  1308:     apply the function only once on each composite type, thus avoiding
  1309:     circularity. When the function returns ExistsMaybe then the types that
  1310:     construct the current type are scanned (e.g. the base type for TPtr and
  1311:     TArray, the type of fields for a TComp, etc). *)
  1312: val existsType: (typ -> existsAction) -> typ -> bool
  1313: 
  1314: 
  1315: (** Given a function type split it into return type,
  1316:  * arguments, is_vararg and attributes. An error is raised if the type is not
  1317:  * a function type *)
  1318: val splitFunctionType:
  1319:     typ -> typ * (string * typ * attributes) list option * bool * attributes
  1320: (** Same as {!Flx_cil_cil.splitFunctionType} but takes a varinfo. Prints a nicer
  1321:  * error message if the varinfo is not for a function *)
  1322: val splitFunctionTypeVI:
  1323:     varinfo -> typ * (string * typ * attributes) list option * bool * attributes
  1324: 
  1325: 
  1326: (** {b Type signatures} *)
  1327: 
  1328: (** Type signatures. Two types are identical iff they have identical
  1329:  * signatures. These contain the same information as types but canonicalized.
  1330:  * For example, two function types that are identical except for the name of
  1331:  * the formal arguments are given the same signature. Also, [TNamed]
  1332:  * constructors are unrolled. *)
  1333: type typsig =
  1334:     TSArray of typsig * exp option * attributes
  1335:   | TSPtr of typsig * attributes
  1336:   | TSComp of bool * string * attributes
  1337:   | TSFun of typsig * typsig list * bool * attributes
  1338:   | TSEnum of string * attributes
  1339:   | TSBase of typ
  1340: 
  1341: (** Print a type signature *)
  1342: val d_typsig: unit -> typsig -> Flx_cil_pretty.doc
  1343: 
  1344: (** Compute a type signature *)
  1345: val typeSig: typ -> typsig
  1346: 
  1347: (** Like {!Flx_cil_cil.typeSig} but customize the incorporation of attributes *)
  1348: val typeSigWithAttrs: (attributes -> attributes) -> typ -> typsig
  1349: 
  1350: (** Replace the attributes of a signature (only at top level) *)
  1351: val setTypeSigAttrs: attributes -> typsig -> typsig
  1352: 
  1353: (** Get the top-level attributes of a signature *)
  1354: val typeSigAttrs: typsig -> attributes
  1355: 
  1356: (*********************************************************)
  1357: (**  LVALUES *)
  1358: 
  1359: (** Make a varinfo. Use this (rarely) to make a raw varinfo. Use other
  1360:  * functions to make locals ({!Flx_cil_cil.makeLocalVar} or {!Flx_cil_cil.makeFormalVar} or
  1361:  * {!Flx_cil_cil.makeTempVar}) and globals ({!Flx_cil_cil.makeGlobalVar}). Note that this
  1362:  * function will assign a new identifier. The first argument specifies
  1363:  * whether the varinfo is for a global. *)
  1364: val makeVarinfo: bool -> string -> typ -> varinfo
  1365: 
  1366: (** Make a formal variable for a function. Insert it in both the sformals
  1367:     and the type of the function. You can optionally specify where to insert
  1368:     this one. If where = "^" then it is inserted first. If where = "$" then
  1369:     it is inserted last. Otherwise where must be the name of a formal after
  1370:     which to insert this. By default it is inserted at the end. *)
  1371: val makeFormalVar: fundec -> ?where:string -> string -> typ -> varinfo
  1372: 
  1373: (** Make a local variable and add it to a function's slocals (only if insert =
  1374:     true, which is the default). Make sure you know what you are doing if you
  1375:     set insert=false.  *)
  1376: val makeLocalVar: fundec -> ?insert:bool -> string -> typ -> varinfo
  1377: 
  1378: (** Make a temporary variable and add it to a function's slocals. The name of
  1379:     the temporary variable will be generated based on the given name hint so
  1380:     that to avoid conflicts with other locals.  *)
  1381: val makeTempVar: fundec -> ?name: string -> typ -> varinfo
  1382: 
  1383: 
  1384: (** Make a global variable. Your responsibility to make sure that the name
  1385:     is unique *)
  1386: val makeGlobalVar: string -> typ -> varinfo
  1387: 
  1388: (** Make a shallow copy of a [varinfo] and assign a new identifier *)
  1389: val copyVarinfo: varinfo -> string -> varinfo
  1390: 
  1391: (** Add an offset at the end of an lvalue. Make sure the type of the lvalue
  1392:  * and the offset are compatible. *)
  1393: val addOffsetLval: offset -> lval -> lval
  1394: 
  1395: (** [addOffset o1 o2] adds [o1] to the end of [o2]. *)
  1396: val addOffset:     offset -> offset -> offset
  1397: 
  1398: (** Remove ONE offset from the end of an lvalue. Returns the lvalue with the
  1399:  * trimmed offset and the final offset. If the final offset is [NoOffset]
  1400:  * then the original [lval] did not have an offset. *)
  1401: val removeOffsetLval: lval -> lval * offset
  1402: 
  1403: (** Remove ONE offset from the end of an offset sequence. Returns the
  1404:  * trimmed offset and the final offset. If the final offset is [NoOffset]
  1405:  * then the original [lval] did not have an offset. *)
  1406: val removeOffset:   offset -> offset * offset
  1407: 
  1408: (** Compute the type of an lvalue *)
  1409: val typeOfLval: lval -> typ
  1410: 
  1411: (** Compute the type of an offset from a base type *)
  1412: val typeOffset: typ -> offset -> typ
  1413: 
  1414: 
  1415: (*******************************************************)
  1416: (** {b Values for manipulating expressions} *)
  1417: 
  1418: 
  1419: (* Construct integer constants *)
  1420: 
  1421: (** 0 *)
  1422: val zero: exp
  1423: 
  1424: (** 1 *)
  1425: val one: exp
  1426: 
  1427: (** -1 *)
  1428: val mone: exp
  1429: 
  1430: 
  1431: (** Construct an integer of a given kind, using OCaml's int64 type. If needed
  1432:   * it will truncate the integer to be within the representable range for the
  1433:   * given kind. *)
  1434: val kinteger64: ikind -> int64 -> exp
  1435: 
  1436: (** Construct an integer of a given kind. Converts the integer to int64 and
  1437:   * then uses kinteger64. This might truncate the value if you use a kind
  1438:   * that cannot represent the given integer. This can only happen for one of
  1439:   * the Char or Short kinds *)
  1440: val kinteger: ikind -> int -> exp
  1441: 
  1442: (** Construct an integer of kind IInt. You can use this always since the
  1443:     OCaml integers are 31 bits and are guaranteed to fit in an IInt *)
  1444: val integer: int -> exp
  1445: 
  1446: 
  1447: (** True if the given expression is a (possibly cast'ed)
  1448:     character or an integer constant *)
  1449: val isInteger: exp -> int64 option
  1450: 
  1451: (** True if the expression is a compile-time constant *)
  1452: val isConstant: exp -> bool
  1453: 
  1454: (** True if the given expression is a (possibly cast'ed) integer or character
  1455:     constant with value zero *)
  1456: val isZero: exp -> bool
  1457: 
  1458: (** Do constant folding on an expression. If the first argument is true then
  1459:     will also compute compiler-dependent expressions such as sizeof *)
  1460: val constFold: bool -> exp -> exp
  1461: 
  1462: (** Do constant folding on a binary operation. The bulk of the work done by
  1463:     [constFold] is done here. If the first argument is true then
  1464:     will also compute compiler-dependent expressions such as sizeof *)
  1465: val constFoldBinOp: bool -> binop -> exp -> exp -> typ -> exp
  1466: 
  1467: (** Increment an expression. Can be arithmetic or pointer type *)
  1468: val increm: exp -> int -> exp
  1469: 
  1470: 
  1471: (** Makes an lvalue out of a given variable *)
  1472: val var: varinfo -> lval
  1473: 
  1474: (** Make an AddrOf. Given an lvalue of type T will give back an expression of
  1475:     type ptr(T). It optimizes somewhat expressions like "& v" and "& v[0]"  *)
  1476: val mkAddrOf: lval -> exp
  1477: 
  1478: 
  1479: (** Like mkAddrOf except if the type of lval is an array then it uses
  1480:     StartOf. This is the right operation for getting a pointer to the start
  1481:     of the storage denoted by lval. *)
  1482: val mkAddrOrStartOf: lval -> exp
  1483: 
  1484: (** Make a Mem, while optimizing AddrOf. The type of the addr must be
  1485:     TPtr(t) and the type of the resulting lval is t. Note that in CIL the
  1486:     implicit conversion between an array and the pointer to the first
  1487:     element does not apply. You must do the conversion yourself using
  1488:     StartOf *)
  1489: val mkMem: addr:exp -> off:offset -> lval
  1490: 
  1491: (** Make an expression that is a string constant (of pointer type) *)
  1492: val mkString: string -> exp
  1493: 
  1494: (** Construct a cast when having the old type of the expression. If the new
  1495:   * type is the same as the old type, then no cast is added. *)
  1496: val mkCastT: e:exp -> oldt:typ -> newt:typ -> exp
  1497: 
  1498: (** Like {!Flx_cil_cil.mkCastT} but uses typeOf to get [oldt] *)
  1499: val mkCast: e:exp -> newt:typ -> exp
  1500: 
  1501: (** Compute the type of an expression *)
  1502: val typeOf: exp -> typ
  1503: 
  1504: (** Convert a string representing a C integer literal to an expression.
  1505:  * Handles the prefixes 0x and 0 and the suffixes L, U, UL, LL, ULL *)
  1506: val parseInt: string -> exp
  1507: 
  1508: 
  1509: (**********************************************)
  1510: (** {b Values for manipulating statements} *)
  1511: 
  1512: (** Construct a statement, given its kind. Initialize the [sid] field to -1,
  1513:     and [labels], [succs] and [preds] to the empty list *)
  1514: val mkStmt: stmtkind -> stmt
  1515: 
  1516: (** Construct a block with no attributes, given a list of statements *)
  1517: val mkBlock: stmt list -> block
  1518: 
  1519: (** Construct a statement consisting of just one instruction *)
  1520: val mkStmtOneInstr: instr -> stmt
  1521: 
  1522: (** Try to compress statements so as to get maximal basic blocks *)
  1523: (* use this instead of List.@ because you get fewer basic blocks *)
  1524: val compactStmts: stmt list -> stmt list
  1525: 
  1526: (** Returns an empty statement (of kind [Instr]) *)
  1527: val mkEmptyStmt: unit -> stmt
  1528: 
  1529: (** A instr to serve as a placeholder *)
  1530: val dummyInstr: instr
  1531: 
  1532: (** A statement consisting of just [dummyInstr] *)
  1533: val dummyStmt: stmt
  1534: 
  1535: (** Make a while loop. Can contain Break or Continue *)
  1536: val mkWhile: guard:exp -> body:stmt list -> stmt list
  1537: 
  1538: (** Make a for loop for(i=start; i<past; i += incr) \{ ... \}. The body
  1539:     can contain Break but not Continue. Can be used with i a pointer
  1540:     or an integer. Start and done must have the same type but incr
  1541:     must be an integer *)
  1542: val mkForIncr:  iter:varinfo -> first:exp -> stopat:exp -> incr:exp
  1543:                  -> body:stmt list -> stmt list
  1544: 
  1545: (** Make a for loop for(start; guard; next) \{ ... \}. The body can
  1546:     contain Break but not Continue !!! *)
  1547: val mkFor: start:stmt list -> guard:exp -> next: stmt list ->
  1548:                                        body: stmt list -> stmt list
  1549: 
  1550: 
  1551: 
  1552: (**************************************************)
  1553: (** {b Values for manipulating attributes} *)
  1554: 
  1555: (** Various classes of attributes *)
  1556: type attributeClass =
  1557:     AttrName of bool
  1558:         (** Attribute of a name. If argument is true and we are on MSVC then
  1559:             the attribute is printed using __declspec as part of the storage
  1560:             specifier  *)
  1561:   | AttrFunType of bool
  1562:         (** Attribute of a function type. If argument is true and we are on
  1563:             MSVC then the attribute is printed just before the function name *)
  1564:   | AttrType  (** Attribute of a type *)
  1565: 
  1566: (** This table contains the mapping of predefined attributes to classes.
  1567:     Extend this table with more attributes as you need. This table is used to
  1568:     determine how to associate attributes with names or types *)
  1569: val attributeHash: (string, attributeClass) Hashtbl.t
  1570: 
  1571: (** Partition the attributes into classes:name attributes, function type,
  1572:     and type attributes *)
  1573: val partitionAttributes:  default:attributeClass ->
  1574:                          attributes -> attribute list * (* AttrName *)
  1575:                                        attribute list * (* AttrFunType *)
  1576:                                            attribute list   (* AttrType *)
  1577: 
  1578: (** Add an attribute. Maintains the attributes in sorted order of the second
  1579:     argument *)
  1580: val addAttribute: attribute -> attributes -> attributes
  1581: 
  1582: (** Add a list of attributes. Maintains the attributes in sorted order. The
  1583:     second argument must be sorted, but not necessarily the first *)
  1584: val addAttributes: attribute list -> attributes -> attributes
  1585: 
  1586: (** Remove all attributes with the given name. Maintains the attributes in
  1587:     sorted order.  *)
  1588: val dropAttribute: string -> attributes -> attributes
  1589: 
  1590: (** Retains attributes with the given name *)
  1591: val filterAttributes: string -> attributes -> attributes
  1592: 
  1593: (** True if the named attribute appears in the attribute list. The list of
  1594:     attributes must be sorted.  *)
  1595: val hasAttribute: string -> attributes -> bool
  1596: 
  1597: (** Returns all the attributes contained in a type. This requires a traversal
  1598:     of the type structure, in case of composite, enumeration and named types *)
  1599: val typeAttrs: typ -> attribute list
  1600: 
  1601: val setTypeAttrs: typ -> attributes -> typ (* Resets the attributes *)
  1602: 
  1603: 
  1604: (** Add some attributes to a type *)
  1605: val typeAddAttributes: attribute list -> typ -> typ
  1606: 
  1607: (** Remove all attributes with the given names from a type. Note that this
  1608:     does not remove attributes from typedef and tag definitions, just from
  1609:     their uses *)
  1610: val typeRemoveAttributes: string list -> typ -> typ
  1611: 
  1612: 
  1613: (******************
  1614:  ******************  VISITOR
  1615:  ******************)
  1616: (** {b The visitor} *)
  1617: 
  1618: (** Different visiting actions. 'a will be instantiated with [exp], [instr],
  1619:     etc. *)
  1620: type 'a visitAction =
  1621:     SkipChildren                        (** Do not visit the children. Return
  1622:                                             the node as it is. *)
  1623:   | DoChildren                          (** Continue with the children of this
  1624:                                             node. Rebuild the node on return
  1625:                                             if any of the children changes
  1626:                                             (use == test) *)
  1627:   | ChangeTo of 'a                      (** Replace the expression with the
  1628:                                             given one *)
  1629:   | ChangeDoChildrenPost of 'a * ('a -> 'a) (** First consider that the entire
  1630:                                            exp is replaced by the first
  1631:                                            parameter. Then continue with
  1632:                                            the children. On return rebuild
  1633:                                            the node if any of the children
  1634:                                            has changed and then apply the
  1635:                                            function on the node *)
  1636: 
  1637: 
  1638: 
  1639: (** A visitor interface for traversing CIL trees. Create instantiations of
  1640:  * this type by specializing the class {!Flx_cil_cil.nopCilVisitor}. Each of the
  1641:  * specialized visiting functions can also call the [queueInstr] to specify
  1642:  * that some instructions should be inserted before the current instruction
  1643:  * or statement. Use syntax like [self#queueInstr] to call a method
  1644:  * associated with the current object. *)
  1645: class type cilVisitor = object
  1646:   method vvdec: varinfo -> varinfo visitAction
  1647:     (** Invoked for each variable declaration. The subtrees to be traversed
  1648:      * are those corresponding to the type and attributes of the variable.
  1649:      * Note that variable declarations are all the [GVar], [GVarDecl], [GFun],
  1650:      * all the [varinfo] in formals of function types, and the formals and
  1651:      * locals for function definitions. This means that the list of formals
  1652:      * in a function definition will be traversed twice, once as part of the
  1653:      * function type and second as part of the formals in a function
  1654:      * definition. *)
  1655: 
  1656:   method vvrbl: varinfo -> varinfo visitAction
  1657:     (** Invoked on each variable use. Here only the [SkipChildren] and
  1658:      * [ChangeTo] actions make sense since there are no subtrees. Note that
  1659:      * the type and attributes of the variable are not traversed for a
  1660:      * variable use *)
  1661: 
  1662:   method vexpr: exp -> exp visitAction
  1663:     (** Invoked on each expression occurrence. The subtrees are the
  1664:      * subexpressions, the types (for a [Cast] or [SizeOf] expression) or the
  1665:      * variable use. *)
  1666: 
  1667:   method vlval: lval -> lval visitAction
  1668:     (** Invoked on each lvalue occurrence *)
  1669: 
  1670:   method voffs: offset -> offset visitAction
  1671:     (** Invoked on each offset occurrence that is *not* as part
  1672:       * of an initializer list specification, i.e. in an lval or
  1673:       * recursively inside an offset. *)
  1674: 
  1675:   method vinitoffs: offset -> offset visitAction
  1676:     (** Invoked on each offset appearing in the list of a
  1677:       * CompoundInit initializer.  *)
  1678: 
  1679:   method vinst: instr -> instr list visitAction
  1680:     (** Invoked on each instruction occurrence. The [ChangeTo] action can
  1681:      * replace this instruction with a list of instructions *)
  1682: 
  1683:   method vstmt: stmt -> stmt visitAction
  1684:     (** Control-flow statement. The default [DoChildren] action does not
  1685:      * create a new statement when the components change. Instead it updates
  1686:      * the contents of the original statement. This is done to preserve the
  1687:      * sharing with [Goto] and [Case] statements that point to the original
  1688:      * statement. If you use the [ChangeTo] action then you should take care
  1689:      * of preserving that sharing yourself.  *)
  1690: 
  1691:   method vblock: block -> block visitAction     (** Block. *)
  1692:   method vfunc: fundec -> fundec visitAction    (** Function definition.
  1693:                                                     Replaced in place. *)
  1694:   method vglob: global -> global list visitAction (** Global (vars, types,
  1695:                                                       etc.)  *)
  1696:   method vinit: init -> init visitAction        (** Initializers for globals *)
  1697:   method vtype: typ -> typ visitAction          (** Use of some type. Note
  1698:                                                  * that for structure/union
  1699:                                                  * and enumeration types the
  1700:                                                  * definition of the
  1701:                                                  * composite type is not
  1702:                                                  * visited. Use [vglob] to
  1703:                                                  * visit it.  *)
  1704:   method vattr: attribute -> attribute list visitAction
  1705:     (** Attribute. Each attribute can be replaced by a list *)
  1706: 
  1707:     (** Add here instructions while visiting to queue them to preceede the
  1708:      * current statement or instruction being processed. Use this method only
  1709:      * when you are visiting an expression that is inside a function body, or
  1710:      * a statement, because otherwise there will no place for the visitor to
  1711:      * place your instructions. *)
  1712:   method queueInstr: instr list -> unit
  1713: 
  1714:     (** Gets the queue of instructions and resets the queue. This is done
  1715:      * automatically for you when you visit statments. *)
  1716:   method unqueueInstr: unit -> instr list
  1717: 
  1718: end
  1719: 
  1720: (** Default Visitor. Traverses the CIL tree without modifying anything *)
  1721: class nopCilVisitor: cilVisitor
  1722: 
  1723: (* other cil constructs *)
  1724: 
  1725: (** Visit a file. This will will re-cons all globals TWICE (so that it is
  1726:  * tail-recursive). Use {!Flx_cil_cil.visitCilFileSameGlobals} if your visitor will
  1727:  * not change the list of globals.  *)
  1728: val visitCilFile: cilVisitor -> file -> unit
  1729: 
  1730: (** A visitor for the whole file that does not change the globals (but maybe
  1731:  * changes things inside the globals). Use this function instead of
  1732:  * {!Flx_cil_cil.visitCilFile} whenever appropriate because it is more efficient for
  1733:  * long files. *)
  1734: val visitCilFileSameGlobals: cilVisitor -> file -> unit
  1735: 
  1736: (** Visit a global *)
  1737: val visitCilGlobal: cilVisitor -> global -> global list
  1738: 
  1739: (** Visit a function definition *)
  1740: val visitCilFunction: cilVisitor -> fundec -> fundec
  1741: 
  1742: (* Visit an expression *)
  1743: val visitCilExpr: cilVisitor -> exp -> exp
  1744: 
  1745: (** Visit an lvalue *)
  1746: val visitCilLval: cilVisitor -> lval -> lval
  1747: 
  1748: (** Visit an lvalue or recursive offset *)
  1749: val visitCilOffset: cilVisitor -> offset -> offset
  1750: 
  1751: (** Visit an initializer offset *)
  1752: val visitCilInitOffset: cilVisitor -> offset -> offset
  1753: 
  1754: (** Visit an instruction *)
  1755: val visitCilInstr: cilVisitor -> instr -> instr list
  1756: 
  1757: (** Visit a statement *)
  1758: val visitCilStmt: cilVisitor -> stmt -> stmt
  1759: 
  1760: (** Visit a block *)
  1761: val visitCilBlock: cilVisitor -> block -> block
  1762: 
  1763: (** Visit a type *)
  1764: val visitCilType: cilVisitor -> typ -> typ
  1765: 
  1766: (** Visit a variable declaration *)
  1767: val visitCilVarDecl: cilVisitor -> varinfo -> varinfo
  1768: 
  1769: (** Visit an initializer *)
  1770: val visitCilInit: cilVisitor -> init -> init
  1771: 
  1772: 
  1773: (** Visit a list of attributes *)
  1774: val visitCilAttributes: cilVisitor -> attribute list -> attribute list
  1775: 
  1776: (* And some generic visitors. The above are built with these *)
  1777: 
  1778: 
  1779: 
  1780: 
  1781: (** {b Flx_cil_utility functions} *)
  1782: 
  1783: (** Whether the pretty printer should print output for the MS VC compiler.
  1784:    Default is GCC. After you set this function you should call {!Flx_cil_cil.initCIL}. *)
  1785: val msvcMode: bool ref
  1786: 
  1787: 
  1788: (** Whether to use the logical operands LAnd and LOr. By default, do not use
  1789:  * them because they are unlike other expressions and do not evaluate both of
  1790:  * their operands *)
  1791: val useLogicalOperators: bool ref
  1792: 
  1793: (** Styles of printing line directives *)
  1794: type lineDirectiveStyle =
  1795:   | LineComment
  1796:   | LinePreprocessorInput
  1797:   | LinePreprocessorOutput
  1798: 
  1799: (** How to print line directives *)
  1800: val lineDirectiveStyle: lineDirectiveStyle option ref
  1801: 
  1802: (** Whether we print something that will only be used as input to our own
  1803:  * parser. In that case we are a bit more liberal in what we print *)
  1804: val print_CIL_Input: bool ref
  1805: 
  1806: (** Whether to print the CIL as they are, without trying to be smart and
  1807:   * print nicer code. Normally this is false, in which case the pretty
  1808:   * printer will turn the while(1) loops of CIL into nicer loops, will not
  1809:   * print empty "else" blocks, etc. These is one case howewer in which if you
  1810:   * turn this on you will get code that does not compile: if you use varargs
  1811:   * the __builtin_va_arg function will be printed in its internal form. *)
  1812: val printCilAsIs: bool ref
  1813: 
  1814: (** {b Debugging support} *)
  1815: 
  1816: (** A reference to the current location. If you are careful to set this to
  1817:  * the current location then you can use some built-in logging functions that
  1818:  * will print the location. *)
  1819: val currentLoc: location ref
  1820: 
  1821: (** CIL has a fairly easy to use mechanism for printing error messages. This
  1822:  * mechanism is built on top of the pretty-printer mechanism (see
  1823:  * {!Flx_cil_pretty.doc}) and the error-message modules (see {!Flx_cil_errormsg.error}).
  1824: 
  1825:  Here is a typical example for printing a log message: {v
  1826: ignore (Flx_cil_errormsg.log "Expression %a is not positive (at %s:%i)\n"
  1827:                         d_exp e loc.file loc.line)
  1828:  v}
  1829: 
  1830:  and here is an example of how you print a fatal error message that stop the
  1831: * execution: {v
  1832: Flx_cil_errormsg.s (Flx_cil_errormsg.bug "Why am I here?")
  1833:  v}
  1834: 
  1835:  Notice that you can use C format strings with some extension. The most
  1836: useful extension is "%a" that means to consumer the next two argument from
  1837: the argument list and to apply the first to [unit] and then to the second
  1838: and to print the resulting {!Flx_cil_pretty.doc}. For each major type in CIL there is
  1839: a corresponding function that pretty-prints an element of that type:
  1840: *)
  1841: 
  1842: 
  1843: (** Flx_cil_pretty-print a location *)
  1844: val d_loc: unit -> location -> Flx_cil_pretty.doc
  1845: 
  1846: (** Flx_cil_pretty-print the {!Flx_cil_cil.currentLoc} *)
  1847: val d_thisloc: unit -> Flx_cil_pretty.doc
  1848: 
  1849: (** Flx_cil_pretty-print an integer of a given kind *)
  1850: val d_ikind: unit -> ikind -> Flx_cil_pretty.doc
  1851: 
  1852: (** Flx_cil_pretty-print a floating-point kind *)
  1853: val d_fkind: unit -> fkind -> Flx_cil_pretty.doc
  1854: 
  1855: (** Flx_cil_pretty-print storage-class information *)
  1856: val d_storage: unit -> storage -> Flx_cil_pretty.doc
  1857: 
  1858: (** Flx_cil_pretty-print a constant *)
  1859: val d_const: unit -> constant -> Flx_cil_pretty.doc
  1860: 
  1861: 
  1862: (** A printer interface for CIL trees. Create instantiations of
  1863:  * this type by specializing the class {!Flx_cil_cil.defaultCilPrinterClass}. *)
  1864: class type cilPrinter = object
  1865:   method pVDecl: unit -> varinfo -> Flx_cil_pretty.doc
  1866:     (** Invoked for each variable declaration. Note that variable
  1867:      * declarations are all the [GVar], [GVarDecl], [GFun], all the [varinfo]
  1868:      * in formals of function types, and the formals and locals for function
  1869:      * definitions. *)
  1870: 
  1871:   method pVar: varinfo -> Flx_cil_pretty.doc
  1872:     (** Invoked on each variable use. *)
  1873: 
  1874:   method pLval: unit -> lval -> Flx_cil_pretty.doc
  1875:     (** Invoked on each lvalue occurrence *)
  1876: 
  1877:   method pOffset: Flx_cil_pretty.doc -> offset -> Flx_cil_pretty.doc
  1878:     (** Invoked on each offset occurrence. The second argument is the base. *)
  1879: 
  1880:   method pInstr: unit -> instr -> Flx_cil_pretty.doc
  1881:     (** Invoked on each instruction occurrence. *)
  1882: 
  1883:   method pLabel: unit -> label -> Flx_cil_pretty.doc
  1884:     (** Print a label. *)
  1885: 
  1886:   method pStmt: unit -> stmt -> Flx_cil_pretty.doc
  1887:     (** Control-flow statement. This is used by
  1888:      * {!Flx_cil_cil.printGlobal} and by {!Flx_cil_cil.dumpGlobal}. *)
  1889: 
  1890:   method dStmt: out_channel -> int -> stmt -> unit
  1891:     (** Dump a control-flow statement to a file with a given indentation.
  1892:      * This is used by {!Flx_cil_cil.dumpGlobal}. *)
  1893: 
  1894:   method dBlock: out_channel -> int -> block -> unit
  1895:     (** Dump a control-flow block to a file with a given indentation.
  1896:      * This is used by {!Flx_cil_cil.dumpGlobal}. *)
  1897: 
  1898:   method pBlock: unit -> block -> Flx_cil_pretty.doc
  1899: 
  1900:   method pBlock: unit -> block -> Flx_cil_pretty.doc
  1901:     (** Print a block. *)
  1902: 
  1903:   method pGlobal: unit -> global -> Flx_cil_pretty.doc
  1904:     (** Global (vars, types, etc.). This can be slow and is used only by
  1905:      * {!Flx_cil_cil.printGlobal} but not by {!Flx_cil_cil.dumpGlobal}. *)
  1906: 
  1907:   method dGlobal: out_channel -> global -> unit
  1908:     (** Dump a global to a file with a given indentation. This is used by
  1909:      * {!Flx_cil_cil.dumpGlobal} *)
  1910: 
  1911:   method pFieldDecl: unit -> fieldinfo -> Flx_cil_pretty.doc
  1912:     (** A field declaration *)
  1913: 
  1914:   method pType: Flx_cil_pretty.doc option -> unit -> typ -> Flx_cil_pretty.doc
  1915:   (* Use of some type in some declaration. The first argument is used to print
  1916:    * the declared element, or is None if we are just printing a type with no
  1917:    * name being declared. Note that for structure/union and enumeration types
  1918:    * the definition of the composite type is not visited. Use [vglob] to
  1919:    * visit it.  *)
  1920: 
  1921:   method pAttr: attribute -> Flx_cil_pretty.doc * bool
  1922:     (** Attribute. Also return an indication whether this attribute must be
  1923:       * printed inside the __attribute__ list or not. *)
  1924: 
  1925:   method pAttrParam: unit -> attrparam -> Flx_cil_pretty.doc
  1926:     (** Attribute parameter *)
  1927: 
  1928:   method pAttrs: unit -> attributes -> Flx_cil_pretty.doc
  1929:     (** Attribute lists *)
  1930: 
  1931:   method pLineDirective: ?forcefile:bool -> location -> Flx_cil_pretty.doc
  1932:     (** Print a line-number. This is assumed to come always on an empty line.
  1933:      * If the forcefile argument is present and is true then the file name
  1934:      * will be printed always. Otherwise the file name is printed only if it
  1935:      * is different from the last time time this function is called. The last
  1936:      * file name is stored in a private field inside the cilPrinter object. *)
  1937: 
  1938:   method pStmtKind : stmt -> unit -> stmtkind -> Flx_cil_pretty.doc
  1939:     (** Print a statement kind. The code to be printed is given in the
  1940:      * {!Flx_cil_cil.stmtkind} argument.  The initial {!Flx_cil_cil.stmt} argument
  1941:      * records the statement which follows the one being printed;
  1942:      * {!Flx_cil_cil.defaultCilPrinterClass} uses this information to prettify
  1943:      * statement printing in certain special cases. *)
  1944: 
  1945:   method pExp: unit -> exp -> Flx_cil_pretty.doc
  1946:     (** Print expressions *)
  1947: 
  1948:   method pInit: unit -> init -> Flx_cil_pretty.doc
  1949:     (** Print initializers. This can be slow and is used by
  1950:      * {!Flx_cil_cil.printGlobal} but not by {!Flx_cil_cil.dumpGlobal}. *)
  1951: 
  1952:   method dInit: out_channel -> int -> init -> unit
  1953:     (** Dump a global to a file with a given indentation. This is used by
  1954:      * {!Flx_cil_cil.dumpGlobal} *)
  1955: end
  1956: 
  1957: class defaultCilPrinterClass: cilPrinter
  1958: val defaultCilPrinter: cilPrinter
  1959: 
  1960: (* Top-level printing functions *)
  1961: (** Print a type given a pretty printer *)
  1962: val printType: cilPrinter -> unit -> typ -> Flx_cil_pretty.doc
  1963: 
  1964: (** Print an expression given a pretty printer *)
  1965: val printExp: cilPrinter -> unit -> exp -> Flx_cil_pretty.doc
  1966: 
  1967: (** Print an lvalue given a pretty printer *)
  1968: val printLval: cilPrinter -> unit -> lval -> Flx_cil_pretty.doc
  1969: 
  1970: (** Print a global given a pretty printer *)
  1971: val printGlobal: cilPrinter -> unit -> global -> Flx_cil_pretty.doc
  1972: 
  1973: (** Print an attribute given a pretty printer *)
  1974: val printAttr: cilPrinter -> unit -> attribute -> Flx_cil_pretty.doc
  1975: 
  1976: (** Print a set of attributes given a pretty printer *)
  1977: val printAttrs: cilPrinter -> unit -> attributes -> Flx_cil_pretty.doc
  1978: 
  1979: (** Print an instruction given a pretty printer *)
  1980: val printInstr: cilPrinter -> unit -> instr -> Flx_cil_pretty.doc
  1981: 
  1982: (** Print a statement given a pretty printer. This can take very long
  1983:  * (or even overflow the stack) for huge statements. Use {!Flx_cil_cil.dumpStmt}
  1984:  * instead. *)
  1985: val printStmt: cilPrinter -> unit -> stmt -> Flx_cil_pretty.doc
  1986: 
  1987: (** Print a block given a pretty printer. This can take very long
  1988:  * (or even overflow the stack) for huge block. Use {!Flx_cil_cil.dumpBlock}
  1989:  * instead. *)
  1990: val printBlock: cilPrinter -> unit -> block -> Flx_cil_pretty.doc
  1991: 
  1992: (** Dump a statement to a file using a given indentation. Use this instead of
  1993:  * {!Flx_cil_cil.printStmt} whenever possible. *)
  1994: val dumpStmt: cilPrinter -> out_channel -> int -> stmt -> unit
  1995: 
  1996: (** Dump a block to a file using a given indentation. Use this instead of
  1997:  * {!Flx_cil_cil.printBlock} whenever possible. *)
  1998: val dumpBlock: cilPrinter -> out_channel -> int -> block -> unit
  1999: 
  2000: (** Print an initializer given a pretty printer. This can take very long
  2001:  * (or even overflow the stack) for huge initializers. Use {!Flx_cil_cil.dumpInit}
  2002:  * instead. *)
  2003: val printInit: cilPrinter -> unit -> init -> Flx_cil_pretty.doc
  2004: 
  2005: (** Dump an initializer to a file using a given indentation. Use this instead of
  2006:  * {!Flx_cil_cil.printInit} whenever possible. *)
  2007: val dumpInit: cilPrinter -> out_channel -> int -> init -> unit
  2008: 
  2009: (** Flx_cil_pretty-print a type using {!Flx_cil_cil.defaultCilPrinter} *)
  2010: val d_type: unit -> typ -> Flx_cil_pretty.doc
  2011: 
  2012: (** Flx_cil_pretty-print an expression using {!Flx_cil_cil.defaultCilPrinter}  *)
  2013: val d_exp: unit -> exp -> Flx_cil_pretty.doc
  2014: 
  2015: (** Flx_cil_pretty-print an lvalue using {!Flx_cil_cil.defaultCilPrinter}   *)
  2016: val d_lval: unit -> lval -> Flx_cil_pretty.doc
  2017: 
  2018: (** Flx_cil_pretty-print an offset using {!Flx_cil_cil.defaultCilPrinter}, given the pretty
  2019:  * printing for the base.   *)
  2020: val d_offset: Flx_cil_pretty.doc -> unit -> offset -> Flx_cil_pretty.doc
  2021: 
  2022: (** Flx_cil_pretty-print an initializer using {!Flx_cil_cil.defaultCilPrinter}.  This can be
  2023:  * extremely slow (or even overflow the stack) for huge initializers. Use
  2024:  * {!Flx_cil_cil.dumpInit} instead. *)
  2025: val d_init: unit -> init -> Flx_cil_pretty.doc
  2026: 
  2027: (** Flx_cil_pretty-print a binary operator *)
  2028: val d_binop: unit -> binop -> Flx_cil_pretty.doc
  2029: 
  2030: (** Flx_cil_pretty-print an attribute using {!Flx_cil_cil.defaultCilPrinter}  *)
  2031: val d_attr: unit -> attribute -> Flx_cil_pretty.doc
  2032: 
  2033: (** Flx_cil_pretty-print an argument of an attribute using {!Flx_cil_cil.defaultCilPrinter}  *)
  2034: val d_attrparam: unit -> attrparam -> Flx_cil_pretty.doc
  2035: 
  2036: (** Flx_cil_pretty-print a list of attributes using {!Flx_cil_cil.defaultCilPrinter}  *)
  2037: val d_attrlist: unit -> attributes -> Flx_cil_pretty.doc
  2038: 
  2039: (** Flx_cil_pretty-print an instruction using {!Flx_cil_cil.defaultCilPrinter}   *)
  2040: val d_instr: unit -> instr -> Flx_cil_pretty.doc
  2041: 
  2042: (** Flx_cil_pretty-print a label using {!Flx_cil_cil.defaultCilPrinter} *)
  2043: val d_label: unit -> label -> Flx_cil_pretty.doc
  2044: 
  2045: (** Flx_cil_pretty-print a statement using {!Flx_cil_cil.defaultCilPrinter}. This can be
  2046:  * extremely slow (or even overflow the stack) for huge statements. Use
  2047:  * {!Flx_cil_cil.dumpStmt} instead. *)
  2048: val d_stmt: unit -> stmt -> Flx_cil_pretty.doc
  2049: 
  2050: (** Flx_cil_pretty-print a block using {!Flx_cil_cil.defaultCilPrinter}. This can be
  2051:  * extremely slow (or even overflow the stack) for huge blocks. Use
  2052:  * {!Flx_cil_cil.dumpBlock} instead. *)
  2053: val d_block: unit -> block -> Flx_cil_pretty.doc
  2054: 
  2055: (** Flx_cil_pretty-print the internal representation of a global using
  2056:  * {!Flx_cil_cil.defaultCilPrinter}. This can be extremely slow (or even overflow the
  2057:  * stack) for huge globals (such as arrays with lots of initializers). Use
  2058:  * {!Flx_cil_cil.dumpGlobal} instead. *)
  2059: val d_global: unit -> global -> Flx_cil_pretty.doc
  2060: 
  2061: 
  2062: (** Versions of the above pretty printers, that don't print #line directives *)
  2063: val dn_exp       : unit -> exp -> Flx_cil_pretty.doc
  2064: val dn_lval      : unit -> lval -> Flx_cil_pretty.doc
  2065: (* dn_offset is missing because it has a different interface *)
  2066: val dn_init      : unit -> init -> Flx_cil_pretty.doc
  2067: val dn_type      : unit -> typ -> Flx_cil_pretty.doc
  2068: val dn_global    : unit -> global -> Flx_cil_pretty.doc
  2069: val dn_attrlist  : unit -> attributes -> Flx_cil_pretty.doc
  2070: val dn_attr      : unit -> attribute -> Flx_cil_pretty.doc
  2071: val dn_attrparam : unit -> attrparam -> Flx_cil_pretty.doc
  2072: val dn_stmt      : unit -> stmt -> Flx_cil_pretty.doc
  2073: val dn_instr     : unit -> instr -> Flx_cil_pretty.doc
  2074: 
  2075: 
  2076: (** Flx_cil_pretty-print a short description of the global. This is useful for error
  2077:  * messages *)
  2078: val d_shortglobal: unit -> global -> Flx_cil_pretty.doc
  2079: 
  2080: (** Flx_cil_pretty-print a global. Here you give the channel where the printout
  2081:  * should be sent. *)
  2082: val dumpGlobal: cilPrinter -> out_channel -> global -> unit
  2083: 
  2084: (** Flx_cil_pretty-print an entire file. Here you give the channel where the printout
  2085:  * should be sent. *)
  2086: val dumpFile: cilPrinter -> out_channel -> file -> unit
  2087: 
  2088: 
  2089: (* the following error message producing functions also print a location in
  2090:  * the code. use {!Flx_cil_errormsg.bug} and {!Flx_cil_errormsg.unimp} if you do not want
  2091:  * that *)
  2092: 
  2093: (** Like {!Flx_cil_errormsg.bug} except that {!Flx_cil_cil.currentLoc} is also printed *)
  2094: val bug: ('a,unit,Flx_cil_pretty.doc) format -> 'a
  2095: 
  2096: (** Like {!Flx_cil_errormsg.unimp} except that {!Flx_cil_cil.currentLoc}is also printed *)
  2097: val unimp: ('a,unit,Flx_cil_pretty.doc) format -> 'a
  2098: 
  2099: (** Like {!Flx_cil_errormsg.error} except that {!Flx_cil_cil.currentLoc} is also printed *)
  2100: val error: ('a,unit,Flx_cil_pretty.doc) format -> 'a
  2101: 
  2102: (** Like {!Flx_cil_cil.error} except that it explicitly takes a location argument,
  2103:  * instead of using the {!Flx_cil_cil.currentLoc} *)
  2104: val errorLoc: location -> ('a,unit,Flx_cil_pretty.doc) format -> 'a
  2105: 
  2106: (** Like {!Flx_cil_errormsg.warn} except that {!Flx_cil_cil.currentLoc} is also printed *)
  2107: val warn: ('a,unit,Flx_cil_pretty.doc) format -> 'a
  2108: 
  2109: 
  2110: (** Like {!Flx_cil_errormsg.warnOpt} except that {!Flx_cil_cil.currentLoc} is also printed.
  2111:  * This warning is printed only of {!Flx_cil_errormsg.warnFlag} is set. *)
  2112: val warnOpt: ('a,unit,Flx_cil_pretty.doc) format -> 'a
  2113: 
  2114: (** Like {!Flx_cil_errormsg.warn} except that {!Flx_cil_cil.currentLoc} and context
  2115:     is also printed *)
  2116: val warnContext: ('a,unit,Flx_cil_pretty.doc) format -> 'a
  2117: 
  2118: (** Like {!Flx_cil_errormsg.warn} except that {!Flx_cil_cil.currentLoc} and context is also
  2119:  * printed. This warning is printed only of {!Flx_cil_errormsg.warnFlag} is set. *)
  2120: val warnContextOpt: ('a,unit,Flx_cil_pretty.doc) format -> 'a
  2121: 
  2122: (** Like {!Flx_cil_cil.warn} except that it explicitly takes a location argument,
  2123:  * instead of using the {!Flx_cil_cil.currentLoc} *)
  2124: val warnLoc: location -> ('a,unit,Flx_cil_pretty.doc) format -> 'a
  2125: 
  2126: (** Sometimes you do not want to see the syntactic sugar that the above
  2127:  * pretty-printing functions add. In that case you can use the following
  2128:  * pretty-printing functions. But note that the output of these functions is
  2129:  * not valid C *)
  2130: 
  2131: (** Flx_cil_pretty-print the internal representation of an expression *)
  2132: val d_plainexp: unit -> exp -> Flx_cil_pretty.doc
  2133: 
  2134: (** Flx_cil_pretty-print the internal representation of an integer *)
  2135: val d_plaininit: unit -> init -> Flx_cil_pretty.doc
  2136: 
  2137: (** Flx_cil_pretty-print the internal representation of an lvalue *)
  2138: val d_plainlval: unit -> lval -> Flx_cil_pretty.doc
  2139: 
  2140: (** Flx_cil_pretty-print the internal representation of an lvalue offset
  2141: val d_plainoffset: unit -> offset -> Flx_cil_pretty.doc *)
  2142: 
  2143: (** Flx_cil_pretty-print the internal representation of a type *)
  2144: val d_plaintype: unit -> typ -> Flx_cil_pretty.doc
  2145: 
  2146: 
  2147: 
  2148: (** {b ALPHA conversion} *)
  2149: 
  2150: (** This is the type of the elements that are recorded by the alpha
  2151:  * conversion functions in order to be able to undo changes to the tables
  2152:  * they modify. Useful for implementing
  2153:  * scoping *)
  2154: type undoAlphaElement
  2155: 
  2156: (** This is the type of the elements of the alpha renaming table. *)
  2157: type alphaTableData
  2158: 
  2159: 
  2160: (** Create a new name based on a given name. The new name is formed from a
  2161:  * prefix (obtained from the given name by stripping a suffix consisting of _
  2162:  * followed by only digits), followed by a special separator and then by a
  2163:  * positive integer suffix. The first argument is a table mapping name
  2164:  * prefixes to some data that specifies what suffixes have been used and how
  2165:  * to create the new one. This function updates the table with the new
  2166:  * largest suffix generated. The "undolist" argument, when present, will be
  2167:  * used by the function to record information that can be used by
  2168:  * {!Flx_cil_cil.undoAlphaChanges} to undo those changes. Note that the undo
  2169:  * information will be in reverse order in which the action occurred. Returns
  2170:  * the new name and, if different from the lookupname, the location of the
  2171:  * previous occurrence. This function knows about the location implicitly
  2172:  * from the {!Flx_cil_cil.currentLoc}. *)
  2173: val newAlphaName: alphaTable:(string, alphaTableData ref) Hashtbl.t ->
  2174:                   undolist: undoAlphaElement list ref option ->
  2175:                   lookupname:string -> string * location
  2176: 
  2177: 
  2178: (** Register a name with an alpha conversion table to ensure that when later
  2179:   * we call newAlphaName we do not end up generating this one *)
  2180: val registerAlphaName: alphaTable:(string, alphaTableData ref) Hashtbl.t ->
  2181:                        undolist: undoAlphaElement list ref option ->
  2182:                        lookupname:string -> unit
  2183: 
  2184: (** Split the name in preparation for newAlphaName. The prefix returned is
  2185:     used to index into the hashtable. The next result value is a separator
  2186:     (either empty or the separator chosen to separate the original name from
  2187:      the index)  *)
  2188: val docAlphaTable: unit -> (string, alphaTableData ref) Hashtbl.t -> Flx_cil_pretty.doc
  2189: 
  2190: 
  2191: val getAlphaPrefix: lookupname:string -> string
  2192: 
  2193: (** Undo the changes to a table *)
  2194: val undoAlphaChanges: alphaTable:(string, alphaTableData ref) Hashtbl.t ->
  2195:                       undolist:undoAlphaElement list -> unit
  2196: 
  2197: (** Assign unique names to local variables. This might be necessary after you
  2198:  * transformed the code and added or renamed some new variables. Names are
  2199:  * not used by CIL internally, but once you print the file out the compiler
  2200:  * downstream might be confused. You might
  2201:  * have added a new global that happens to have the same name as a local in
  2202:  * some function. Rename the local to ensure that there would never be
  2203:  * confusioin. Or, viceversa, you might have added a local with a name that
  2204:  * conflicts with a global *)
  2205: val uniqueVarNames: file -> unit
  2206: 
  2207: (** {b Optimization Passes} *)
  2208: 
  2209: (** A peephole optimizer that processes two adjacent statements and possibly
  2210:     replaces them both. If some replacement happens, then the new statements
  2211:     are themselves subject to optimization *)
  2212: val peepHole2: (instr * instr -> instr list option) -> stmt list -> unit
  2213: 
  2214: (** Similar to [peepHole2] except that the optimization window consists of
  2215:     one statement, not two *)
  2216: val peepHole1: (instr -> instr list option) -> stmt list -> unit
  2217: 
  2218: (** {b Machine dependency} *)
  2219: 
  2220: 
  2221: (** Raised when one of the bitsSizeOf functions cannot compute the size of a
  2222:     type. This can happen because the type contains array-length expressions
  2223:     that we don't know how to compute or because it is a type whose size is
  2224:     not defined (e.g. TFun or an undefined compinfo)  *)
  2225: exception SizeOfError of typ
  2226: 
  2227: (** The size of a type, in bits. Trailing padding is added for structs and
  2228:  * arrays. Raises {!Flx_cil_cil.SizeOfError} when it cannot compute the size. This
  2229:  * function is architecture dependent, so you should only call this after you
  2230:  * call {!Flx_cil_cil.initCIL}. Remember that on GCC sizeof(void) is 1! *)
  2231: val bitsSizeOf: typ -> int
  2232: 
  2233: (* The size of a type, in bytes. Returns a constant expression or a "sizeof"
  2234:  * expression if it cannot compute the size. This function is architecture
  2235:  * dependent, so you should only call this after you call {!Flx_cil_cil.initCIL}.  *)
  2236: val sizeOf: typ -> exp
  2237: 
  2238: (** The minimum alignment (in bytes) for a type. This function is
  2239:  * architecture dependent, so you should only call this after you call
  2240:  * {!Flx_cil_cil.initCIL}. *)
  2241: val alignOf_int: typ -> int
  2242: 
  2243: (** Give a type of a base and an offset, returns the number of bits from the
  2244:  * base address and the width (also expressed in bits) for the subobject
  2245:  * denoted by the offset. Raises {!Flx_cil_cil.SizeOfError} when it cannot compute
  2246:  * the size. This function is architecture dependent, so you should only call
  2247:  * this after you call {!Flx_cil_cil.initCIL}. *)
  2248: val bitsOffset: typ -> offset -> int * int
  2249: 
  2250: 
  2251: (** Whether "char" is unsigned. Set after you call {!Flx_cil_cil.initCIL} *)
  2252: val char_is_unsigned: bool ref
  2253: 
  2254: (** Whether the machine is little endian. Set after you call {!Flx_cil_cil.initCIL} *)
  2255: val little_endian: bool ref
  2256: 
  2257: (** Represents a location that cannot be determined *)
  2258: val locUnknown: location
  2259: 
  2260: (** Return the location of an instruction *)
  2261: val get_instrLoc: instr -> location
  2262: 
  2263: (** Return the location of a global, or locUnknown *)
  2264: val get_globalLoc: global -> location
  2265: 
  2266: (** Return the location of a statement, or locUnknown *)
  2267: val get_stmtLoc: stmtkind -> location
  2268: 
  2269: 
  2270: (** Generate an {!Flx_cil_cil.exp} to be used in case of errors. *)
  2271: val dExp: Flx_cil_pretty.doc -> exp
  2272: 
  2273: (** Generate an {!Flx_cil_cil.instr} to be used in case of errors. *)
  2274: val dInstr: Flx_cil_pretty.doc -> location -> instr
  2275: 
  2276: (** Generate a {!Flx_cil_cil.global} to be used in case of errors. *)
  2277: val dGlobal: Flx_cil_pretty.doc -> location -> global
  2278: 
  2279: (** Like map but try not to make a copy of the list *)
  2280: val mapNoCopy: ('a -> 'a) -> 'a list -> 'a list
  2281: 
  2282: (** Like map but each call can return a list. Try not to make a copy of the
  2283:     list *)
  2284: val mapNoCopyList: ('a -> 'a list) -> 'a list -> 'a list
  2285: 
  2286: (** sm: return true if the first is a prefix of the second string *)
  2287: val startsWith: string -> string -> bool
  2288: 
  2289: 
  2290: (** {b An Interpreter for constructing CIL constructs} *)
  2291: 
  2292: (** The type of argument for the interpreter *)
  2293: type formatArg =
  2294:     Fe of exp
  2295:   | Feo of exp option  (** For array lengths *)
  2296:   | Fu of unop
  2297:   | Fb of binop
  2298:   | Fk of ikind
  2299:   | FE of exp list (** For arguments in a function call *)
  2300:   | Ff of (string * typ * attributes) (** For a formal argument *)
  2301:   | FF of (string * typ * attributes) list (** For formal argument lists *)
  2302:   | Fva of bool (** For the ellipsis in a function type *)
  2303:   | Fv of varinfo
  2304:   | Fl of lval
  2305:   | Flo of lval option
  2306: 
  2307:   | Fo of offset
  2308: 
  2309:   | Fc of compinfo
  2310:   | Fi of instr
  2311:   | FI of instr list
  2312:   | Ft of typ
  2313:   | Fd of int
  2314:   | Fg of string
  2315:   | Fs of stmt
  2316:   | FS of stmt list
  2317:   | FA of attributes
  2318: 
  2319:   | Fp of attrparam
  2320:   | FP of attrparam list
  2321: 
  2322:   | FX of string
  2323: 
  2324: 
  2325: (** Flx_cil_pretty-prints a format arg *)
  2326: val d_formatarg: unit -> formatArg -> Flx_cil_pretty.doc
  2327: 
End ocaml section to src/flx_cil_cil.mli[1]
Start ocaml section to src/flx_cil_cilutil.mli[1 /1 ]
     1: # 9328 "./lpsrc/flx_cil.ipk"
     2: 
     3: val doFlx_cil_check : bool ref
     4: val logCalls : bool ref
     5: val logWrites : bool ref
     6: val doPartial : bool ref
     7: val doSimpleMem : bool ref
     8: val doOneRet : bool ref
     9: val doStackGuard : bool ref
    10: val doHeapify : bool ref
    11: val makeCFG : bool ref
    12: val printFlx_cil_stats : bool ref
    13: val sliceGlobal : bool ref
    14: val printStages : bool ref
    15: val doCxxPP : bool ref
    16: val libDir : string ref
    17: 
End ocaml section to src/flx_cil_cilutil.mli[1]
Start ocaml section to src/flx_cil_cilutil.ml[1 /1 ]
     1: # 9346 "./lpsrc/flx_cil.ipk"
     2: 
     3: (* Keep here the globally-visible flags *)
     4: let doFlx_cil_check= ref false   (* Whether to check CIL *)
     5: 
     6: let logCalls = ref false (* Whether to produce a log with all the function
     7:                           * calls made *)
     8: let logWrites = ref false (* Whether to produce a log with all the mem
     9:                           * writes made *)
    10: let doPartial = ref false (* Whether to do partial evaluation and constant
    11:                           * folding *)
    12: let doSimpleMem = ref false (* reduce complex memory expressions so that
    13:                           * they contain at most one lval *)
    14: let doOneRet = ref false (* make a functions have at most one 'return' *)
    15: let doStackGuard = ref false (* instrument function calls and returns to
    16: maintain a separate stack for return addresses *)
    17: let doHeapify = ref false (* move stack-allocated arrays to the heap *)
    18: let makeCFG = ref false (* turn the input CIL file into something more like
    19:                           * a CFG *)
    20: let printFlx_cil_stats = ref false
    21: 
    22: (* when 'sliceGlobal' is set, then when 'rmtmps' runs, only globals*)
    23: (* marked with #pragma cilnoremove(whatever) are kept; when used with *)
    24: (* cilly.asm.exe, the effect is to slice the input on the noremove symbols *)
    25: let sliceGlobal = ref false
    26: 
    27: 
    28: let printStages = ref false
    29: 
    30: 
    31: let doCxxPP = ref false
    32: 
    33: let libDir = ref ""
    34: 
End ocaml section to src/flx_cil_cilutil.ml[1]
Start ocaml section to src/flx_cil_clist.ml[1 /1 ]
     1: # 9381 "./lpsrc/flx_cil.ipk"
     2: 
     3: open Flx_cil_pretty
     4: open Flx_cil_trace
     5: 
     6: (* We often need to concatenate sequences and using lists for this purpose is
     7:  * expensive. So we define a kind of "concatenable lists" that are easier to
     8:  * concatenate *)
     9: type 'a clist =
    10:   | CList of 'a list             (* This is the only representation for empty
    11:                                   * *)
    12:   | CConsL of 'a * 'a clist
    13:   | CConsR of 'a clist * 'a
    14:   | CSeq  of 'a clist * 'a clist (* We concatenate only two of them at this
    15:                                   * time. Neither is CEmpty. To be sure
    16:                                   * always use append to make these  *)
    17: 
    18: let rec listifyOnto (tail: 'a list) = function
    19:     CList l -> l @ tail
    20:   | CConsL (x, l) -> x :: listifyOnto tail l
    21:   | CConsR (l, x) -> listifyOnto (x :: tail) l
    22:   | CSeq (l1, l2) -> listifyOnto (listifyOnto tail l2) l1
    23: 
    24: let toList l = listifyOnto [] l
    25: let fromList l = CList l
    26: 
    27: 
    28: let single x = CList [x]
    29: let empty = CList []
    30: 
    31: let checkBeforeAppend  (l1: 'a clist) (l2: 'a clist) : bool =
    32:   l1 != l2 || l1 = (CList [])
    33: 
    34: let append l1 l2 =
    35:   if l1 = CList [] then l2 else
    36:   if l2 = CList [] then l1 else
    37:   begin
    38:     if l1 == l2 then
    39:       raise (Failure "You should not use Flx_cil_clist.append to double a list");
    40:     CSeq (l1, l2)
    41:   end
    42: 
    43: let rec length (acc: int) = function
    44:     CList l -> acc + (List.length l)
    45:   | CConsL (x, l) -> length (acc + 1) l
    46:   | CConsR (l, _) -> length (acc + 1) l
    47:   | CSeq (l1, l2) -> length (length acc l1) l2
    48: let length l = length 0 l  (* The external version *)
    49: 
    50: let map (f: 'a -> 'b) (l: 'a clist) : 'b clist =
    51:   let rec loop = function
    52:       CList l -> CList (List.map f l)
    53:     | CConsL (x, l) -> let x' = f x in CConsL (x', loop l)
    54:     | CConsR (l, x) -> let l' = loop l in CConsR (l', f x)
    55:     | CSeq (l1, l2) -> let l1' = loop l1 in CSeq (l1', loop l2)
    56:   in
    57:   loop l
    58: 
    59: 
    60: let fold_left (f: 'acc -> 'a -> 'acc) (start: 'acc) (l: 'a clist) =
    61:   let rec loop (start: 'acc) = function
    62:       CList l -> List.fold_left f start l
    63:     | CConsL (x, l) -> loop (f start x) l
    64:     | CConsR (l, x) -> let res = loop start l in f res x
    65:     | CSeq (l1, l2) ->
    66:         let res1 = loop start l1 in
    67:         loop res1 l2
    68:   in
    69:   loop start l
    70: 
    71: let iter (f: 'a -> unit) (l: 'a clist) : unit =
    72:   let rec loop = function
    73:       CList l -> List.iter f l
    74:     | CConsL (x, l) -> f x; loop l
    75:     | CConsR (l, x) -> loop l; f x
    76:     | CSeq (l1, l2) -> loop l1; loop l2
    77:   in
    78:   loop l
    79: 
    80: 
    81: let rec rev = function
    82:     CList l -> CList (List.rev l)
    83:   | CConsL (x, l) -> CConsR (rev l, x)
    84:   | CConsR (l, x) -> CConsL (x, rev l)
    85:   | CSeq (l1, l2) -> CSeq (rev l2, rev l1)
    86: 
    87: 
    88: let docCList (sep: doc) (doone: 'a -> doc) () (dl: 'a clist) =
    89:   fold_left
    90:     (fun (acc: doc) (elem: 'a) ->
    91:       let elemd = doone elem in
    92:       if acc == nil then elemd else acc ++ sep ++ elemd)
    93:     nil
    94:     dl
    95: 
    96: 
    97: (* let debugFlx_cil_check (lst: 'a clist) : unit =*)
    98: (*   (* use a hashtable to store values encountered *)*)
    99: (*   let tbl : 'a bool H.t = (H.create 13) in*)
   100: 
   101: (*   letrec recurse (node: 'a clist) =*)
   102: (*     (* have we seen*)*)
   103: 
   104: (*     match node with*)
   105: (*     | CList*)
   106: 
   107: 
   108: (* --------------- testing ----------------- *)
   109: type boxedInt =
   110:   | BI of int
   111:   | SomethingElse
   112: 
   113: let d_boxedInt () b =
   114:   match b with
   115:   | BI(i) -> (dprintf "%d" i)
   116:   | SomethingElse -> (text "somethingElse")
   117: 
   118: 
   119: (* sm: some simple tests of CLists *)
   120: let testCList () : unit =
   121: begin
   122:   (trace "sm" (dprintf "in testCList\n"));
   123: 
   124:   let clist1 = (fromList [BI(1); BI(2); BI(3)]) in
   125:   (trace "sm" (dprintf "length of clist1 is %d\n"
   126:                        (length clist1) ));
   127: 
   128:   let flattened = (toList clist1) in
   129:   (trace "sm" (dprintf "flattened: %a\n"
   130:                        (docList (chr ',' ++ break) (d_boxedInt ()))
   131:                        flattened));
   132: 
   133: 
   134: end
End ocaml section to src/flx_cil_clist.ml[1]
Start ocaml section to src/flx_cil_clist.mli[1 /1 ]
     1: # 9516 "./lpsrc/flx_cil.ipk"
     2: 
     3: (** Flx_cil_utilities for managing "concatenable lists" (clists). We often need to
     4:     concatenate sequences, and using lists for this purpose is expensive. This
     5:     module provides routines to manage such lists more efficiently. In this
     6:     model, we never do cons or append explicitly. Instead we maintain
     7:     the elements of the list in a special data structure. Routines are provided
     8:     to convert to/from ordinary lists, and carry out common list operations.*)
     9: 
    10: (** The clist datatype. A clist can be an ordinary list, or a clist preceded
    11:     or followed by an element, or two clists implicitly appended together*)
    12: type 'a clist =
    13:   | CList of 'a list             (** The only representation for the empty
    14:                                      list. Try to use sparingly.  *)
    15:   | CConsL of 'a * 'a clist      (** Do not use this a lot because scanning
    16:                                    * it is not tail recursive *)
    17:   | CConsR of 'a clist * 'a
    18:   | CSeq of 'a clist * 'a clist (** We concatenate only two of them at this
    19:                                     time. Neither is the empty clist. To be
    20:                                     sure always use append to make these *)
    21: 
    22: 
    23: (** Convert a clist to an ordinary list *)
    24: val toList: 'a clist -> 'a list
    25: 
    26: (** Convert an ordinary list to a clist *)
    27: val fromList: 'a list -> 'a clist
    28: 
    29: (** Create a clist containing one element *)
    30: val single: 'a -> 'a clist
    31: 
    32: (** The empty clist *)
    33: val empty: 'a clist
    34: 
    35: 
    36: (** Append two clists *)
    37: val append: 'a clist -> 'a clist -> 'a clist
    38: 
    39: (** A useful check to assert before an append. It checks that the two lists
    40:  * are not identically the same (Except if they are both empty) *)
    41: val checkBeforeAppend: 'a clist -> 'a clist -> bool
    42: 
    43: (** Find the length of a clist *)
    44: val length: 'a clist -> int
    45: 
    46: (** Map a function over a clist. Returns another clist *)
    47: val map: ('a -> 'b) -> 'a clist -> 'b clist
    48: 
    49: 
    50: (** A version of fold_left that works on clists *)
    51: val fold_left: ('acc -> 'a -> 'acc) -> 'acc -> 'a clist -> 'acc
    52: 
    53: (** A version of iter that works on clists *)
    54: val iter: ('a -> unit) -> 'a clist -> unit
    55: 
    56: (** Reverse a clist *)
    57: val rev: 'a clist -> 'a clist
    58: 
    59: (** A document for printing a clist (similar to [docList]) *)
    60: val docCList:
    61:     Flx_cil_pretty.doc -> ('a -> Flx_cil_pretty.doc) -> unit -> 'a clist -> Flx_cil_pretty.doc
    62: 
End ocaml section to src/flx_cil_clist.mli[1]
Start ocaml section to src/flx_cil_formatcil.ml[1 /1 ]
     1: # 9579 "./lpsrc/flx_cil.ipk"
     2: open Flx_cil_cil
     3: open Flx_cil_pretty
     4: open Flx_cil_trace      (* sm: 'trace' function *)
     5: module E = Flx_cil_errormsg
     6: module H = Hashtbl
     7: 
     8: let noMemoize = ref false
     9: 
    10: let expMemoTable :
    11:     (string, (((string * formatArg) list -> exp) *
    12:                (exp -> formatArg list option))) H.t = H.create 23
    13: 
    14: let typeMemoTable :
    15:     (string, (((string * formatArg) list -> typ) *
    16:                (typ -> formatArg list option))) H.t = H.create 23
    17: 
    18: let lvalMemoTable :
    19:     (string, (((string * formatArg) list -> lval) *
    20:                (lval -> formatArg list option))) H.t = H.create 23
    21: 
    22: let instrMemoTable :
    23:     (string, ((location -> (string * formatArg) list -> instr) *
    24:                (instr -> formatArg list option))) H.t = H.create 23
    25: 
    26: let stmtMemoTable :
    27:     (string, ((string -> typ -> varinfo) ->
    28:               location ->
    29:               (string * formatArg) list -> stmt)) H.t = H.create 23
    30: 
    31: let stmtsMemoTable :
    32:     (string, ((string -> typ -> varinfo) ->
    33:               location ->
    34:               (string * formatArg) list -> stmt list)) H.t = H.create 23
    35: 
    36: 
    37: let doParse (prog: string)
    38:             (theParser: (Lexing.lexbuf -> Flx_cil_formatparse.token)
    39:                                           -> Lexing.lexbuf -> 'a)
    40:             (memoTable: (string, 'a) H.t) : 'a =
    41:   try
    42:     if !noMemoize then raise Not_found else
    43:     H.find memoTable prog
    44:   with Not_found -> begin
    45:     let lexbuf = Flx_cil_formatlex.init prog in
    46:     try
    47:       Flx_cil_formatparse.initialize Flx_cil_formatlex.initial lexbuf;
    48:       let res = theParser Flx_cil_formatlex.initial lexbuf in
    49:       H.add memoTable prog res;
    50:       Flx_cil_formatlex.finish ();
    51:       res
    52:     with Parsing.Parse_error -> begin
    53:       Flx_cil_formatlex.finish ();
    54:       E.s (E.error "Parsing error: %s" prog)
    55:     end
    56:     | e -> begin
    57:         ignore (E.log "Caught %s while parsing\n" (Printexc.to_string e));
    58:         Flx_cil_formatlex.finish ();
    59:         raise e
    60:     end
    61:   end
    62: 
    63: 
    64: let cExp (prog: string) : (string * formatArg) list -> exp =
    65:   let cf = doParse prog Flx_cil_formatparse.expression expMemoTable in
    66:   (fst cf)
    67: 
    68: let cLval (prog: string) : (string * formatArg) list -> lval =
    69:   let cf = doParse prog Flx_cil_formatparse.lval lvalMemoTable in
    70:   (fst cf)
    71: 
    72: let cType (prog: string) : (string * formatArg) list -> typ =
    73:   let cf = doParse prog Flx_cil_formatparse.typename typeMemoTable in
    74:   (fst cf)
    75: 
    76: let cInstr (prog: string) : location -> (string * formatArg) list -> instr =
    77:   let cf = doParse prog Flx_cil_formatparse.instr instrMemoTable in
    78:   (fst cf)
    79: 
    80: let cStmt (prog: string) : (string -> typ -> varinfo) ->
    81:                            location -> (string * formatArg) list -> stmt =
    82:   let cf = doParse prog Flx_cil_formatparse.stmt stmtMemoTable in
    83:   cf
    84: 
    85: let cStmts (prog: string) :
    86:     (string -> typ -> varinfo) ->
    87:     location -> (string * formatArg) list -> stmt list =
    88:   let cf = doParse prog Flx_cil_formatparse.stmt_list stmtsMemoTable in
    89:   cf
    90: 
    91: 
    92: 
    93: (* Match an expression *)
    94: let dExp (prog: string) : exp -> formatArg list option =
    95:   let df = doParse prog Flx_cil_formatparse.expression expMemoTable in
    96:   (snd df)
    97: 
    98: (* Match an lvalue *)
    99: let dLval (prog: string) : lval -> formatArg list option =
   100:   let df = doParse prog Flx_cil_formatparse.lval lvalMemoTable in
   101:   (snd df)
   102: 
   103: 
   104: (* Match a type *)
   105: let dType (prog: string) : typ -> formatArg list option =
   106:   let df = doParse prog Flx_cil_formatparse.typename typeMemoTable in
   107:   (snd df)
   108: 
   109: 
   110: 
   111: (* Match an instruction *)
   112: let dInstr (prog: string) : instr -> formatArg list option =
   113:   let df = doParse prog Flx_cil_formatparse.instr instrMemoTable in
   114:   (snd df)
   115: 
   116: 
   117: let test () =
   118:   (* Construct a dummy function *)
   119:   let func = emptyFunction "test_formatcil" in
   120:   (* Construct a few varinfo *)
   121:   let res = makeLocalVar func "res" (TPtr(intType, [])) in
   122:   let arr = makeLocalVar func "arr" (TArray(TPtr(intType, []),
   123:                                             Some (integer 8), [])) in
   124:   let fptr = makeLocalVar func "fptr"
   125:       (TPtr(TFun(intType, None, false, []), [])) in
   126:   (* Construct an instruction *)
   127:   let makeInstr () =
   128:     Call(Some (var res),
   129:          Lval (Mem (CastE(TPtr(TFun(TPtr(intType, []),
   130:                                     Some [ ("", intType, []);
   131:                                            ("a2", TPtr(intType, []), []);
   132:                                            ("a3", TPtr(TPtr(intType, []),
   133:                                                        []), []) ],
   134:                                     false, []), []),
   135:                           Lval (var fptr))),
   136:                NoOffset),
   137:          [  ], locUnknown)
   138:   in
   139:   let times = 100000 in
   140:   (* Make the instruction the regular way *)
   141:   Flx_cil_stats.time "make instruction regular"
   142:     (fun _ -> for i = 0 to times do ignore (makeInstr ()) done)
   143:     ();
   144:   (* Now make the instruction interpreted *)
   145:   noMemoize := true;
   146:   Flx_cil_stats.time "make instruction interpreted"
   147:     (fun _ -> for i = 0 to times do
   148:       let ins =
   149:         cInstr "%v:res = (* ((int * (*)(int, int * a2, int * * a3))%v:fptr))();"
   150:           locUnknown [ ("res", Fv res);
   151:                        ("fptr", Fv fptr) ]
   152:       in
   153:       ()
   154:     done)
   155:     ();
   156:   (* Now make the instruction interpreted with memoization *)
   157:   noMemoize := false;
   158:   Flx_cil_stats.time "make instruction interpreted memoized"
   159:     (fun _ -> for i = 0 to times do
   160:       let ins =
   161:         cInstr "%v:res = (* ((int * (*)(int, int * a2, int * * a3))%v:fptr))();"
   162:           locUnknown [ ("res", Fv res); ("fptr", Fv fptr) ]
   163:       in
   164:       ()
   165:     done)
   166:     ();
   167:   (* Now make the instruction interpreted with partial application *)
   168:   let partInstr =
   169:     cInstr "%v:res = (* ((int * (*)(int, int * a2, int * * a3))%v:fptr))();" in
   170:   Flx_cil_stats.time "make instruction interpreted partial"
   171:     (fun _ -> for i = 0 to times do
   172:       let ins =
   173:         partInstr
   174:           locUnknown [ ("res", Fv res); ("fptr", Fv fptr) ]
   175:       in
   176:       ()
   177:     done)
   178:     ();
   179: 
   180:   ()
   181: 
   182: 
End ocaml section to src/flx_cil_formatcil.ml[1]
Start ocaml section to src/flx_cil_formatcil.mli[1 /1 ]
     1: # 9762 "./lpsrc/flx_cil.ipk"
     2: 
     3: (** {b An Interpreter for constructing CIL constructs} *)
     4: 
     5: 
     6: (** Constructs an expression based on the program and the list of arguments.
     7:  * Each argument consists of a name followed by the actual data. This
     8:  * argument will be placed instead of occurrences of "%v:name" in the pattern
     9:  * (where the "v" is dependent on the type of the data). The parsing of the
    10:  * string is memoized. * Only the first expression is parsed. *)
    11: val cExp: string -> (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.exp
    12: 
    13: (** Constructs an lval based on the program and the list of arguments.
    14:  * Only the first lvalue is parsed.
    15:  * The parsing of the string is memoized. *)
    16: val cLval: string -> (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.lval
    17: 
    18: (** Constructs a type based on the program and the list of arguments.
    19:  * Only the first type is parsed.
    20:  * The parsing of the string is memoized. *)
    21: val cType: string -> (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.typ
    22: 
    23: 
    24: (** Constructs an instruction based on the program and the list of arguments.
    25:  * Only the first instruction is parsed.
    26:  * The parsing of the string is memoized. *)
    27: val cInstr: string -> Flx_cil_cil.location ->
    28:                       (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.instr
    29: 
    30: (* Constructs a statement based on the program and the list of arguments. We
    31:  * also pass a function that can be used to make new varinfo's for the
    32:  * declared variables, and a location to be used for the statements. Only the
    33:  * first statement is parsed. The parsing of the string is memoized. *)
    34: val cStmt: string ->
    35:            (string -> Flx_cil_cil.typ -> Flx_cil_cil.varinfo) ->
    36:            Flx_cil_cil.location -> (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.stmt
    37: 
    38: (** Constructs a list of statements *)
    39: val cStmts: string ->
    40:             (string -> Flx_cil_cil.typ -> Flx_cil_cil.varinfo) ->
    41:             Flx_cil_cil.location -> (string * Flx_cil_cil.formatArg) list ->
    42:             Flx_cil_cil.stmt list
    43: 
    44: (** Deconstructs an expression based on the program. Produces an optional
    45:  * list of format arguments. The parsing of the string is memoized. *)
    46: val dExp: string -> Flx_cil_cil.exp -> Flx_cil_cil.formatArg list option
    47: 
    48: (** Deconstructs an lval based on the program. Produces an optional
    49:  * list of format arguments. The parsing of the string is memoized. *)
    50: val dLval: string -> Flx_cil_cil.lval -> Flx_cil_cil.formatArg list option
    51: 
    52: 
    53: (** Deconstructs a type based on the program. Produces an optional list of
    54:  * format arguments. The parsing of the string is memoized. *)
    55: val dType: string -> Flx_cil_cil.typ -> Flx_cil_cil.formatArg list option
    56: 
    57: 
    58: (** Deconstructs an instruction based on the program. Produces an optional
    59:  * list of format arguments. The parsing of the string is memoized. *)
    60: val dInstr: string -> Flx_cil_cil.instr -> Flx_cil_cil.formatArg list option
    61: 
    62: 
    63: (** If set then will not memoize the parsed patterns *)
    64: val noMemoize: bool ref
    65: 
    66: (** Just a testing function *)
    67: val test: unit -> unit
    68: 
End ocaml section to src/flx_cil_formatcil.mli[1]
Start ocaml section to src/flx_cil_formatlex.mli[1 /1 ]
     1: # 9831 "./lpsrc/flx_cil.ipk"
     2: 
     3: exception Eof
     4: exception InternalError of string
     5: 
     6: val keywords : (string, Flx_cil_formatparse.token) Hashtbl.t
     7: val scan_ident : string -> Flx_cil_formatparse.token
     8: val init : prog:string -> Lexing.lexbuf
     9: val finish : unit -> unit
    10: val error : string -> 'a
    11: val scan_escape : string -> string
    12: val get_value : char -> int
    13: val scan_hex_escape : string -> string
    14: val scan_oct_escape : string -> string
    15: val wbtowc : string -> string
    16: val wstr_to_warray : string -> string
    17: val getArgName : Lexing.lexbuf -> int -> string
    18: val initial : Lexing.lexbuf -> Flx_cil_formatparse.token
    19: val comment : Lexing.lexbuf -> unit
    20: val endline : Lexing.lexbuf -> Flx_cil_formatparse.token
    21: 
End ocaml section to src/flx_cil_formatlex.mli[1]
Start data section to src/flx_cil_formatlex.mll[1 /1 ]
     1: (* A simple lexical analyzer for constructing CIL based on format strings *)
     2: {
     3: open Flx_cil_formatparse
     4: exception Eof
     5: exception InternalError of string
     6: module H = Hashtbl
     7: module E = Flx_cil_errormsg
     8: (*
     9: ** Keyword hashtable
    10: *)
    11: let keywords = H.create 211
    12: 
    13: (*
    14: ** Useful primitives
    15: *)
    16: let scan_ident id =
    17:   try H.find keywords id
    18:   with Not_found -> IDENT id  (* default to variable name *)
    19: 
    20: (*
    21: ** Buffer processor
    22: *)
    23: 
    24: 
    25: let init ~(prog: string) : Lexing.lexbuf =
    26:   H.clear keywords;
    27:   Flx_cil_lexerhack.currentPattern := prog;
    28:   List.iter
    29:     (fun (key, token) -> H.add keywords key token)
    30:     [ ("const", CONST); ("__const", CONST); ("__const__", CONST);
    31:       ("static", STATIC);
    32:       ("extern", EXTERN);
    33:       ("long", LONG);
    34:       ("short", SHORT);
    35:       ("signed", SIGNED);
    36:       ("unsigned", UNSIGNED);
    37:       ("volatile", VOLATILE);
    38:       ("char", CHAR);
    39:       ("int", INT);
    40:       ("_Imaginary", IMAGINARY);
    41:       ("_Complex", COMPLEX);
    42:       ("_Bool", BOOL);
    43:       ("float", FLOAT);
    44:       ("double", DOUBLE);
    45:       ("void", VOID);
    46:       ("enum", ENUM);
    47:       ("struct", STRUCT);
    48:       ("typedef", TYPEDEF);
    49:       ("union", UNION);
    50:       ("break", BREAK);
    51:       ("continue", CONTINUE);
    52:       ("goto", GOTO);
    53:       ("return", RETURN);
    54:       ("switch", SWITCH);
    55:       ("case", CASE);
    56:       ("default", DEFAULT);
    57:       ("while", WHILE);
    58:       ("do", DO);
    59:       ("for", FOR);
    60:       ("if", IF);
    61:       ("else", ELSE);
    62:       ("__attribute__", ATTRIBUTE); ("__attribute", ATTRIBUTE);
    63:       ("__int64", INT64);
    64:       ("__builtin_va_arg", BUILTIN_VA_ARG);
    65:     ];
    66:   E.startParsingFromString prog
    67: 
    68: let finish () =
    69:   E.finishParsing ()
    70: 
    71: (*** Error handling ***)
    72: let error msg =
    73:   E.parse_error msg
    74: 
    75: 
    76: (*** escape character management ***)
    77: let scan_escape str =
    78:   match str with
    79:     "n" -> "\n"
    80:   | "r" -> "\r"
    81:   | "t" -> "\t"
    82:   | "b" -> "\b"
    83:   | "f" -> "\012"  (* ASCII code 12 *)
    84:   | "v" -> "\011"  (* ASCII code 11 *)
    85:   | "a" -> "\007"  (* ASCII code 7 *)
    86:   | "e" -> "\027"  (* ASCII code 27. This is a GCC extension *)
    87:   | _ -> str
    88: 
    89: let get_value chr =
    90:   match chr with
    91:     '0'..'9' -> (Char.code chr) - (Char.code '0')
    92:   | 'a'..'z' -> (Char.code chr) - (Char.code 'a') + 10
    93:   | 'A'..'Z' -> (Char.code chr) - (Char.code 'A') + 10
    94:   | _ -> 0
    95: let scan_hex_escape str =
    96:   String.make 1 (Char.chr (
    97:                  (get_value (String.get str 0)) * 16
    98:                    + (get_value (String.get str 1))
    99:                    ))
   100: let scan_oct_escape str =
   101:   (* weimer: wide-character constants like L'\400' may be bigger than
   102:    * 256 (in fact, may be up to 511), so Char.chr cannot be used directly *)
   103:   let the_value = (get_value (String.get str 0)) * 64
   104:                    + (get_value (String.get str 1)) * 8
   105:                    + (get_value (String.get str 2)) in
   106:   if the_value < 256 then String.make 1 (Char.chr the_value )
   107:   else (String.make 1 (Char.chr (the_value / 256))) ^
   108:        (String.make 1 (Char.chr (the_value mod 256)))
   109: 
   110: (* ISO standard locale-specific function to convert a wide character
   111:  * into a sequence of normal characters. Here we work on strings.
   112:  * We convert L"Hi" to "H\000i\000" *)
   113: let wbtowc wstr =
   114:   let len = String.length wstr in
   115:   let dest = String.make (len * 2) '\000' in
   116:   for i = 0 to len-1 do
   117:     dest.[i*2] <- wstr.[i] ;
   118:   done ;
   119:   dest
   120: 
   121: (* This function converst the "Hi" in L"Hi" to { L'H', L'i', L'\0' } *)
   122: let wstr_to_warray wstr =
   123:   let len = String.length wstr in
   124:   let res = ref "{ " in
   125:   for i = 0 to len-1 do
   126:     res := !res ^ (Printf.sprintf "L'%c', " wstr.[i])
   127:   done ;
   128:   res := !res ^ "}" ;
   129:   !res
   130: 
   131: let getArgName (l: Lexing.lexbuf) (prefixlen: int) =
   132:   let lexeme = Lexing.lexeme l in
   133:   let ll = String.length lexeme in
   134:   if  ll > prefixlen then
   135:     String.sub lexeme (prefixlen + 1) (ll - prefixlen - 1)
   136:   else
   137:     ""
   138: }
   139: 
   140: let decdigit = ['0'-'9']
   141: let octdigit = ['0'-'7']
   142: let hexdigit = ['0'-'9' 'a'-'f' 'A'-'F']
   143: let letter = ['a'- 'z' 'A'-'Z']
   144: 
   145: let floatsuffix = ['f' 'F' 'l' 'L']
   146: 
   147: let usuffix = ['u' 'U']
   148: let lsuffix = "l"|"L"|"ll"|"LL"
   149: let intsuffix = lsuffix | usuffix | usuffix lsuffix | lsuffix usuffix
   150: 
   151: let intnum = decdigit+ intsuffix?
   152: let octnum = '0' octdigit+ intsuffix?
   153: let hexnum = '0' ['x' 'X'] hexdigit+ intsuffix?
   154: 
   155: let exponent = ['e' 'E']['+' '-']? decdigit+
   156: let fraction  = '.' decdigit+
   157: let floatraw = (intnum? fraction)
   158:                         |(intnum exponent)
   159:                         |(intnum? fraction exponent)
   160:                         |(intnum '.')
   161:                         |(intnum '.' exponent)
   162: let floatnum = floatraw floatsuffix?
   163: 
   164: let ident = (letter|'_')(letter|decdigit|'_')*
   165: let attribident = (letter|'_')(letter|decdigit|'_'|':')
   166: let blank = [' ' '\t' '\012' '\r']
   167: let escape = '\\' _
   168: let hex_escape = '\\' ['x' 'X'] hexdigit hexdigit
   169: let oct_escape = '\\' octdigit  octdigit octdigit
   170: 
   171: 
   172: (* The arguments are of the form %l:foo *)
   173: let argname = ':' ident
   174: 
   175: rule initial =
   176:         parse   blank                   { initial lexbuf}
   177: |               "/*"                    { let _ = comment lexbuf in
   178:                                           initial lexbuf}
   179: |               "//"                    { endline lexbuf }
   180: |               "\n"                    { E.newline (); initial lexbuf}
   181: |               floatnum                {CST_FLOAT (Lexing.lexeme lexbuf)}
   182: |               hexnum                  {CST_INT (Lexing.lexeme lexbuf)}
   183: |               octnum                  {CST_INT (Lexing.lexeme lexbuf)}
   184: |               intnum                  {CST_INT (Lexing.lexeme lexbuf)}
   185: |               "..."                   {ELLIPSIS}
   186: |               "-="                    {MINUS_EQ}
   187: |               "+="                    {PLUS_EQ}
   188: |               "*="                    {STAR_EQ}
   189: |               "<<"                    {INF_INF}
   190: |               ">>"                    {SUP_SUP}
   191: |               "=="                    {EQ_EQ}
   192: |               "!="                    {EXCLAM_EQ}
   193: |               "<="                    {INF_EQ}
   194: |               ">="                    {SUP_EQ}
   195: |               "="                     {EQ}
   196: |               "<"                     {INF}
   197: |               ">"                     {SUP}
   198: |               "++"                    {PLUS_PLUS}
   199: |               "--"                    {MINUS_MINUS}
   200: |               "->"                    {ARROW}
   201: |               '+'                     {PLUS}
   202: |               '-'                     {MINUS}
   203: |               '*'                     {STAR}
   204: |               '/'                     {SLASH}
   205: |               '!'                     {EXCLAM}
   206: |               '&'                     {AND}
   207: |               '|'                     {PIPE}
   208: |               '^'                     {CIRC}
   209: |               '~'                     {TILDE}
   210: |               '['                     {LBRACKET}
   211: |               ']'                     {RBRACKET}
   212: |               '{'                     {LBRACE}
   213: |               '}'                     {RBRACE}
   214: |               '('                     {LPAREN}
   215: |               ')'                     {RPAREN}
   216: |               ';'                     {SEMICOLON}
   217: |               ','                     {COMMA}
   218: |               '.'                     {DOT}
   219: |               ':'                     {COLON}
   220: |               '?'                     {QUEST}
   221: |               "sizeof"                {SIZEOF}
   222: 
   223: |               "%eo" argname           {ARG_eo (getArgName lexbuf 3) }
   224: |               "%e"  argname           {ARG_e  (getArgName lexbuf 2) }
   225: |               "%E"  argname           {ARG_E  (getArgName lexbuf 2) }
   226: |               "%u"  argname           {ARG_u  (getArgName lexbuf 2) }
   227: |               "%b"  argname           {ARG_b  (getArgName lexbuf 2) }
   228: |               "%t"  argname           {ARG_t  (getArgName lexbuf 2) }
   229: |               "%d"  argname           {ARG_d  (getArgName lexbuf 2) }
   230: |               "%lo" argname           {ARG_lo (getArgName lexbuf 3) }
   231: |               "%l"  argname           {ARG_l  (getArgName lexbuf 2) }
   232: |               "%i"  argname           {ARG_i  (getArgName lexbuf 2) }
   233: |               "%I"  argname           {ARG_I  (getArgName lexbuf 2) }
   234: |               "%o"  argname           {ARG_o  (getArgName lexbuf 2) }
   235: |               "%va" argname           {ARG_va (getArgName lexbuf 3) }
   236: |               "%v"  argname           {ARG_v  (getArgName lexbuf 2) }
   237: |               "%k"  argname           {ARG_k  (getArgName lexbuf 2) }
   238: |               "%f"  argname           {ARG_f  (getArgName lexbuf 2) }
   239: |               "%F"  argname           {ARG_F  (getArgName lexbuf 2) }
   240: |               "%p"  argname           {ARG_p  (getArgName lexbuf 2) }
   241: |               "%P"  argname           {ARG_P  (getArgName lexbuf 2) }
   242: |               "%s"  argname           {ARG_s  (getArgName lexbuf 2) }
   243: |               "%S"  argname           {ARG_S  (getArgName lexbuf 2) }
   244: |               "%g"  argname           {ARG_g  (getArgName lexbuf 2) }
   245: |               "%A"  argname           {ARG_A  (getArgName lexbuf 2) }
   246: |               "%c"  argname           {ARG_c  (getArgName lexbuf 2) }
   247: 
   248: |               '%'                     {PERCENT}
   249: |               ident                   {scan_ident (Lexing.lexeme lexbuf)}
   250: |               eof                     {EOF}
   251: |               _                       {E.parse_error
   252:                                                 "Flx_cil_formatlex: Invalid symbol"
   253:                                                 (Lexing.lexeme_start lexbuf)
   254:                                                 (Lexing.lexeme_end lexbuf);
   255:                                          raise Parsing.Parse_error
   256:                                         }
   257: 
   258: and comment =
   259:     parse
   260:       "*/"                              { () }
   261: |     '\n'                              { E.newline (); comment lexbuf }
   262: |               _                       { comment lexbuf }
   263: 
   264: 
   265: and endline = parse
   266:         '\n'                    { E.newline (); initial lexbuf}
   267: |       _                       { endline lexbuf}
   268: 
   269: 
End data section to src/flx_cil_formatlex.mll[1]
Start ocaml section to src/flx_cil_formatparse.mli[1 /1 ]
     1: # 10124 "./lpsrc/flx_cil.ipk"
     2: 
     3: type token =
     4:     IDENT of string
     5:   | CST_CHAR of string
     6:   | CST_INT of string
     7:   | CST_FLOAT of string
     8:   | CST_STRING of string
     9:   | CST_WSTRING of string
    10:   | NAMED_TYPE of string
    11:   | EOF
    12:   | BOOL
    13:   | CHAR
    14:   | INT
    15:   | DOUBLE
    16:   | FLOAT
    17:   | COMPLEX
    18:   | IMAGINARY
    19:   | VOID
    20:   | INT64
    21:   | INT32
    22:   | ENUM
    23:   | STRUCT
    24:   | TYPEDEF
    25:   | UNION
    26:   | SIGNED
    27:   | UNSIGNED
    28:   | LONG
    29:   | SHORT
    30:   | VOLATILE
    31:   | EXTERN
    32:   | STATIC
    33:   | CONST
    34:   | RESTRICT
    35:   | AUTO
    36:   | REGISTER
    37:   | ARG_e of string
    38:   | ARG_eo of string
    39:   | ARG_E of string
    40:   | ARG_u of string
    41:   | ARG_b of string
    42:   | ARG_t of string
    43:   | ARG_d of string
    44:   | ARG_lo of string
    45:   | ARG_l of string
    46:   | ARG_i of string
    47:   | ARG_o of string
    48:   | ARG_va of string
    49:   | ARG_f of string
    50:   | ARG_F of string
    51:   | ARG_A of string
    52:   | ARG_v of string
    53:   | ARG_k of string
    54:   | ARG_c of string
    55:   | ARG_s of string
    56:   | ARG_p of string
    57:   | ARG_P of string
    58:   | ARG_I of string
    59:   | ARG_S of string
    60:   | ARG_g of string
    61:   | SIZEOF
    62:   | ALIGNOF
    63:   | EQ
    64:   | ARROW
    65:   | DOT
    66:   | EQ_EQ
    67:   | EXCLAM_EQ
    68:   | INF
    69:   | SUP
    70:   | INF_EQ
    71:   | SUP_EQ
    72:   | MINUS_EQ
    73:   | PLUS_EQ
    74:   | STAR_EQ
    75:   | PLUS
    76:   | MINUS
    77:   | STAR
    78:   | SLASH
    79:   | PERCENT
    80:   | TILDE
    81:   | AND
    82:   | PIPE
    83:   | CIRC
    84:   | EXCLAM
    85:   | AND_AND
    86:   | PIPE_PIPE
    87:   | INF_INF
    88:   | SUP_SUP
    89:   | PLUS_PLUS
    90:   | MINUS_MINUS
    91:   | RPAREN
    92:   | LPAREN
    93:   | RBRACE
    94:   | LBRACE
    95:   | LBRACKET
    96:   | RBRACKET
    97:   | COLON
    98:   | SEMICOLON
    99:   | COMMA
   100:   | ELLIPSIS
   101:   | QUEST
   102:   | BREAK
   103:   | CONTINUE
   104:   | GOTO
   105:   | RETURN
   106:   | SWITCH
   107:   | CASE
   108:   | DEFAULT
   109:   | WHILE
   110:   | DO
   111:   | FOR
   112:   | IF
   113:   | THEN
   114:   | ELSE
   115:   | ATTRIBUTE
   116:   | INLINE
   117:   | ASM
   118:   | TYPEOF
   119:   | FUNCTION__
   120:   | PRETTY_FUNCTION__
   121:   | LABEL__
   122:   | BUILTIN_VA_ARG
   123:   | BUILTIN_VA_LIST
   124:   | BLOCKATTRIBUTE
   125:   | DECLSPEC
   126:   | MSASM of string
   127:   | MSATTR of string
   128:   | PRAGMA
   129: 
   130: 
   131: val initialize : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> unit
   132: val expression :
   133:   (Lexing.lexbuf -> token) ->
   134:   Lexing.lexbuf ->
   135:   ((string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.exp) *
   136:   (Flx_cil_cil.exp -> Flx_cil_cil.formatArg list option)
   137: val typename :
   138:   (Lexing.lexbuf -> token) ->
   139:   Lexing.lexbuf ->
   140:   ((string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.typ) *
   141:   (Flx_cil_cil.typ -> Flx_cil_cil.formatArg list option)
   142: val offset :
   143:   (Lexing.lexbuf -> token) ->
   144:   Lexing.lexbuf ->
   145:   (Flx_cil_cil.typ ->
   146:    (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.offset) *
   147:   (Flx_cil_cil.offset -> Flx_cil_cil.formatArg list option)
   148: val lval :
   149:   (Lexing.lexbuf -> token) ->
   150:   Lexing.lexbuf ->
   151:   ((string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.lval) *
   152:   (Flx_cil_cil.lval -> Flx_cil_cil.formatArg list option)
   153: val instr :
   154:   (Lexing.lexbuf -> token) ->
   155:   Lexing.lexbuf ->
   156:   (Flx_cil_cil.location ->
   157:    (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.instr) *
   158:   (Flx_cil_cil.instr -> Flx_cil_cil.formatArg list option)
   159: val stmt :
   160:   (Lexing.lexbuf -> token) ->
   161:   Lexing.lexbuf ->
   162:   (string -> Flx_cil_cil.typ -> Flx_cil_cil.varinfo) ->
   163:   Flx_cil_cil.location ->
   164:   (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.stmt
   165: val stmt_list :
   166:   (Lexing.lexbuf -> token) ->
   167:   Lexing.lexbuf ->
   168:   (string -> Flx_cil_cil.typ -> Flx_cil_cil.varinfo) ->
   169:   Flx_cil_cil.location ->
   170:   (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.stmt list
   171: 
End ocaml section to src/flx_cil_formatparse.mli[1]
Start data section to src/flx_cil_formatparse.mly[1 /1 ]
     1: /*(* Parser for constructing CIL from format strings *)
     2: */
     3: %{
     4: open Flx_cil_cil
     5: open Flx_cil_pretty
     6: module E = Flx_cil_errormsg
     7: 
     8: let parse_error msg : 'a =           (* sm: c++-mode highlight hack: -> ' <- *)
     9:   E.hadErrors := true;
    10:   E.parse_error
    11:     msg
    12:     (Parsing.symbol_start ()) (Parsing.symbol_end ())
    13: 
    14: 
    15: let getArg (argname: string) (args: (string * formatArg) list) =
    16:   try
    17:     snd (List.find (fun (n, a) -> n = argname) args)
    18:   with _ ->
    19:     E.s (error "Pattern string %s does not have argument with name %s\n"
    20:            !Flx_cil_lexerhack.currentPattern argname)
    21: 
    22: let wrongArgType (which: string) (expected: string) (found: formatArg) =
    23:   E.s (bug "Expecting %s argument (%s) and found %a\n"
    24:          expected which d_formatarg found)
    25: 
    26: let doUnop (uo: unop) subexp =
    27:   ((fun args ->
    28:         let e = (fst subexp) args in
    29:         UnOp(uo, e, typeOf e)),
    30: 
    31:    (fun e -> match e with
    32:      UnOp(uo', e', _) when uo  = uo' -> (snd subexp) e'
    33:    | _ -> None))
    34: 
    35: let buildPlus e1 e2 : exp =
    36:   let t1 = typeOf e1 in
    37:   if isPointerType t1 then
    38:     BinOp(PlusPI, e1, e2, t1)
    39:   else
    40:     BinOp(PlusA, e1, e2, t1)
    41: 
    42: let buildMinus e1 e2 : exp =
    43:   let t1 = typeOf e1 in
    44:   let t2 = typeOf e2 in
    45:   if isPointerType t1 then
    46:     if isPointerType t2 then
    47:       BinOp(MinusPP, e1, e2, intType)
    48:     else
    49:       BinOp(MinusPI, e1, e2, t1)
    50:   else
    51:     BinOp(MinusA, e1, e2, t1)
    52: 
    53: let doBinop bop e1t e2t =
    54:   ((fun args ->
    55:     let e1 = (fst e1t) args in
    56:     let e2 = (fst e2t) args in
    57:     let t1 = typeOf e1 in
    58:     BinOp(bop, e1, e2, t1)),
    59: 
    60:    (fun e -> match e with
    61:      BinOp(bop', e1, e2, _) when bop' = bop -> begin
    62:        match (snd e1t) e1, (snd e2t) e2 with
    63:          Some m1, Some m2 -> Some (m1 @ m2)
    64:        | _, _ -> None
    65:      end
    66:    | _ -> None))
    67: 
    68: (* Flx_cil_check the equivalence of two format lists *)
    69: let rec checkSameFormat (fl1: formatArg list) (fl2: formatArg list) =
    70:   match fl1, fl2 with
    71:     [], [] -> true
    72:   | h1::t1, h2::t2 -> begin
    73:       let rec checkOffsetEq o1 o2 =
    74:         match o1, o2 with
    75:           NoOffset, NoOffset -> true
    76:         | Field(f1, o1'), Field(f2, o2') ->
    77:             f1.fname = f2.fname && checkOffsetEq o1' o2'
    78:         | Index(e1, o1'), Index(e2, o2') ->
    79:             checkOffsetEq o1' o2' && checkExpEq e1 e2
    80:         | _, _ -> false
    81: 
    82:       and checkExpEq e1 e2 =
    83:         match e1, e2 with
    84:           Const(CInt64(n1, _, _)), Const(CInt64(n2, _, _)) -> n1 = n2
    85:         | Lval l1, Lval l2 -> checkLvalEq l1 l2
    86:         | UnOp(uo1, e1, _), UnOp(uo2, e2, _) ->
    87:             uo1 = uo2 && checkExpEq e1 e2
    88:         | BinOp(bo1, e11, e12, _), BinOp(bo2, e21, e22, _) ->
    89:             bo1 = bo2 && checkExpEq e11 e21 && checkExpEq e21 e22
    90:         | AddrOf l1, AddrOf l2 -> checkLvalEq l1 l2
    91:         | StartOf l1, StartOf l2 -> checkLvalEq l1 l2
    92:         | SizeOf t1, SizeOf t2 -> typeSig t1 = typeSig t2
    93:         | _, _ ->
    94:             ignore (E.warn "checkSameFormat for Fe"); false
    95: 
    96:       and checkLvalEq l1 l2 =
    97:         match l1, l2 with
    98:           (Var v1, o1), (Var v2, o2) -> v1 == v2 && checkOffsetEq o1 o2
    99:         | (Mem e1, o1), (Mem e2, o2) ->
   100:             checkOffsetEq o1 o2 && checkExpEq e1 e2
   101:         | _, _ -> false
   102:       in
   103:       let hdeq =
   104:         match h1, h2 with
   105:           Fv v1, Fv v2 -> v1 == v2
   106:         | Fd n1, Fd n2 -> n1 = n2
   107:         | Fe e1, Fe e2 -> checkExpEq e1 e2
   108:         | Fi i1, Fi i2 -> ignore (E.warn "checkSameFormat for Fi"); false
   109:         | Ft t1, Ft t2 -> typeSig t1 = typeSig t2
   110:         | Fl l1, Fl l2 -> checkLvalEq l1 l2
   111:         | Fo o1, Fo o2 -> checkOffsetEq o1 o2
   112:         | Fc c1, Fc c2 -> c1 == c2
   113:         | _, _ -> false
   114:       in
   115:       hdeq || checkSameFormat t1 t2
   116:   end
   117:   | _, _ -> false
   118: 
   119: let matchBinopEq (bopeq: binop -> bool) lvt et =
   120:   (fun i -> match i with
   121:     Set (lv, BinOp(bop', Lval (lv'), e', _), l) when bopeq bop' -> begin
   122:       match lvt lv, lvt lv', et e' with
   123:         Some m1, Some m1', Some m2 ->
   124:           (* Must check that m1 and m2 are the same *)
   125:           if checkSameFormat m1 m1' then
   126:             Some (m1 @ m2)
   127:           else
   128:             None
   129:       | _, _, _ -> None
   130:      end
   131:   | _ -> None)
   132: 
   133: let doBinopEq bop lvt et =
   134:   ((fun loc args ->
   135:     let l = (fst lvt) args in
   136:     Set(l, BinOp(bop, (Lval l), (fst et) args, typeOfLval l), loc)),
   137: 
   138:    matchBinopEq (fun bop' -> bop = bop') (snd lvt) (snd et))
   139: 
   140: 
   141: let getField (bt: typ) (fname: string) : fieldinfo =
   142:   match unrollType bt with
   143:     TComp(ci, _) -> begin
   144:       try
   145:         List.find (fun f -> fname = f.fname) ci.cfields
   146:       with Not_found ->
   147:         E.s (bug "Cannot find field %s in %s\n" fname (compFullName ci))
   148:     end
   149:   | t -> E.s (bug "Trying to access field %s in non-struct\n" fname)
   150: 
   151: 
   152: let matchIntType (ik: ikind) (t:typ) : formatArg list option =
   153:   match unrollType t with
   154:     TInt(ik', _) when ik = ik' -> Some []
   155:   | _ -> None
   156: 
   157: let matchFloatType (fk: fkind) (t:typ) : formatArg list option =
   158:   match unrollType t with
   159:     TFloat(fk', _) when fk = fk' -> Some []
   160:   | _ -> None
   161: 
   162: let doAttr (id: string)
   163:            (aargs: (((string * formatArg) list -> attrparam list) *
   164:                     (attrparam list -> formatArg list option)) option)
   165:     =
   166:   let t = match aargs with
   167:     Some t -> t
   168:   | None -> (fun _ -> []),
   169:             (function [] -> Some [] | _ -> None)
   170:   in
   171:   ((fun args -> Attr (id, (fst t) args)),
   172: 
   173:    (fun attrs ->
   174:      (* Find the attributes with the same ID *)
   175:      List.fold_left
   176:        (fun acc a ->
   177:          match acc, a with
   178:            Some _, _ -> acc (* We found one already *)
   179:          | None, Attr(id', args) when id = id' ->
   180:              (* Now match the arguments *)
   181:              (snd t) args
   182:          | None, _ -> acc)
   183:        None
   184:        attrs))
   185: 
   186: 
   187: type falist = formatArg list
   188: 
   189: type maybeInit =
   190:     NoInit
   191:   | InitExp of exp
   192:   | InitCall of lval * exp list
   193: 
   194: %}
   195: 
   196: %token <string> IDENT
   197: %token <string> CST_CHAR
   198: %token <string> CST_INT
   199: %token <string> CST_FLOAT
   200: %token <string> CST_STRING
   201: %token <string> CST_WSTRING
   202: %token <string> NAMED_TYPE
   203: 
   204: %token EOF
   205: %token BOOL CHAR INT DOUBLE FLOAT COMPLEX IMAGINARY VOID INT64 INT32
   206: %token ENUM STRUCT TYPEDEF UNION
   207: %token SIGNED UNSIGNED LONG SHORT
   208: %token VOLATILE EXTERN STATIC CONST RESTRICT AUTO REGISTER
   209: 
   210: %token <string> ARG_e ARG_eo ARG_E ARG_u ARG_b ARG_t ARG_d ARG_lo ARG_l ARG_i
   211: %token <string> ARG_o ARG_va ARG_f ARG_F ARG_A ARG_v ARG_k ARG_c ARG_d
   212: %token <string> ARG_s ARG_p ARG_P ARG_I ARG_S ARG_g
   213: 
   214: %token SIZEOF ALIGNOF
   215: 
   216: %token EQ
   217: %token ARROW DOT
   218: 
   219: %token EQ_EQ EXCLAM_EQ INF SUP INF_EQ SUP_EQ
   220: %token MINUS_EQ PLUS_EQ STAR_EQ
   221: %token PLUS MINUS STAR SLASH PERCENT
   222: %token TILDE AND PIPE CIRC
   223: %token EXCLAM AND_AND PIPE_PIPE
   224: %token INF_INF SUP_SUP
   225: %token PLUS_PLUS MINUS_MINUS
   226: 
   227: %token RPAREN LPAREN RBRACE LBRACE LBRACKET RBRACKET
   228: %token COLON SEMICOLON COMMA ELLIPSIS QUEST
   229: 
   230: %token BREAK CONTINUE GOTO RETURN
   231: %token SWITCH CASE DEFAULT
   232: %token WHILE DO FOR
   233: %token IF THEN ELSE
   234: 
   235: %token ATTRIBUTE INLINE ASM TYPEOF FUNCTION__ PRETTY_FUNCTION__ LABEL__
   236: %token BUILTIN_VA_ARG BUILTIN_VA_LIST
   237: %token BLOCKATTRIBUTE
   238: %token DECLSPEC
   239: %token <string> MSASM MSATTR
   240: %token PRAGMA
   241: 
   242: 
   243: /* operator precedence */
   244: %nonassoc       IF
   245: %nonassoc       ELSE
   246: 
   247: 
   248: %left   COMMA
   249: 
   250:  /*(* Set the following precedences higer than COMMA *)*/
   251: %nonassoc ARG_e ARG_d ARG_lo ARG_l ARG_i ARG_v ARG_I ARG_g
   252: %right  EQ PLUS_EQ MINUS_EQ STAR_EQ SLASH_EQ PERCENT_EQ
   253:                 AND_EQ PIPE_EQ CIRC_EQ INF_INF_EQ SUP_SUP_EQ
   254: %right  COLON
   255: %left   PIPE_PIPE
   256: %left   AND_AND
   257: %left   ARG_b
   258: %left   PIPE
   259: %left   CIRC
   260: %left   AND
   261: %left   EQ_EQ EXCLAM_EQ
   262: %left   INF SUP INF_EQ SUP_EQ
   263: %left   INF_INF SUP_SUP
   264: %left   PLUS MINUS
   265: %left   STAR SLASH PERCENT CONST RESTRICT VOLATILE
   266: %right  ARG_u EXCLAM TILDE PLUS_PLUS MINUS_MINUS CAST RPAREN ADDROF SIZEOF ALIGNOF
   267: %left   LBRACKET
   268: %left   DOT ARROW LPAREN LBRACE
   269: %nonassoc IDENT QUEST CST_INT
   270: 
   271: %start initialize expression typename offset lval instr stmt stmt_list
   272: 
   273: 
   274: %type <unit> initialize
   275: %type <((string -> Flx_cil_cil.typ -> Flx_cil_cil.varinfo) -> Flx_cil_cil.location -> (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.stmt)> stmt
   276: %type <((string -> Flx_cil_cil.typ -> Flx_cil_cil.varinfo) -> Flx_cil_cil.location -> (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.stmt list)> stmt_list
   277: 
   278: %type <((string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.exp) * (Flx_cil_cil.exp -> Flx_cil_cil.formatArg list option)> expression
   279: 
   280: %type <((string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.exp) * (Flx_cil_cil.exp -> Flx_cil_cil.formatArg list option)> constant
   281: 
   282: %type <((string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.lval) * (Flx_cil_cil.lval -> Flx_cil_cil.formatArg list option)> lval
   283: 
   284: %type <((string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.typ) * (Flx_cil_cil.typ -> Flx_cil_cil.formatArg list option)> typename
   285: 
   286: %type <(Flx_cil_cil.attributes -> (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.typ) * (Flx_cil_cil.typ -> Flx_cil_cil.formatArg list option)> type_spec
   287: 
   288: %type <((string * Flx_cil_cil.formatArg) list -> (string * Flx_cil_cil.typ * Flx_cil_cil.attributes) list option * bool) * ((string * Flx_cil_cil.typ * Flx_cil_cil.attributes) list option * bool -> Flx_cil_cil.formatArg list option)> parameters
   289: 
   290: 
   291: %type <(Flx_cil_cil.location -> (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.instr) * (Flx_cil_cil.instr -> Flx_cil_cil.formatArg list option)> instr
   292: 
   293: %type <(Flx_cil_cil.typ -> (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.offset) * (Flx_cil_cil.offset -> Flx_cil_cil.formatArg list option)> offset
   294: 
   295: 
   296: %%
   297: 
   298: 
   299: initialize:
   300:  /* empty */   {  }
   301: ;
   302: 
   303: /* (*** Expressions ***) */
   304: 
   305: 
   306: expression:
   307: |               ARG_e  {  (* Count arguments eagerly *)
   308:                             let currentArg = $1 in
   309:                             ((fun args ->
   310:                                match getArg currentArg args with
   311:                                    Fe e -> e
   312:                                  | a -> wrongArgType currentArg
   313:                                             "expression" a),
   314: 
   315:                              (fun e -> Some [ Fe e ]))
   316:                          }
   317: 
   318: |               constant { $1 }
   319: 
   320: |               lval     %prec IDENT
   321:                         { ((fun args -> Lval ((fst $1) args)),
   322: 
   323:                              (fun e -> match e with
   324:                                 Lval l -> (snd $1) l
   325:                               | _ -> None))
   326:                          }
   327: 
   328: |               SIZEOF expression
   329:                         { ((fun args -> SizeOfE ((fst $2) args)),
   330: 
   331:                            fun e -> match e with
   332:                              SizeOfE e' -> (snd $2) e'
   333:                            | _ -> None)
   334:                         }
   335: 
   336: |               SIZEOF LPAREN typename RPAREN
   337:                         { ((fun args -> SizeOf ((fst $3) args)),
   338: 
   339:                            (fun e -> match e with
   340:                               SizeOf t -> (snd $3) t
   341:                            |  _ -> None))
   342:                         }
   343: 
   344: |               ALIGNOF expression
   345:                         { ((fun args -> AlignOfE ((fst $2) args)),
   346: 
   347:                            (fun e -> match e with
   348:                              AlignOfE e' -> (snd $2) e' | _ -> None))
   349:                         }
   350: 
   351: |               ALIGNOF LPAREN typename RPAREN
   352:                         { ((fun args -> AlignOf ((fst $3) args)),
   353: 
   354:                            (fun e -> match e with
   355:                              AlignOf t' -> (snd $3) t' | _ -> None))
   356:                         }
   357: 
   358: |               PLUS expression
   359:                         { $2 }
   360: |               MINUS expression
   361:                         { doUnop Neg $2 }
   362: 
   363: |               EXCLAM expression
   364:                         { doUnop LNot $2 }
   365: 
   366: |               TILDE expression
   367:                         { doUnop BNot $2 }
   368: 
   369: |               argu expression %prec ARG_u
   370:                         { ((fun args ->
   371:                              let e = (fst $2) args in
   372:                              UnOp((fst $1) args, e, typeOf e)),
   373: 
   374:                            (fun e -> match e with
   375:                              UnOp(uo, e', _) -> begin
   376:                                match (snd $1) uo, (snd $2) e' with
   377:                                  Some m1, Some m2 -> Some (m1 @ m2)
   378:                                | _ -> None
   379:                              end
   380:                            | _ -> None))
   381:                         }
   382: 
   383: 
   384: |               AND expression                          %prec ADDROF
   385:                         { ((fun args ->
   386:                              match (fst $2) args with
   387:                                 Lval l -> mkAddrOf l
   388:                               | _ -> E.s (bug "AddrOf applied to a non lval")),
   389:                           (fun e -> match e with
   390:                             AddrOf l -> (snd $2) (Lval l)
   391:                           | e -> (snd $2) (Lval (mkMem e NoOffset))))
   392:                          }
   393: 
   394: |               LPAREN expression RPAREN
   395:                         { $2 }
   396: 
   397: |               expression PLUS expression
   398:                         { ((fun args -> buildPlus ((fst $1) args)
   399:                                                   ((fst $3) args)),
   400:                           (fun e -> match e with
   401:                             BinOp((PlusPI|PlusA), e1, e2, _) -> begin
   402:                               match (snd $1) e1, (snd $3) e2 with
   403:                                 Some m1, Some m2 -> Some (m1 @ m2)
   404:                               | _, _ -> None
   405:                             end
   406:                           | _ -> None))
   407:                         }
   408: 
   409: |               expression MINUS expression
   410:                         { ((fun args -> buildMinus ((fst $1) args)
   411:                                                    ((fst $3) args)),
   412: 
   413:                            (fun e -> match e with
   414:                              BinOp((MinusPP|MinusPI|MinusA), e1, e2, _) ->
   415:                                begin
   416:                                  match (snd $1) e1, (snd $3) e2 with
   417:                                    Some m1, Some m2 -> Some (m1 @ m2)
   418:                                  | _, _ -> None
   419:                                end
   420:                            | _ -> None))
   421:                         }
   422: |               expression argb expression %prec ARG_b
   423:                         { ((fun args ->
   424:                                let e1 = (fst $1) args in
   425:                                let bop = (fst $2) args in
   426:                                let e2 = (fst $3) args in
   427:                                let t1 = typeOf e1 in
   428:                                BinOp(bop, e1, e2, t1)),
   429: 
   430:                            (fun e -> match e with
   431:                              BinOp(bop, e1, e2, _) -> begin
   432:                                match (snd $1) e1,(snd $2) bop,(snd $3) e2 with
   433:                                  Some m1, Some m2, Some m3 ->
   434:                                    Some (m1 @ m2 @ m3)
   435:                                | _, _, _ -> None
   436:                              end
   437:                            | _ -> None))
   438:                         }
   439: 
   440: |               expression STAR expression
   441:                         { doBinop Mult $1 $3 }
   442: |               expression SLASH expression
   443:                         { doBinop Div $1 $3 }
   444: |               expression PERCENT expression
   445:                         { doBinop Mod $1 $3 }
   446: |               expression  INF_INF expression
   447:                         { doBinop Shiftlt $1 $3 }
   448: |               expression  SUP_SUP expression
   449:                         { doBinop Shiftrt $1 $3 }
   450: |               expression AND expression
   451:                         { doBinop BAnd $1 $3 }
   452: |               expression PIPE expression
   453:                         { doBinop BOr $1 $3 }
   454: |               expression CIRC expression
   455:                         { doBinop BXor $1 $3 }
   456: |               expression EQ_EQ expression
   457:                         { doBinop Eq $1 $3 }
   458: |               expression EXCLAM_EQ expression
   459:                         { doBinop Ne $1 $3 }
   460: |               expression INF expression
   461:                         { doBinop Lt $1 $3 }
   462: |               expression SUP expression
   463:                         { doBinop Gt $1 $3 }
   464: |               expression INF_EQ expression
   465:                         { doBinop Le $1 $3 }
   466: |               expression SUP_EQ expression
   467:                         { doBinop Ge $1 $3 }
   468: 
   469: |               LPAREN typename RPAREN expression
   470:                          { ((fun args ->
   471:                               let t = (fst $2) args in
   472:                               let e = (fst $4) args in
   473:                               mkCast e t),
   474: 
   475:                             (fun e ->
   476:                               let t', e' =
   477:                                 match e with
   478:                                   CastE (t', e') -> t', e'
   479:                                 | _ -> typeOf e, e
   480:                               in
   481:                               match (snd $2) t', (snd $4 e') with
   482:                                 Some m1, Some m2 -> Some (m1 @ m2)
   483:                               | _, _ -> None))
   484:                          }
   485: ;
   486: 
   487: /*(* Separate the ARG_ to ensure that the counting of arguments is right *)*/
   488: argu :
   489: |   ARG_u              { let currentArg = $1 in
   490:                          ((fun args ->
   491:                            match getArg currentArg args with
   492:                              Fu uo -> uo
   493:                            | a -> wrongArgType currentArg "unnop" a),
   494: 
   495:                           fun uo -> Some [ Fu uo ])
   496:                        }
   497: ;
   498: 
   499: argb :
   500: |   ARG_b              { let currentArg = $1 in
   501:                          ((fun args ->
   502:                            match getArg currentArg args with
   503:                              Fb bo -> bo
   504:                            | a -> wrongArgType currentArg "binop" a),
   505: 
   506:                           fun bo -> Some [ Fb bo ])
   507:                        }
   508: ;
   509: 
   510: constant:
   511: |   ARG_d              { let currentArg = $1 in
   512:                            ((fun args ->
   513:                              match getArg currentArg args with
   514:                                Fd n -> integer n
   515:                               | a -> wrongArgType currentArg "integer" a),
   516: 
   517:                             fun e -> match e with
   518:                               Const(CInt64(n, _, _)) ->
   519:                                 Some [ Fd (Int64.to_int n) ]
   520:                             | _ -> None)
   521:                          }
   522: 
   523: |   ARG_g             { let currentArg = $1 in
   524:                         ((fun args ->
   525:                              match getArg currentArg args with
   526:                                Fg s -> Const(CStr s)
   527:                               | a -> wrongArgType currentArg "string" a),
   528: 
   529:                             fun e -> match e with
   530:                               Const(CStr s) ->
   531:                                 Some [ Fg s ]
   532:                             | _ -> None)
   533:                          }
   534: |   CST_INT              { let n = parseInt $1 in
   535:                            ((fun args -> n),
   536: 
   537:                             (fun e -> match e, n with
   538:                               Const(CInt64(e', _, _)),
   539:                               Const(CInt64(n', _, _)) when e' = n' -> Some []
   540:                             | _ -> None))
   541:                          }
   542: ;
   543: 
   544: 
   545: /*(***************** LVALUES *******************)*/
   546: lval:
   547: |   ARG_l             { let currentArg = $1 in
   548:                            ((fun args ->
   549:                                 match getArg currentArg args with
   550:                                   Fl l -> l
   551:                                 | Fv v -> Var v, NoOffset
   552:                                 | a -> wrongArgType currentArg "lval" a),
   553: 
   554:                             fun l -> Some [ Fl l ])
   555:                          }
   556: 
   557: |   argv offset       %prec ARG_v
   558:                          { ((fun args ->
   559:                               let v = (fst $1) args in
   560:                                (Var v, (fst $2) v.vtype args)),
   561: 
   562:                             (fun l -> match l with
   563:                               Var vi, off -> begin
   564:                                 match (snd $1) vi, (snd $2) off with
   565:                                   Some m1, Some m2 -> Some (m1 @ m2)
   566:                                 | _ -> None
   567:                               end
   568:                             | _ -> None))
   569:                          }
   570: 
   571: |   STAR expression      { ((fun args -> mkMem ((fst $2) args) NoOffset),
   572: 
   573:                            (fun l -> match l with
   574:                               Mem e, NoOffset -> (snd $2) e
   575:                            | _, _ -> None))
   576:                          }
   577: 
   578: |   expression ARROW IDENT offset
   579:              { ((fun args ->
   580:                    let e = (fst $1) args in
   581:                    let baset =
   582:                      match unrollTypeDeep (typeOf e) with
   583:                        TPtr (t, _) -> t
   584:                      | _ -> E.s (bug "Expecting a pointer for field %s\n" $3)
   585:                    in
   586:                    let fi = getField baset $3 in
   587:                    mkMem e (Field(fi, (fst $4) fi.ftype args))),
   588: 
   589:                 (fun l -> match l with
   590:                    Mem e, Field(fi, off) when fi.fname = $3 -> begin
   591:                      match (snd $1) e, (snd $4) off with
   592:                        Some m1, Some m2 -> Some (m1 @ m2)
   593:                      | _, _ -> None
   594:                    end
   595:                 | _, _ -> None))
   596:              }
   597: 
   598: |   LPAREN STAR expression RPAREN offset
   599:              { ((fun args ->
   600:                  let e = (fst $3) args in
   601:                  let baset =
   602:                    match unrollTypeDeep (typeOf e) with
   603:                      TPtr (t, _) -> t
   604:                    | _ -> E.s (bug "Expecting a pointer\n")
   605:                  in
   606:                  mkMem e ((fst $5) baset args)),
   607: 
   608:                 (fun l -> match l with
   609:                   Mem e, off -> begin
   610:                     match (snd $3) e, (snd $5 off) with
   611:                       Some m1, Some m2 -> Some (m1 @ m2)
   612:                     | _, _ -> None
   613:                   end
   614:                 | _, _ -> None))
   615:               }
   616:     ;
   617: 
   618: argv :
   619: |   ARG_v              { let currentArg = $1 in
   620:                          ((fun args ->
   621:                            match getArg currentArg args with
   622:                              Fv v -> v
   623:                            | a -> wrongArgType currentArg "varinfo" a),
   624: 
   625:                           fun v -> Some [ Fv v ])
   626:                        }
   627: |  IDENT               { let currentArg = $1 in
   628:                          ((fun args ->
   629:                            match getArg currentArg args with
   630:                              Fv v -> v
   631:                            | a -> wrongArgType currentArg "varinfo" a),
   632:                          (fun v ->
   633:                              E.s (bug "identifiers (%s) are not supported for deconstruction" currentArg)))
   634:                        }
   635: ;
   636: 
   637: 
   638: /*(********** OFFSETS *************)*/
   639: offset:
   640: |  ARG_o             { let currentArg = $1 in
   641:                             ((fun t args ->
   642:                                 match getArg currentArg args with
   643:                                   Fo o -> o
   644:                                 | a -> wrongArgType currentArg "offset" a),
   645: 
   646:                               (fun off -> Some [ Fo off ]))
   647:                           }
   648: 
   649: |  /* empty */            { ((fun t args -> NoOffset),
   650: 
   651:                              (fun off -> match off with
   652:                                 NoOffset -> Some []
   653:                               | _ -> None))
   654:                           }
   655: 
   656: |  DOT IDENT offset       { ((fun t args ->
   657:                                 let fi = getField t $2 in
   658:                                 Field (fi, (fst $3) fi.ftype args)),
   659: 
   660:                             (fun off -> match off with
   661:                                Field (fi, off') when fi.fname = $2 ->
   662:                                  (snd $3) off'
   663:                             | _ -> None))
   664:                           }
   665: 
   666: |  LBRACKET expression RBRACKET offset
   667:                    { ((fun t args ->
   668:                      let bt =
   669:                        match unrollType t with
   670:                          TArray(bt, _, _) -> bt
   671:                        | _ -> E.s (error "Flx_cil_formatcil: expecting an array for index")
   672:                      in
   673:                      let e = (fst $2) args in
   674:                      Index(e, (fst $4) bt args)),
   675: 
   676:                     (fun off -> match off with
   677:                       Index (e, off') -> begin
   678:                         match (snd $2) e, (snd $4) off with
   679:                           Some m1, Some m2 -> Some (m1 @ m2)
   680:                         | _, _ -> None
   681:                       end
   682:                     | _ -> None))
   683:                     }
   684: ;
   685: 
   686: 
   687: /*(************ TYPES **************)*/
   688: typename: one_formal  { ((fun args ->
   689:                             let (_, ft, _) = (fst $1) args in
   690:                             ft),
   691: 
   692:                          (fun t -> (snd $1) ("", t, [])))
   693:                       }
   694: ;
   695: 
   696: one_formal:
   697: /*(* Do not allow attributes for the name *)*/
   698: | type_spec attributes decl
   699:                    { ((fun args ->
   700:                         let tal = (fst $2) args in
   701:                         let ts = (fst $1) tal args in
   702:                         let (fn, ft, _) = (fst $3) ts args in
   703:                         (fn, ft, [])),
   704: 
   705:                       (fun (fn, ft, fa) ->
   706:                          match (snd $3) (fn, ft) with
   707:                            Some (restt, m3) -> begin
   708:                              match (snd $1) restt,
   709:                                    (snd $2) (typeAttrs restt)with
   710:                                Some m1, Some m2 ->
   711:                                  Some (m1 @ m2 @ m3)
   712:                              | _, _ -> None
   713:                            end
   714:                          | _ -> None))
   715:                    }
   716: 
   717: | ARG_f
   718:                    { let currentArg = $1 in
   719:                      ((fun args ->
   720:                          match getArg currentArg args with
   721:                           Ff (fn, ft, fa) -> (fn, ft, fa)
   722:                          | a  -> wrongArgType currentArg "formal" a),
   723: 
   724:                       (fun (fn, ft, fa) -> Some [ Ff (fn, ft, fa) ]))
   725:                    }
   726: ;
   727: 
   728: type_spec:
   729: |   ARG_t       { let currentArg = $1 in
   730:                      ((fun al args ->
   731:                        match getArg currentArg args with
   732:                           Ft t -> typeAddAttributes al t
   733:                        | a -> wrongArgType currentArg "type" a),
   734: 
   735:                       (fun t -> Some [ Ft t ]))
   736:                       }
   737: 
   738: |   VOID            { ((fun al args -> TVoid al),
   739: 
   740:                        (fun t -> match unrollType t with
   741:                            TVoid _ -> Some []
   742:                          | _ -> None)) }
   743: 
   744: |   ARG_k           { let currentArg = $1 in
   745:                       ((fun al args ->
   746:                         match getArg currentArg args with
   747:                           Fk ik -> TInt(ik, al)
   748:                         | a -> wrongArgType currentArg "ikind" a),
   749: 
   750:                        (fun t -> match unrollType t with
   751:                          TInt(ik, _) -> Some [ Fk ik ]
   752:                        | _ -> None))
   753:                     }
   754: 
   755: |   CHAR            { ((fun al args -> TInt(IChar, al)),
   756:                        (matchIntType IChar)) }
   757: |   UNSIGNED CHAR   { ((fun al args -> TInt(IUChar, al)),
   758:                        matchIntType IUChar) }
   759: 
   760: |   SHORT           { ((fun al args -> TInt(IShort, al)),
   761:                        matchIntType IShort) }
   762: |   UNSIGNED SHORT  { ((fun al args -> TInt(IUShort, al)),
   763:                        matchIntType IUShort) }
   764: 
   765: |   INT             { ((fun al args -> TInt(IInt, al)),
   766:                        matchIntType IInt) }
   767: |   UNSIGNED INT    { ((fun al args -> TInt(IUInt, al)), matchIntType IUInt) }
   768: 
   769: |   LONG             { ((fun al args -> TInt(ILong, al)),
   770:                         matchIntType ILong) }
   771: |   UNSIGNED LONG    { ((fun al args -> TInt(IULong, al)),
   772:                         matchIntType IULong) }
   773: 
   774: |   LONG LONG          { ((fun al args -> TInt(ILongLong, al)),
   775: 
   776:                           matchIntType ILongLong)
   777:                         }
   778: |   UNSIGNED LONG LONG    { ((fun al args -> TInt(IULongLong, al)),
   779: 
   780:                              matchIntType IULongLong)
   781:                            }
   782: 
   783: |   FLOAT           { ((fun al args -> TFloat(FFloat, al)),
   784:                        matchFloatType FFloat)
   785:                     }
   786: |   DOUBLE          { ((fun al args -> TFloat(FDouble, al)),
   787:                        matchFloatType FDouble) }
   788: 
   789: |   COMPLEX         { ((fun al args -> TFloat(CFloat, al)),
   790:                        matchFloatType CFloat ) }
   791: 
   792: |   IMAGINARY       { ((fun al args -> TFloat(IFloat, al)),
   793:                        matchFloatType IFloat) }
   794: 
   795: |   STRUCT ARG_c { let currentArg = $2 in
   796:                       ((fun al args ->
   797:                          match getArg currentArg args with
   798:                            Fc ci -> TComp(ci, al)
   799:                          | a -> wrongArgType currentArg "compinfo" a),
   800: 
   801:                         (fun t -> match unrollType t with
   802:                             TComp(ci, _) -> Some [ Fc ci ]
   803:                           | _ -> None))
   804:                     }
   805: |   UNION ARG_c { let currentArg = $2 in
   806:                      ((fun al args ->
   807:                          match getArg currentArg args with
   808:                            Fc ci -> TComp(ci, al)
   809:                          | a -> wrongArgType currentArg "compinfo" a),
   810: 
   811:                         (fun t -> match unrollType t with
   812:                             TComp(ci, _) -> Some [ Fc ci ]
   813:                           | _ -> None))
   814: 
   815:                    }
   816: 
   817: |   TYPEOF LPAREN expression RPAREN
   818:                    { ((fun al args -> typeAddAttributes al
   819:                                         (typeOf ((fst $3) args))),
   820: 
   821:                       (fun t -> E.s (bug "Cannot match typeof(e)\n")))
   822:                    }
   823: ;
   824: 
   825: decl:
   826: |  STAR attributes decl
   827:                     { ((fun ts args ->
   828:                          let al = (fst $2) args in
   829:                          (fst $3) (TPtr(ts, al)) args),
   830: 
   831:                        (fun (fn, ft) ->
   832:                          match (snd $3) (fn, ft) with
   833:                            Some (TPtr(bt, al), m2) -> begin
   834:                              match (snd $2) al with
   835:                                Some m1 -> Some (bt, m1 @ m2)
   836:                              | _ -> None
   837:                            end
   838:                          | _ -> None))
   839:                     }
   840: 
   841: |  direct_decl  { $1 }
   842: ;
   843: 
   844: direct_decl:
   845: |  /* empty */     { ((fun ts args -> ("", ts, [])),
   846: 
   847:                       (* Match any name in this case *)
   848:                       (fun (fn, ft) ->
   849:                          Some (unrollType ft, [])))
   850:                    }
   851: 
   852: |  IDENT           { ((fun ts args -> ($1, ts, [])),
   853: 
   854:                       (fun (fn, ft) ->
   855:                         if fn = "" || fn = $1 then
   856:                           Some (unrollType ft, [])
   857:                         else
   858:                           None))
   859:                    }
   860: 
   861: |  LPAREN attributes decl RPAREN
   862:                    { ((fun ts args ->
   863:                           let al = (fst $2) args in
   864:                           (fst $3) (typeAddAttributes al ts) args),
   865: 
   866:                       (fun (fn, ft) -> begin
   867:                         match (snd $3) (fn, ft) with
   868:                           Some (restt, m2) -> begin
   869:                             match (snd $2) (typeAttrs restt) with
   870:                               Some m1 -> Some (restt, m1 @ m2)
   871:                             | _ -> None
   872:                           end
   873:                         | _ -> None
   874:                       end))
   875:                    }
   876: 
   877: |  direct_decl LBRACKET exp_opt RBRACKET
   878:                    { ((fun ts args ->
   879:                         (fst $1) (TArray(ts, (fst $3) args, [])) args),
   880: 
   881:                      (fun (fn, ft) ->
   882:                        match (snd $1) (fn, ft) with
   883:                          Some (TArray(bt, lo, _), m1) -> begin
   884:                            match (snd $3) lo with
   885:                              Some m2 -> Some (unrollType bt, m1 @ m2)
   886:                            | _ -> None
   887:                          end
   888:                        | _ -> None))
   889:                    }
   890: 
   891: 
   892: /*(* We use parentheses around the function to avoid conflicts *)*/
   893: |  LPAREN attributes decl RPAREN LPAREN parameters RPAREN
   894:                    { ((fun ts args ->
   895:                         let al = (fst $2) args in
   896:                         let pars, isva = (fst $6) args in
   897:                         (fst $3) (TFun(ts, pars, isva, al)) args),
   898: 
   899:                       (fun (fn, ft) ->
   900:                          match (snd $3) (fn, ft) with
   901:                            Some (TFun(rt, args, isva, al), m1) -> begin
   902:                              match (snd $2) al, (snd $6) (args, isva) with
   903:                                Some m2, Some m6
   904:                                -> Some (unrollType rt, m1 @ m2 @ m6)
   905:                              | _ -> None
   906:                            end
   907:                          | _ -> None))
   908:                    }
   909: ;
   910: 
   911: parameters:
   912: | /* empty */      { ((fun args -> (None, false)),
   913: 
   914:                      (* Match any formals *)
   915:                       (fun (pars, isva) ->
   916:                         match pars, isva with
   917:                           (_, false) -> Some []
   918:                         | _ -> None))
   919:                    }
   920: 
   921: | parameters_ne    { ((fun args ->
   922:                         let (pars : (string * typ * attributes) list),
   923:                             (isva : bool) = (fst $1) args in
   924:                         (Some pars), isva),
   925: 
   926:                      (function
   927:                          ((Some pars), isva) -> (snd $1) (pars, isva)
   928:                        |  _ -> None))
   929:                    }
   930: ;
   931: parameters_ne:
   932: | ELLIPSIS
   933:                    { ((fun args -> ([], true)),
   934: 
   935:                       (function
   936:                           ([], true) -> Some []
   937:                         | _ -> None))
   938:                    }
   939: 
   940: | ARG_va           { let currentArg = $1 in
   941:                      ((fun args ->
   942:                        match getArg currentArg args with
   943:                          Fva isva -> ([], isva)
   944:                        | a -> wrongArgType currentArg "vararg" a),
   945: 
   946:                      (function
   947:                          ([], isva) -> Some [ Fva isva ]
   948:                        | _ -> None))
   949:                    }
   950: 
   951: | ARG_F            { let currentArg = $1 in
   952:                      ((fun args ->
   953:                        match getArg currentArg args with
   954:                         FF fl -> ( fl, false)
   955:                        | a  -> wrongArgType currentArg "formals" a),
   956: 
   957:                       (function
   958:                           (pars, false) -> Some [ FF pars ]
   959:                         | _ -> None))
   960:                    }
   961: 
   962: | one_formal       { ((fun args -> ([(fst $1) args], false)),
   963: 
   964:                      (function
   965:                          ([ f ], false) -> (snd $1) f
   966:                        | _ -> None))
   967:                    }
   968: 
   969: 
   970: | one_formal COMMA parameters_ne
   971:                    { ((fun args ->
   972:                         let this = (fst $1) args in
   973:                         let (rest, isva) = (fst $3) args in
   974:                         (this :: rest, isva)),
   975: 
   976:                       (function
   977:                           ((f::rest, isva)) -> begin
   978:                             match (snd $1) f, (snd $3) (rest, isva) with
   979:                               Some m1, Some m2 -> Some (m1 @ m2)
   980:                             | _, _ -> None
   981:                           end
   982:                         | _ -> None))
   983:                    }
   984: ;
   985: 
   986: 
   987: 
   988: 
   989: 
   990: exp_opt:
   991:    /* empty */     { ((fun args -> None),
   992:                       (* Match anything if the pattern does not have a len *)
   993:                       (fun _ -> Some [])) }
   994: 
   995: |  expression      { ((fun args -> Some ((fst $1) args)),
   996: 
   997:                       (fun lo -> match lo with
   998:                         Some e -> (snd $1) e
   999:                       | _ -> None))
  1000:                    }
  1001: |  ARG_eo          { let currentArg = $1 in
  1002:                      ((fun args ->
  1003:                        match getArg currentArg args with
  1004:                          Feo lo -> lo
  1005:                        | a -> wrongArgType currentArg "exp_opt" a),
  1006: 
  1007:                       fun lo -> Some [ Feo lo ])
  1008:                    }
  1009: ;
  1010: 
  1011: 
  1012: 
  1013: attributes:
  1014:   /*(* Ignore other attributes *)*/
  1015:   /* empty */     { ((fun args -> []),
  1016:                      (fun attrs -> Some [])) }
  1017: 
  1018: | ARG_A           { let currentArg = $1 in
  1019:                     ((fun args ->
  1020:                         match getArg currentArg args with
  1021:                           FA al -> al
  1022:                         | a -> wrongArgType currentArg "attributes" a),
  1023: 
  1024:                      (fun al -> Some [ FA al ]))
  1025:                   }
  1026: 
  1027: | attribute attributes
  1028:                   { ((fun args ->
  1029:                        addAttribute ((fst $1) args) ((fst $2) args)),
  1030:                      (* Pass all the attributes down *)
  1031:                      (fun attrs ->
  1032:                        match (snd $1) attrs, (snd $2) attrs with
  1033:                          Some m1, Some m2 -> Some (m1 @ m2)
  1034:                        | _, _ -> None))
  1035:                   }
  1036: ;
  1037: 
  1038: attribute:
  1039: |   CONST                               { doAttr "const" None }
  1040: |   RESTRICT                            { doAttr "restrict" None }
  1041: |   VOLATILE                            { doAttr "volatile" None }
  1042: |   ATTRIBUTE LPAREN LPAREN attr RPAREN RPAREN
  1043:                                         { $4 }
  1044: 
  1045: ;
  1046: 
  1047: 
  1048: attr:
  1049: |   IDENT
  1050:                           { doAttr $1 None }
  1051: 
  1052: |   IDENT LPAREN attr_args_ne RPAREN
  1053:                           { doAttr $1 (Some $3) }
  1054: ;
  1055: 
  1056: attr_args_ne:
  1057:     attr_arg                     { ((fun args -> [ (fst $1) args ]),
  1058: 
  1059:                                     (fun aargs -> match aargs with
  1060:                                       [ arg ] -> (snd $1) arg
  1061:                                     | _ -> None))
  1062:                                  }
  1063: |   attr_arg COMMA attr_args_ne  { ((fun args ->
  1064:                                       let this = (fst $1) args in
  1065:                                       this :: ((fst $3) args)),
  1066: 
  1067:                                     (fun aargs -> match aargs with
  1068:                                       h :: rest -> begin
  1069:                                         match (snd $1) h, (snd $3) rest with
  1070:                                           Some m1, Some m2 -> Some (m1 @ m2)
  1071:                                         | _, _ -> None
  1072:                                       end
  1073:                                     | _ -> None))
  1074:                                   }
  1075: |   ARG_P               { let currentArg = $1 in
  1076:                           ((fun args ->
  1077:                             match getArg currentArg args with
  1078:                               FP al -> al
  1079:                             | a -> wrongArgType currentArg "attrparams" a),
  1080: 
  1081:                            (fun al -> Some [ FP al ]))
  1082:                         }
  1083: ;
  1084: 
  1085: attr_arg:
  1086: |   IDENT            { ((fun args -> ACons($1, [])),
  1087: 
  1088:                         (fun aarg -> match aarg with
  1089:                             ACons(id, []) when id = $1 -> Some []
  1090:                         | _ -> None))
  1091:                      }
  1092: |   IDENT LPAREN attr_args_ne RPAREN
  1093:                      { ((fun args -> ACons($1, (fst $3) args)),
  1094: 
  1095:                         (fun aarg -> match aarg with
  1096:                             ACons(id, args) when id = $1 ->
  1097:                               (snd $3) args
  1098:                         | _ -> None))
  1099:                      }
  1100: |   ARG_p            { let currentArg = $1 in
  1101:                        ((fun args ->
  1102:                           match getArg currentArg args with
  1103:                             Fp p -> p
  1104:                           | a -> wrongArgType currentArg "attrparam" a),
  1105: 
  1106:                         (fun ap -> Some [ Fp ap]))
  1107:                      }
  1108: 
  1109: ;
  1110: 
  1111: /* (********** INSTRUCTIONS ***********) */
  1112: instr:
  1113: |               ARG_i SEMICOLON
  1114:                         { let currentArg = $1 in
  1115:                           ((fun loc args ->
  1116:                                 match getArg currentArg args with
  1117:                                   Fi i -> i
  1118:                                 | a -> wrongArgType currentArg "instr" a),
  1119: 
  1120:                            (fun i -> Some [ Fi i]))
  1121:                         }
  1122: 
  1123: |               lval EQ expression SEMICOLON
  1124:                         { ((fun loc args ->
  1125:                               Set((fst $1) args, (fst $3) args, loc)),
  1126: 
  1127:                            (fun i -> match i with
  1128:                              Set (lv, e, l) -> begin
  1129:                                match (snd $1) lv, (snd $3) e with
  1130:                                  Some m1, Some m2 -> Some (m1 @ m2)
  1131:                                | _, _ -> None
  1132:                              end
  1133:                            | _ -> None))
  1134:                         }
  1135: 
  1136: |               lval PLUS_EQ expression SEMICOLON
  1137:                         { ((fun loc args ->
  1138:                               let l = (fst $1) args in
  1139:                               Set(l, buildPlus (Lval l) ((fst $3) args), loc)),
  1140: 
  1141:                            matchBinopEq
  1142:                              (fun bop -> bop = PlusPI || bop = PlusA)
  1143:                              (snd $1) (snd $3))
  1144:                         }
  1145: 
  1146: |               lval MINUS_EQ expression SEMICOLON
  1147:                         { ((fun loc args ->
  1148:                               let l = (fst $1) args in
  1149:                               Set(l,
  1150:                                   buildMinus (Lval l) ((fst $3) args), loc)),
  1151: 
  1152:                            matchBinopEq (fun bop -> bop = MinusA
  1153:                                                || bop = MinusPP
  1154:                                                || bop = MinusPI)
  1155:                                       (snd $1)  (snd $3))
  1156:                         }
  1157: |               lval STAR_EQ expression SEMICOLON
  1158:                         { doBinopEq Mult $1 $3 }
  1159: 
  1160: |               lval SLASH_EQ expression SEMICOLON
  1161:                         { doBinopEq Div $1 $3 }
  1162: 
  1163: |               lval PERCENT_EQ expression SEMICOLON
  1164:                         { doBinopEq Mod $1 $3 }
  1165: 
  1166: |               lval AND_EQ expression SEMICOLON
  1167:                         { doBinopEq BAnd $1 $3 }
  1168: 
  1169: |               lval PIPE_EQ expression SEMICOLON
  1170:                         { doBinopEq BOr $1 $3 }
  1171: 
  1172: |               lval CIRC_EQ expression SEMICOLON
  1173:                         { doBinopEq BXor $1 $3 }
  1174: 
  1175: |               lval INF_INF_EQ expression SEMICOLON
  1176:                         { doBinopEq Shiftlt $1 $3 }
  1177: 
  1178: |               lval SUP_SUP_EQ expression SEMICOLON
  1179:                         { doBinopEq Shiftrt $1 $3 }
  1180: 
  1181: /* (* Would be nice to be able to condense the next three rules but we get
  1182:  * into conflicts *)*/
  1183: |               lval EQ lval LPAREN arguments RPAREN  SEMICOLON
  1184:                         { ((fun loc args ->
  1185:                               Call(Some ((fst $1) args), Lval ((fst $3) args),
  1186:                                      (fst $5) args, loc)),
  1187: 
  1188:                            (fun i -> match i with
  1189:                              Call(Some l, Lval f, args, loc) -> begin
  1190:                                match (snd $1) l, (snd $3) f, (snd $5) args with
  1191:                                  Some m1, Some m2, Some m3 ->
  1192:                                    Some (m1 @ m2 @ m3)
  1193:                                | _, _, _ -> None
  1194:                              end
  1195:                            | _ -> None))
  1196:                         }
  1197: 
  1198: |                       lval LPAREN arguments RPAREN  SEMICOLON
  1199:                         { ((fun loc args ->
  1200:                               Call(None, Lval ((fst $1) args),
  1201:                                      (fst $3) args, loc)),
  1202: 
  1203:                            (fun i -> match i with
  1204:                              Call(None, Lval f, args, loc) -> begin
  1205:                                match (snd $1) f, (snd $3) args with
  1206:                                  Some m1, Some m2 -> Some (m1 @ m2)
  1207:                                | _, _ -> None
  1208:                              end
  1209:                            | _ -> None))
  1210:                          }
  1211: 
  1212: |                 arglo lval LPAREN arguments RPAREN  SEMICOLON
  1213:                      { ((fun loc args ->
  1214:                        Call((fst $1) args, Lval ((fst $2) args),
  1215:                             (fst $4) args, loc)),
  1216: 
  1217:                         (fun i -> match i with
  1218:                           Call(lo, Lval f, args, loc) -> begin
  1219:                             match (snd $1) lo, (snd $2) f, (snd $4) args with
  1220:                               Some m1, Some m2, Some m3 ->
  1221:                                 Some (m1 @ m2 @ m3)
  1222:                             | _, _, _ -> None
  1223:                           end
  1224:                         | _ -> None))
  1225:                      }
  1226: ;
  1227: 
  1228: /* (* Separate this out to ensure that the counting or arguments is right *)*/
  1229: arglo:
  1230:     ARG_lo               { let currentArg = $1 in
  1231:                            ((fun args ->
  1232:                              let res =
  1233:                                match getArg currentArg args with
  1234:                                  Flo x -> x
  1235:                                | a -> wrongArgType currentArg "lval option" a
  1236:                              in
  1237:                              res),
  1238: 
  1239:                             (fun lo -> Some [ Flo lo ]))
  1240:                          }
  1241: ;
  1242: arguments:
  1243:     /* empty */   { ((fun args -> []),
  1244: 
  1245:                      (fun actuals -> match actuals with
  1246:                           [] -> Some []
  1247:                          | _ -> None))
  1248:                   }
  1249: 
  1250: | arguments_ne    { $1 }
  1251: ;
  1252: 
  1253: arguments_ne:
  1254:   expression      { ((fun args -> [ (fst $1) args ]),
  1255: 
  1256:                      (fun actuals -> match actuals with
  1257:                         [ h ] -> (snd $1) h
  1258:                        | _ -> None))
  1259:                   }
  1260: 
  1261: | ARG_E           {  let currentArg = $1 in
  1262:                      ((fun args ->
  1263:                          match getArg currentArg args with
  1264:                            FE el -> el
  1265:                           | a -> wrongArgType currentArg "arguments" a),
  1266: 
  1267:                       (fun actuals -> Some [ FE actuals ]))
  1268:                   }
  1269: 
  1270: | expression COMMA arguments_ne
  1271:                   { ((fun args -> ((fst $1) args) :: ((fst $3) args)),
  1272: 
  1273:                      (fun actuals -> match actuals with
  1274:                          h :: rest -> begin
  1275:                            match (snd $1) h, (snd $3) rest with
  1276:                              Some m1, Some m2 -> Some (m1 @ m2)
  1277:                            | _, _ -> None
  1278:                          end
  1279:                        | _ -> None))
  1280:                   }
  1281: ;
  1282: 
  1283: 
  1284: /*(******** STATEMENTS *********)*/
  1285: stmt:
  1286:     IF LPAREN expression RPAREN stmt           %prec IF
  1287:                   { (fun mkTemp loc args ->
  1288:                          mkStmt (If((fst $3) args,
  1289:                                     mkBlock [ $5 mkTemp loc args ],
  1290:                                     mkBlock [], loc)))
  1291:                   }
  1292: |   IF LPAREN expression RPAREN stmt ELSE stmt
  1293:                   { (fun mkTemp loc args ->
  1294:                          mkStmt (If((fst $3) args,
  1295:                                     mkBlock [ $5 mkTemp loc args ],
  1296:                                     mkBlock [ $7 mkTemp loc args], loc)))
  1297:                   }
  1298: |   RETURN exp_opt SEMICOLON
  1299:                   { (fun mkTemp loc args ->
  1300:                          mkStmt (Return((fst $2) args, loc)))
  1301:                   }
  1302: |   BREAK SEMICOLON
  1303:                   { (fun mkTemp loc args ->
  1304:                          mkStmt (Break loc))
  1305:                   }
  1306: |   CONTINUE SEMICOLON
  1307:                   { (fun mkTemp loc args ->
  1308:                          mkStmt (Continue loc))
  1309:                   }
  1310: |   LBRACE stmt_list RBRACE
  1311:                   { (fun mkTemp loc args ->
  1312:                          let stmts = $2 mkTemp loc args in
  1313:                          mkStmt (Block (mkBlock (stmts))))
  1314:                   }
  1315: |   WHILE LPAREN expression RPAREN stmt
  1316:                   { (fun mkTemp loc args ->
  1317:                         let e = (fst $3) args in
  1318:                         let e =
  1319:                           if isPointerType(typeOf e) then
  1320:                             mkCast e !upointType
  1321:                           else e
  1322:                         in
  1323:                         mkStmt
  1324:                           (Loop (mkBlock [ mkStmt
  1325:                                              (If(e,
  1326:                                                  mkBlock [],
  1327:                                                  mkBlock [ mkStmt
  1328:                                                              (Break loc) ],
  1329:                                                  loc));
  1330:                                            $5 mkTemp loc args ],
  1331:                                  loc, None, None)))
  1332:                    }
  1333: |   instr_list    { (fun mkTemp loc args ->
  1334:                        mkStmt (Instr ($1 loc args)))
  1335:                   }
  1336: |   ARG_s         { let currentArg = $1 in
  1337:                     (fun mkTemp loc args ->
  1338:                        match getArg currentArg args with
  1339:                          Fs s -> s
  1340:                        | a -> wrongArgType currentArg "stmt" a) }
  1341: ;
  1342: 
  1343: stmt_list:
  1344:     /* empty */  { (fun mkTemp loc args -> []) }
  1345: 
  1346: |   ARG_S        { let currentArg = $1 in
  1347:                    (fun mkTemp loc args ->
  1348:                        match getArg currentArg args with
  1349:                        | FS sl -> sl
  1350:                        | a -> wrongArgType currentArg "stmts" a)
  1351:                  }
  1352: |   stmt stmt_list
  1353:                  { (fun mkTemp loc args ->
  1354:                       let this = $1 mkTemp loc args in
  1355:                       this :: ($2 mkTemp loc args))
  1356:                  }
  1357: /* (* We can also have a declaration *) */
  1358: |   type_spec attributes decl maybe_init SEMICOLON stmt_list
  1359:                 { (fun mkTemp loc args ->
  1360:                      let tal = (fst $2) args in
  1361:                      let ts  = (fst $1) tal args in
  1362:                      let (n, t, _) = (fst $3) ts args in
  1363:                      let init = $4 args in
  1364:                      (* Before we proceed we must create the variable *)
  1365:                      let v = mkTemp n t in
  1366:                      (* Now we parse the rest *)
  1367:                      let rest = $6 mkTemp loc ((n, Fv v) :: args) in
  1368:                      (* Now we add the initialization instruction to the
  1369:                       * front *)
  1370:                      match init with
  1371:                        NoInit -> rest
  1372:                      | InitExp e ->
  1373:                          mkStmtOneInstr (Set((Var v, NoOffset), e, loc))
  1374:                          :: rest
  1375:                      | InitCall (f, args) ->
  1376:                          mkStmtOneInstr (Call(Some (Var v, NoOffset),
  1377:                                               Lval f, args, loc))
  1378:                          :: rest
  1379: 
  1380:                                                            )
  1381:                  }
  1382: ;
  1383: 
  1384: instr_list:
  1385:      /*(* Set this rule to very low precedence to ensure that we shift as
  1386:           many instructions as possible *)*/
  1387:     instr   %prec COMMA
  1388:                  { (fun loc args -> [ ((fst $1) loc args) ]) }
  1389: |   ARG_I        { let currentArg = $1 in
  1390:                    (fun loc args ->
  1391:                        match getArg currentArg args with
  1392:                        | FI il -> il
  1393:                        | a -> wrongArgType currentArg "instrs" a)
  1394:                  }
  1395: |   instr instr_list
  1396:                  { (fun loc args ->
  1397:                       let this = (fst $1) loc args in
  1398:                       this :: ($2 loc args))
  1399:                  }
  1400: ;
  1401: 
  1402: 
  1403: maybe_init:
  1404: |                               { (fun args -> NoInit) }
  1405: | EQ expression                 { (fun args -> InitExp ((fst $2) args)) }
  1406: | EQ lval LPAREN arguments RPAREN
  1407:                                 { (fun args ->
  1408:                                     InitCall((fst $2) args, (fst $4) args)) }
  1409: ;
  1410: %%
  1411: 
End data section to src/flx_cil_formatparse.mly[1]
Start ocaml section to src/flx_cil_mergecil.ml[1 /1 ]
     1: # 11709 "./lpsrc/flx_cil.ipk"
     2: (* mergecil.ml *)
     3: (* This module is responsible for merging multiple CIL source trees into
     4:  * a single, coherent CIL tree which contains the union of all the
     5:  * definitions in the source files.  It effectively acts like a linker,
     6:  * but at the source code level instead of the object code level. *)
     7: 
     8: 
     9: module P = Flx_cil_pretty
    10: open Flx_cil_cil
    11: module E = Flx_cil_errormsg
    12: module H = Hashtbl
    13: open Flx_cil_trace
    14: 
    15: let debugMerge = false
    16: let debugInlines = false
    17: 
    18: let ignore_merge_conflicts = ref false
    19: 
    20: (* Try to merge structure with the same name. However, do not complain if
    21:  * they are not the same *)
    22: let mergeSynonyms = true
    23: 
    24: 
    25: (** Whether to use path compression *)
    26: let usePathCompression = false
    27: 
    28: (* Try to merge definitions of inline functions. They can appear in multiple
    29:  * files and we would like them all to be the same. This can slow down the
    30:  * merger an order of magnitude !!! *)
    31: let mergeInlines = true
    32: 
    33: let mergeInlinesRepeat = mergeInlines && true
    34: 
    35: let mergeInlinesWithAlphaConvert = mergeInlines && true
    36: 
    37: (* when true, merge duplicate definitions of externally-visible functions;
    38:  * this uses a mechanism which is faster than the one for inline functions,
    39:  * but only probabilistically accurate *)
    40: let mergeGlobals = true
    41: 
    42: 
    43: (* Return true if 's' starts with the prefix 'p' *)
    44: let prefix p s =
    45:   let lp = String.length p in
    46:   let ls = String.length s in
    47:   lp <= ls && String.sub s 0 lp = p
    48: 
    49: 
    50: 
    51: (* A name is identified by the index of the file in which it occurs (starting
    52:  * at 0 with the first file) and by the actual name. We'll keep name spaces
    53:  * separate *)
    54: 
    55: (* We define a data structure for the equivalence classes *)
    56: type 'a node =
    57:     { nname: string;   (* The actual name *)
    58:       nfidx: int;      (* The file index *)
    59:       ndata: 'a;       (* Data associated with the node *)
    60:       mutable nloc: (location * int) option;
    61:       (* location where defined and index within the file of the definition.
    62:        * If None then it means that this node actually DOES NOT appear in the
    63:        * given file. In rare occasions we need to talk in a given file about
    64:        * types that are not defined in that file. This happens with undefined
    65:        * structures but also due to cross-contamination of types in a few of
    66:        * the cases of combineType (see the definition of combineTypes). We
    67:        * try never to choose as representatives nodes without a definition.
    68:        * We also choose as representative the one that appears earliest *)
    69:       mutable nrep: 'a node;  (* A pointer to another node in its class (one
    70:                                * closer to the representative). The nrep node
    71:                                * is always in an earlier file, except for the
    72:                                * case where a name is undefined in one file
    73:                                * and defined in a later file. If this pointer
    74:                                * points to the node itself then this is the
    75:                                * representative.  *)
    76:       mutable nmergedSyns: bool (* Whether we have merged the synonyms for
    77:                                  * the node of this name *)
    78:     }
    79: 
    80: let d_nloc () (lo: (location * int) option) : P.doc =
    81:   match lo with
    82:     None -> P.text "None"
    83:   | Some (l, idx) -> P.dprintf "Some(%d at %a)" idx d_loc l
    84: 
    85: (* Make a node with a self loop. This is quite tricky. *)
    86: let mkSelfNode (eq: (int * string, 'a node) H.t) (* The equivalence table *)
    87:                (syn: (string, 'a node) H.t) (* The synonyms table *)
    88:                (fidx: int) (name: string) (data: 'a)
    89:                (l: (location * int) option) =
    90:   let res = { nname = name; nfidx = fidx; ndata = data; nloc = l;
    91:               nrep  = Obj.magic 1; nmergedSyns = false; } in
    92:   res.nrep <- res; (* Make the self cycle *)
    93:   H.add eq (fidx, name) res; (* Add it to the proper table *)
    94:   if mergeSynonyms && not (prefix "__anon" name) then
    95:     H.add syn name res;
    96:   res
    97: 
    98: let debugFind = false
    99: 
   100: (* Find the representative with or without path compression *)
   101: let rec find (pathcomp: bool) (nd: 'a node) =
   102:   if debugFind then
   103:     ignore (E.log "  find %s(%d)\n" nd.nname nd.nfidx);
   104:   if nd.nrep == nd then begin
   105:     if debugFind then
   106:       ignore (E.log "  = %s(%d)\n" nd.nname nd.nfidx);
   107:     nd
   108:   end else begin
   109:     let res = find pathcomp nd.nrep in
   110:     if usePathCompression && pathcomp && nd.nrep != res then
   111:       nd.nrep <- res; (* Compress the paths *)
   112:     res
   113:   end
   114: 
   115: 
   116: (* Union two nodes and return the new representative. We prefer as the
   117:  * representative a node defined earlier. We try not to use as
   118:  * representatives nodes that are not defined in their files. We return a
   119:  * function for undoing the union. Make sure that between the union and the
   120:  * undo you do not do path compression *)
   121: let union (nd1: 'a node) (nd2: 'a node) : 'a node * (unit -> unit) =
   122:   (* Move to the representatives *)
   123:   let nd1 = find true nd1 in
   124:   let nd2 = find true nd2 in
   125:   if nd1 == nd2 then begin
   126:     (* It can happen that we are trying to union two nodes that are already
   127:      * equivalent. This is because between the time we check that two nodes
   128:      * are not already equivalent and the time we invoke the union operation
   129:      * we check type isomorphism which might change the equivalence classes *)
   130: (*
   131:     ignore (warn "unioning already equivalent nodes for %s(%d)"
   132:               nd1.nname nd1.nfidx);
   133: *)
   134:     nd1, fun x -> x
   135:   end else begin
   136:     let rep, norep = (* Choose the representative *)
   137:       if (nd1.nloc != None) =  (nd2.nloc != None) then
   138:         (* They have the same defined status. Choose the earliest *)
   139:         if nd1.nfidx < nd2.nfidx then nd1, nd2
   140:         else if nd1.nfidx > nd2.nfidx then nd2, nd1
   141:         else (* In the same file. Choose the one with the earliest index *) begin
   142:           match nd1.nloc, nd2.nloc with
   143:             Some (_, didx1), Some (_, didx2) ->
   144:               if didx1 < didx2 then nd1, nd2 else
   145:               if didx1 > didx2 then nd2, nd1
   146:               else begin
   147:               ignore (warn
   148:                         "Merging two elements (%s and %s) in the same file (%d) with the same idx (%d) within the file"
   149:                         nd1.nname nd2.nname nd1.nfidx didx1);
   150:                 nd1, nd2
   151:               end
   152:           | _, _ -> (* both none. Does not matter which one we choose. Should
   153:               * not happen though. *)
   154:               (* sm: it does happen quite a bit when, e.g. merging STLport with
   155:                * some client source; I'm disabling the warning since it supposedly
   156:                * is harmless anyway, so is useless noise *)
   157:               (* sm: re-enabling on claim it now will probably not happen *)
   158:               ignore (warn "Merging two undefined elements in the same file: %s and %s\n" nd1.nname nd2.nname);
   159:               nd1, nd2
   160:         end
   161:       else (* One is defined, the other is not. Choose the defined one *)
   162:         if nd1.nloc != None then nd1, nd2 else nd2, nd1
   163:     in
   164:     let oldrep = norep.nrep in
   165:     norep.nrep <- rep;
   166:     rep, (fun () -> norep.nrep <- oldrep)
   167:   end
   168: (*
   169: let union (nd1: 'a node) (nd2: 'a node) : 'a node * (unit -> unit) =
   170:   if nd1 == nd2 && nd1.nname = "!!!intEnumInfo!!!" then begin
   171:     ignore (warn "unioning two identical nodes for %s(%d)"
   172:               nd1.nname nd1.nfidx);
   173:     nd1, fun x -> x
   174:   end else
   175:     union nd1 nd2
   176: *)
   177: (* Find the representative for a node and compress the paths in the process *)
   178: let findReplacement
   179:     (pathcomp: bool)
   180:     (eq: (int * string, 'a node) H.t)
   181:     (fidx: int)
   182:     (name: string) : ('a * int) option =
   183:   if debugFind then
   184:     ignore (E.log "findReplacement for %s(%d)\n" name fidx);
   185:   try
   186:     let nd = H.find eq (fidx, name) in
   187:     if nd.nrep == nd then begin
   188:       if debugFind then
   189:         ignore (E.log "  is a representative\n");
   190:       None (* No replacement if this is the representative of its class *)
   191:     end else
   192:       let rep = find pathcomp nd in
   193:       if rep != rep.nrep then
   194:         E.s (bug "find does not return the representative\n");
   195:       if debugFind then
   196:         ignore (E.log "  RES = %s(%d)\n" rep.nname rep.nfidx);
   197:       Some (rep.ndata, rep.nfidx)
   198:   with Not_found -> begin
   199:     if debugFind then
   200:       ignore (E.log "  not found in the map\n");
   201:     None
   202:   end
   203: 
   204: (* Make a node if one does not already exist. Otherwise return the
   205:  * representative *)
   206: let getNode    (eq: (int * string, 'a node) H.t)
   207:                (syn: (string, 'a node) H.t)
   208:                (fidx: int) (name: string) (data: 'a)
   209:                (l: (location * int) option) =
   210:   let debugGetNode = false in
   211:   if debugGetNode then
   212:     ignore (E.log "getNode(%s(%d), %a)\n"
   213:               name fidx d_nloc l);
   214:   try
   215:     let res = H.find eq (fidx, name) in
   216: 
   217:     (match res.nloc, l with
   218:       (* Maybe we have a better location now *)
   219:       None, Some _ -> res.nloc <- l
   220:     | Some (old_l, old_idx), Some (l, idx) ->
   221:         if old_idx != idx then
   222:           ignore (warn "Duplicate definition of node %s(%d) at indices %d(%a) and %d(%a)"
   223:                     name fidx old_idx d_loc old_l idx d_loc l)
   224:         else
   225:           ()
   226: 
   227:     | _, _ -> ());
   228:     if debugGetNode then
   229:       ignore (E.log "  node already found\n");
   230:     find false res (* No path compression *)
   231:   with Not_found -> begin
   232:     let res = mkSelfNode eq syn fidx name data l in
   233:     if debugGetNode then
   234:       ignore (E.log "   made a new one\n");
   235:     res
   236:   end
   237: 
   238: 
   239: 
   240: (* Dump a graph *)
   241: let dumpGraph (what: string) (eq: (int * string, 'a node) H.t) : unit =
   242:   ignore (E.log "Equivalence graph for %s is:\n" what);
   243:   H.iter (fun (fidx, name) nd ->
   244:     ignore (E.log "  %s(%d) %s-> "
   245:               name fidx (if nd.nloc = None then "(undef)" else ""));
   246:     if nd.nrep == nd then
   247:       ignore (E.log "*\n")
   248:     else
   249:       ignore (E.log " %s(%d)\n" nd.nrep.nname nd.nrep.nfidx ))
   250:     eq
   251: 
   252: 
   253: 
   254: 
   255: (* For each name space we define a set of equivalence classes *)
   256: let vEq: (int * string, varinfo node) H.t = H.create 111 (* Vars *)
   257: let sEq: (int * string, compinfo node) H.t = H.create 111 (* Struct + union *)
   258: let eEq: (int * string, enuminfo node) H.t = H.create 111 (* Enums *)
   259: let tEq: (int * string, typeinfo node) H.t = H.create 111 (* Type names*)
   260: let iEq: (int * string, varinfo node) H.t = H.create 111 (* Inlines *)
   261: 
   262: (* Sometimes we want to merge synonyms. We keep some tables indexed by names.
   263:  * Each name is mapped to multiple exntries *)
   264: let vSyn: (string, varinfo node) H.t = H.create 111 (* Not actually used *)
   265: let iSyn: (string, varinfo node) H.t = H.create 111 (* Inlines *)
   266: let sSyn: (string, compinfo node) H.t = H.create 111
   267: let eSyn: (string, enuminfo node) H.t = H.create 111
   268: let tSyn: (string, typeinfo node) H.t = H.create 111
   269: 
   270: (** A global environment for variables. Put in here only the non-static
   271:   * variables, indexed by their name.  *)
   272: let vEnv : (string, varinfo node) H.t = H.create 111
   273: 
   274: 
   275: (* A set of inline functions indexed by their printout ! *)
   276: let inlineBodies : (P.doc, varinfo node) H.t = H.create 111
   277: 
   278: (** A number of alpha conversion tables. We ought to keep one table for each
   279:  * name space. Unfortunately, because of the way the C lexer works, type
   280:  * names must be different from variable names!! We one alpha table both for
   281:  * variables and types. *)
   282: let vtAlpha : (string, alphaTableData ref) H.t = H.create 57 (* Variables and
   283:                                                              * types *)
   284: let sAlpha : (string, alphaTableData ref) H.t = H.create 57 (* Structures and
   285:                                                              * unions have
   286:                                                              * the same name
   287:                                                              * space *)
   288: let eAlpha : (string, alphaTableData ref) H.t = H.create 57 (* Enumerations *)
   289: 
   290: 
   291: (** Keep track, for all global function definitions, of the names of the formal
   292:  * arguments. They might change during merging of function types if the
   293:  * prototype occurs after the function definition and uses different names.
   294:  * We'll restore the names at the end *)
   295: let formalNames: (int * string, string list) H.t = H.create 111
   296: 
   297: 
   298: (* Accumulate here the globals in the merged file *)
   299: let theFileTypes = ref []
   300: let theFile      = ref []
   301: 
   302: (* add 'g' to the merged file *)
   303: let mergePushGlobal (g: global) : unit =
   304:   pushGlobal g ~types:theFileTypes ~variables:theFile
   305: 
   306: let mergePushGlobals gl = List.iter mergePushGlobal gl
   307: 
   308: 
   309: (* The index of the current file being scanned *)
   310: let currentFidx = ref 0
   311: 
   312: let currentDeclIdx = ref 0 (* The index of the definition in a file. This is
   313:                             * maintained both in pass 1 and in pass 2. Make
   314:                             * sure you count the same things in both passes. *)
   315: (* Keep here the file names *)
   316: let fileNames : (int, string) H.t = H.create 113
   317: 
   318: 
   319: 
   320: (* Remember the composite types that we have already declared *)
   321: let emittedCompDecls: (string, bool) H.t = H.create 113
   322: (* Remember the variables also *)
   323: let emittedVarDecls: (string, bool) H.t = H.create 113
   324: 
   325: (* also keep track of externally-visible function definitions;
   326:  * name maps to declaration, location, and semantic checksum *)
   327: let emittedFunDefn: (string, fundec * location * int) H.t = H.create 113
   328: (* and same for variable definitions; name maps to GVar fields *)
   329: let emittedVarDefn: (string, varinfo * init option * location) H.t = H.create 113
   330: 
   331: (** A mapping from the new names to the original names. Used in PASS2 when we
   332:  * rename variables. *)
   333: let originalVarNames: (string, string) H.t = H.create 113
   334: 
   335: (* Initialize the module *)
   336: let init () =
   337:   H.clear sAlpha;
   338:   H.clear eAlpha;
   339:   H.clear vtAlpha;
   340: 
   341:   H.clear vEnv;
   342: 
   343:   H.clear vEq;
   344:   H.clear sEq;
   345:   H.clear eEq;
   346:   H.clear tEq;
   347:   H.clear iEq;
   348: 
   349:   H.clear vSyn;
   350:   H.clear sSyn;
   351:   H.clear eSyn;
   352:   H.clear tSyn;
   353:   H.clear iSyn;
   354: 
   355:   theFile := [];
   356:   theFileTypes := [];
   357: 
   358:   H.clear formalNames;
   359:   H.clear inlineBodies;
   360: 
   361:   currentFidx := 0;
   362:   currentDeclIdx := 0;
   363:   H.clear fileNames;
   364: 
   365:   H.clear emittedVarDecls;
   366:   H.clear emittedCompDecls;
   367: 
   368:   H.clear emittedFunDefn;
   369:   H.clear emittedVarDefn;
   370: 
   371:   H.clear originalVarNames
   372: 
   373: 
   374: (* Some enumerations have to be turned into an integer. We implement this by
   375:  * introducing a special enumeration type which we'll recognize later to be
   376:  * an integer *)
   377: let intEnumInfo =
   378:   { ename = "!!!intEnumInfo!!!"; (* This is otherwise invalid *)
   379:     eitems = [];
   380:     eattr = [];
   381:     ereferenced = false;
   382:   }
   383: (* And add it to the equivalence graph *)
   384: let intEnumInfoNode =
   385:   getNode eEq eSyn 0 intEnumInfo.ename intEnumInfo
   386:                      (Some (locUnknown, 0))
   387: 
   388:     (* Combine the types. Raises the Failure exception with an error message.
   389:      * isdef says whether the new type is for a definition *)
   390: type combineWhat =
   391:     CombineFundef (* The new definition is for a function definition. The old
   392:                    * is for a prototype *)
   393:   | CombineFunarg (* Comparing a function argument type with an old prototype
   394:                    * arg *)
   395:   | CombineFunret (* Comparing the return of a function with that from an old
   396:                    * prototype *)
   397:   | CombineOther
   398: 
   399: 
   400: let rec combineTypes (what: combineWhat)
   401:                      (oldfidx: int)  (oldt: typ)
   402:                      (fidx: int) (t: typ)  : typ =
   403:   match oldt, t with
   404:   | TVoid olda, TVoid a -> TVoid (addAttributes olda a)
   405:   | TInt (oldik, olda), TInt (ik, a) ->
   406:       let combineIK oldk k =
   407:         if oldk == k then oldk else
   408:         (* GCC allows a function definition to have a more precise integer
   409:          * type than a prototype that says "int" *)
   410:         if not !msvcMode && oldk = IInt && bitsSizeOf t <= 32
   411:            && (what = CombineFunarg || what = CombineFunret)
   412:         then
   413:           k
   414:         else (
   415:           let msg =
   416:             P.sprint ~width:80
   417:               (P.dprintf
   418:                  "(different integer types %a and %a)"
   419:                  d_type oldt d_type t) in
   420:           raise (Failure msg)
   421:         )
   422:       in
   423:       TInt (combineIK oldik ik, addAttributes olda a)
   424: 
   425:   | TFloat (oldfk, olda), TFloat (fk, a) ->
   426:       let combineFK oldk k =
   427:         if oldk == k then oldk else
   428:         (* GCC allows a function definition to have a more precise integer
   429:          * type than a prototype that says "double" *)
   430:         if not !msvcMode && oldk = FDouble && k = FFloat
   431:            && (what = CombineFunarg || what = CombineFunret)
   432:         then
   433:           k
   434:         else
   435:           raise (Failure "(different floating point types)")
   436:       in
   437:       TFloat (combineFK oldfk fk, addAttributes olda a)
   438: 
   439:   | TEnum (oldei, olda), TEnum (ei, a) ->
   440:       (* Matching enumerations always succeeds. But sometimes it maps both
   441:        * enumerations to integers *)
   442:       matchEnumInfo oldfidx oldei fidx ei;
   443:       TEnum (oldei, addAttributes olda a)
   444: 
   445: 
   446:         (* Strange one. But seems to be handled by GCC *)
   447:   | TEnum (oldei, olda) , TInt(IInt, a) -> TEnum(oldei,
   448:                                                  addAttributes olda a)
   449: 
   450:         (* Strange one. But seems to be handled by GCC. Warning. Here we are
   451:          * leaking types from new to old  *)
   452:   | TInt(IInt, olda), TEnum (ei, a) -> TEnum(ei, addAttributes olda a)
   453: 
   454:   | TComp (oldci, olda) , TComp (ci, a) ->
   455:       matchCompInfo oldfidx oldci fidx ci;
   456:       (* If we get here we were successful *)
   457:       TComp (oldci, addAttributes olda a)
   458: 
   459:   | TArray (oldbt, oldsz, olda), TArray (bt, sz, a) ->
   460:       let combbt = combineTypes CombineOther oldfidx oldbt fidx bt in
   461:       let combinesz =
   462:         match oldsz, sz with
   463:           None, Some _ -> sz
   464:         | Some _, None -> oldsz
   465:         | None, None -> oldsz
   466:         | Some oldsz', Some sz' ->
   467:             let samesz =
   468:               match constFold true oldsz', constFold true sz' with
   469:                 Const(CInt64(oldi, _, _)), Const(CInt64(i, _, _)) -> oldi = i
   470:               | _, _ -> false
   471:             in
   472:             if samesz then oldsz else
   473:             raise (Failure "(different array sizes)")
   474:       in
   475:       TArray (combbt, combinesz, addAttributes olda a)
   476: 
   477:   | TPtr (oldbt, olda), TPtr (bt, a) ->
   478:       TPtr (combineTypes CombineOther oldfidx oldbt fidx bt,
   479:             addAttributes olda a)
   480: 
   481:         (* WARNING: In this case we are leaking types from new to old !! *)
   482:   | TFun (_, _, _, [Attr("missingproto",_)]), TFun _ -> t
   483: 
   484: 
   485:   | TFun _, TFun (_, _, _, [Attr("missingproto",_)]) -> oldt
   486: 
   487:   | TFun (oldrt, oldargs, oldva, olda), TFun (rt, args, va, a) ->
   488:       let newrt =
   489:         combineTypes
   490:           (if what = CombineFundef then CombineFunret else CombineOther)
   491:           oldfidx oldrt fidx rt
   492:       in
   493:       if oldva != va then
   494:         raise (Failure "(diferent vararg specifiers)");
   495:       (* If one does not have arguments, believe the one with the
   496:       * arguments *)
   497:       let newargs =
   498:         if oldargs = None then args else
   499:         if args = None then oldargs else
   500:         let oldargslist = argsToList oldargs in
   501:         let argslist = argsToList args in
   502:         if List.length oldargslist <> List.length argslist then
   503:           raise (Failure "(different number of arguments)")
   504:         else begin
   505:           (* Go over the arguments and update the old ones with the
   506:           * adjusted types *)
   507:           Some
   508:             (List.map2
   509:                (fun (on, ot, oa) (an, at, aa) ->
   510:                  let n = if an <> "" then an else on in
   511:                  let t =
   512:                    combineTypes
   513:                      (if what = CombineFundef then
   514:                        CombineFunarg else CombineOther)
   515:                      oldfidx ot fidx at
   516:                  in
   517:                  let a = addAttributes oa aa in
   518:                  (n, t, a))
   519:                oldargslist argslist)
   520:         end
   521:       in
   522:       TFun (newrt, newargs, oldva, addAttributes olda a)
   523: 
   524:   | TBuiltin_va_list olda, TBuiltin_va_list a ->
   525:       TBuiltin_va_list (addAttributes olda a)
   526: 
   527:   | TNamed (oldt, olda), TNamed (t, a) ->
   528:       matchTypeInfo oldfidx oldt fidx t;
   529:       (* If we get here we were able to match *)
   530:       TNamed(oldt, addAttributes olda a)
   531: 
   532:         (* Unroll first the new type *)
   533:   | _, TNamed (t, a) ->
   534:       let res = combineTypes what oldfidx oldt fidx t.ttype in
   535:       typeAddAttributes a res
   536: 
   537:         (* And unroll the old type as well if necessary *)
   538:   | TNamed (oldt, a), _ ->
   539:       let res = combineTypes what oldfidx oldt.ttype fidx t in
   540:       typeAddAttributes a res
   541: 
   542:   | _ -> (
   543:       (* raise (Failure "(different type constructors)") *)
   544:       let msg:string = (P.sprint 1000 (P.dprintf "(different type constructors: %a vs. %a)"
   545:                                                  d_type oldt  d_type t)) in
   546:       raise (Failure msg)
   547:     )
   548: 
   549: 
   550: (* Match two compinfos and throw a Failure if they do not match *)
   551: and matchCompInfo (oldfidx: int) (oldci: compinfo)
   552:                      (fidx: int)    (ci: compinfo) : unit =
   553:   if oldci.cstruct <> ci.cstruct then
   554:     raise (Failure "(different struct/union types)");
   555:   (* See if we have a mapping already *)
   556:   (* Make the nodes if not already made. Actually return the
   557:   * representatives *)
   558:   let oldcinode = getNode sEq sSyn oldfidx oldci.cname oldci None in
   559:   let    cinode = getNode sEq sSyn    fidx    ci.cname    ci None in
   560:   if oldcinode == cinode then (* We already know they are the same *)
   561:         ()
   562:   else begin
   563:     (* Replace with the representative data *)
   564:     let oldci = oldcinode.ndata in
   565:     let oldfidx = oldcinode.nfidx in
   566:     let ci = cinode.ndata in
   567:     let fidx = cinode.nfidx in
   568: 
   569:     let old_len = List.length oldci.cfields in
   570:     let len = List.length ci.cfields in
   571:     (* It is easy to catch here the case when the new structure is undefined
   572:      * and the old one was defined. We just reuse the old *)
   573:     (* More complicated is the case when the old one is not defined but the
   574:      * new one is. We still reuse the old one and we'll take care of defining
   575:      * it later with the new fields. *)
   576:     if len <> 0 && old_len <> 0 && old_len <> len then (
   577:       let curLoc = !currentLoc in     (* d_global blows this away.. *)
   578:       (trace "merge" (P.dprintf "different # of fields\n%d: %a\n%d: %a\n"
   579:                                 old_len  d_global (GCompTag(oldci,locUnknown))
   580:                                     len  d_global (GCompTag(ci,locUnknown))
   581:                      ));
   582:       currentLoc := curLoc;
   583:       let msg = Printf.sprintf
   584:           "(different number of fields in %s and %s: %d != %d.)"
   585:           oldci.cname ci.cname old_len len in
   586:       raise (Failure msg)
   587:     );
   588:     (* We check that they are defined in the same way. While doing this there
   589:      * might be recursion and we have to watch for going into an infinite
   590:      * loop. So we add the assumption that they are equal *)
   591:     let newrep, undo = union oldcinode cinode in
   592:     (* We check the fields but watch for Failure. We only do the check when
   593:      * the lengths are the same. Due to the code above this the other
   594:      * possibility is that one of the length is 0, in which case we reuse the
   595:      * old compinfo. *)
   596:     if old_len = len then
   597:       (try
   598:         List.iter2
   599:           (fun oldf f ->
   600:             if oldf.fbitfield <> f.fbitfield then
   601:               raise (Failure "(different bitfield info)");
   602:             if oldf.fattr <> f.fattr then
   603:               raise (Failure "(different field attributes)");
   604:             (* Make sure the types are compatible *)
   605:             let newtype =
   606:               combineTypes CombineOther oldfidx oldf.ftype fidx f.ftype
   607:             in
   608:             (* Change the type in the representative *)
   609:             oldf.ftype <- newtype;
   610:           )
   611:           oldci.cfields ci.cfields
   612:       with Failure reason -> begin
   613:         (* Our assumption was wrong. Forget the isomorphism *)
   614:         undo ();
   615:         let msg =
   616:           P.sprint ~width:80
   617:             (P.dprintf
   618:                "\n\tFailed assumption that %s and %s are isomorphic %s@!%a@!%a"
   619:                (compFullName oldci) (compFullName ci) reason
   620:                dn_global (GCompTag(oldci,locUnknown))
   621:                dn_global (GCompTag(ci,locUnknown)))
   622:                in
   623:         raise (Failure msg)
   624:       end);
   625:     (* We get here when we succeeded checking that they are equal *)
   626:     newrep.ndata.cattr <- addAttributes oldci.cattr ci.cattr;
   627:     ()
   628:   end
   629: 
   630: (* Match two enuminfos and throw a Failure if they do not match *)
   631: and matchEnumInfo (oldfidx: int) (oldei: enuminfo)
   632:                    (fidx: int)    (ei: enuminfo) : unit =
   633:   (* Find the node for this enum, no path compression. *)
   634:   let oldeinode = getNode eEq eSyn oldfidx oldei.ename oldei None in
   635:   let einode    = getNode eEq eSyn fidx ei.ename ei None in
   636:   if oldeinode == einode then (* We already know they are the same *)
   637:     ()
   638:   else begin
   639:     (* Replace with the representative data *)
   640:     let oldei = oldeinode.ndata in
   641:     let oldfidx = oldeinode.nfidx in
   642:     let ei = einode.ndata in
   643:     let fidx = einode.nfidx in
   644:     (* Try to match them. But if you cannot just make them both integers *)
   645:     try
   646:       (* We do not have a mapping. They better be defined in the same way *)
   647:       if List.length oldei.eitems <> List.length ei.eitems then
   648:         raise (Failure "(different number of enumeration elements)");
   649:       (* We check that they are defined in the same way. This is a fairly
   650:       * conservative check. *)
   651:       List.iter2
   652:         (fun (old_iname, old_iv, _) (iname, iv, _) ->
   653:           if old_iname <> iname then
   654:             raise (Failure "(different names for enumeration items)");
   655:           let samev =
   656:             match constFold true old_iv, constFold true iv with
   657:               Const(CInt64(oldi, _, _)), Const(CInt64(i, _, _)) -> oldi = i
   658:             | _ -> false
   659:           in
   660:           if not samev then
   661:             raise (Failure "(different values for enumeration items)"))
   662:         oldei.eitems ei.eitems;
   663:       (* Set the representative *)
   664:       let newrep, _ = union oldeinode einode in
   665:       (* We get here if the enumerations match *)
   666:       newrep.ndata.eattr <- addAttributes oldei.eattr ei.eattr;
   667:       ()
   668:     with Failure msg -> begin
   669:       (* Get here if you cannot merge two enumeration nodes *)
   670:       if oldeinode != intEnumInfoNode then begin
   671:         let _ = union oldeinode intEnumInfoNode in ()
   672:       end;
   673:       if einode != intEnumInfoNode then begin
   674:         let _ = union einode intEnumInfoNode in ()
   675:       end;
   676:     end
   677:   end
   678: 
   679: 
   680: (* Match two typeinfos and throw a Failure if they do not match *)
   681: and matchTypeInfo (oldfidx: int) (oldti: typeinfo)
   682:                    (fidx: int)      (ti: typeinfo) : unit =
   683:   if oldti.tname = "" || ti.tname = "" then
   684:     E.s (bug "matchTypeInfo for anonymous type\n");
   685:   (* Find the node for this enum, no path compression. *)
   686:   let oldtnode = getNode tEq tSyn oldfidx oldti.tname oldti None in
   687:   let    tnode = getNode tEq tSyn    fidx ti.tname    ti None in
   688:   if oldtnode == tnode then (* We already know they are the same *)
   689:     ()
   690:   else begin
   691:     (* Replace with the representative data *)
   692:     let oldti = oldtnode.ndata in
   693:     let oldfidx = oldtnode.nfidx in
   694:     let ti = tnode.ndata in
   695:     let fidx = tnode.nfidx in
   696:     (* Flx_cil_check that they are the same *)
   697:     (try
   698:       ignore (combineTypes CombineOther oldfidx oldti.ttype fidx ti.ttype);
   699:     with Failure reason -> begin
   700:       let msg =
   701:         P.sprint ~width:80
   702:           (P.dprintf
   703:              "\n\tFailed assumption that %s and %s are isomorphic %s"
   704:              oldti.tname ti.tname reason) in
   705:       raise (Failure msg)
   706:     end);
   707:     let _ = union oldtnode tnode in
   708:     ()
   709:   end
   710: 
   711: (* Scan all files and do two things *)
   712: (* 1. Initialize the alpha renaming tables with the names of the globals so
   713:  * that when we come in the second pass to generate new names, we do not run
   714:  * into conflicts.  *)
   715: (* 2. For all declarations of globals unify their types. In the process
   716:  * construct a set of equivalence classes on type names, structure and
   717:  * enumeration tags  *)
   718: (* 3. We clean the referenced flags *)
   719: 
   720: let rec oneFilePass1 (f:file) : unit =
   721:   H.add fileNames !currentFidx f.fileName;
   722:   if debugMerge || !E.verboseFlag then
   723:     ignore (E.log "Pre-merging (%d) %s\n" !currentFidx f.fileName);
   724:   currentDeclIdx := 0;
   725:   if f.globinitcalled || f.globinit <> None then
   726:     E.s (E.warn "Merging file %s has global initializer" f.fileName);
   727: 
   728:   (* We scan each file and we look at all global varinfo. We see if globals
   729:    * with the same name have been encountered before and we merge those types
   730:    * *)
   731:   let matchVarinfo (vi: varinfo) (l: location * int) =
   732:     ignore (registerAlphaName vtAlpha None vi.vname);
   733:     (* Make a node for it and put it in vEq *)
   734:     let vinode = mkSelfNode vEq vSyn !currentFidx vi.vname vi (Some l) in
   735:     try
   736:       let oldvinode = find true (H.find vEnv vi.vname) in
   737:       let oldloc, _ =
   738:         match oldvinode.nloc with
   739:           None -> E.s (bug "old variable is undefined")
   740:         | Some l -> l
   741:       in
   742:       let oldvi     = oldvinode.ndata in
   743:       (* There is an old definition. We must combine the types. Do this first
   744:        * because it might fail *)
   745:       let newtype =
   746:         try
   747:           combineTypes CombineOther
   748:             oldvinode.nfidx oldvi.vtype
   749:             !currentFidx vi.vtype;
   750:         with (Failure reason) -> begin
   751:           (* Go ahead *)
   752:           let f = if !ignore_merge_conflicts then warn else error in
   753:           ignore (f "Incompatible declaration for %s (from %s(%d)).@! Previous was at %a (from %s (%d)) %s "
   754:                     vi.vname (H.find fileNames !currentFidx) !currentFidx
   755:                     d_loc oldloc
   756:                     (H.find fileNames oldvinode.nfidx) oldvinode.nfidx
   757:                     reason);
   758:           raise Not_found
   759:         end
   760:       in
   761:       let newrep, _ = union oldvinode vinode in
   762:       (* We do not want to turn non-"const" globals into "const" one. That
   763:        * can happen if one file declares the variable a non-const while
   764:        * others declare it as "const". *)
   765:       if hasAttribute "const" (typeAttrs vi.vtype) !=
   766:          hasAttribute "const" (typeAttrs oldvi.vtype) then begin
   767:         newrep.ndata.vtype <- typeRemoveAttributes ["const"] newtype;
   768:       end else begin
   769:         newrep.ndata.vtype <- newtype;
   770:       end;
   771:       (* clean up the storage.  *)
   772:       let newstorage =
   773:         if vi.vstorage = oldvi.vstorage || vi.vstorage = Extern then
   774:           oldvi.vstorage
   775:         else if oldvi.vstorage = Extern then vi.vstorage
   776:         (* Sometimes we turn the NoStorage specifier into Static for inline
   777:          * functions *)
   778:         else if oldvi.vstorage = Static &&
   779:                 vi.vstorage = NoStorage then Static
   780:         else begin
   781:           ignore (warn "Inconsistent storage specification for %s. Now is %a and previous was %a at %a"
   782:                     vi.vname d_storage vi.vstorage d_storage oldvi.vstorage
   783:                     d_loc oldloc);
   784:           vi.vstorage
   785:         end
   786:       in
   787:       newrep.ndata.vstorage <- newstorage;
   788:       newrep.ndata.vattr <- addAttributes oldvi.vattr vi.vattr;
   789:       ()
   790:     with Not_found -> (* Not present in the previous files. Remember it for
   791:                        * later  *)
   792:       H.add vEnv vi.vname vinode
   793: 
   794:   in
   795:   List.iter
   796:     (function
   797:       | GVarDecl (vi, l) | GVar (vi, _, l) ->
   798:           currentLoc := l;
   799:           incr currentDeclIdx;
   800:           vi.vreferenced <- false;
   801:           if vi.vstorage <> Static then begin
   802:             matchVarinfo vi (l, !currentDeclIdx);
   803:           end
   804: 
   805:       | GFun (fdec, l) ->
   806:           currentLoc := l;
   807:           incr currentDeclIdx;
   808:           (* Save the names of the formal arguments *)
   809:           let _, args, _, _ = splitFunctionTypeVI fdec.svar in
   810:           H.add formalNames (!currentFidx, fdec.svar.vname)
   811:             (List.map (fun (fn, _, _) -> fn) (argsToList args));
   812:           fdec.svar.vreferenced <- false;
   813:           (* Force inline functions to be static. *)
   814:           (* GN: This turns out to be wrong. inline functions are external,
   815:            * unless specified to be static. *)
   816:           (*
   817:           if fdec.svar.vinline && fdec.svar.vstorage = NoStorage then
   818:             fdec.svar.vstorage <- Static;
   819:           *)
   820:           if fdec.svar.vstorage <> Static then begin
   821:             matchVarinfo fdec.svar (l, !currentDeclIdx)
   822:           end else begin
   823:             if fdec.svar.vinline && mergeInlines then
   824:               (* Just create the nodes for inline functions *)
   825:               ignore (getNode iEq iSyn !currentFidx
   826:                         fdec.svar.vname fdec.svar (Some (l, !currentDeclIdx)))
   827:           end
   828:               (* Make nodes for the defined type and structure tags *)
   829:       | GType (t, l) ->
   830:           incr currentDeclIdx;
   831:           t.treferenced <- false;
   832:           if t.tname <> "" then (* The empty names are just for introducing
   833:                                  * undefined comp tags *)
   834:             ignore (getNode tEq tSyn !currentFidx t.tname t
   835:                       (Some (l, !currentDeclIdx)))
   836:           else begin (* Go inside and clean the referenced flag for the
   837:                       * declared tags *)
   838:             match t.ttype with
   839:               TComp (ci, _) ->
   840:                 ci.creferenced <- false;
   841:                 (* Create a node for it *)
   842:                 ignore (getNode sEq sSyn !currentFidx ci.cname ci None)
   843: 
   844:             | TEnum (ei, _) ->
   845:                 ei.ereferenced <- false;
   846:                 ignore (getNode eEq eSyn !currentFidx ei.ename ei None);
   847: 
   848:             | _ -> E.s (bug "Anonymous Gtype is not TComp")
   849:           end
   850: 
   851:       | GCompTag (ci, l) ->
   852:           incr currentDeclIdx;
   853:           ci.creferenced <- false;
   854:           ignore (getNode sEq sSyn !currentFidx ci.cname ci
   855:                     (Some (l, !currentDeclIdx)))
   856:       | GEnumTag (ei, l) ->
   857:           incr currentDeclIdx;
   858:           ei.ereferenced <- false;
   859:           ignore (getNode eEq eSyn !currentFidx ei.ename ei
   860:                     (Some (l, !currentDeclIdx)))
   861: 
   862:       | _ -> ())
   863:     f.globals
   864: 
   865: 
   866: (* Try to merge synonyms. Do not give an error if they fail to merge *)
   867: let doMergeSynonyms
   868:     (syn : (string, 'a node) H.t)
   869:     (eq : (int * string, 'a node) H.t)
   870:     (compare : int -> 'a -> int -> 'a -> unit) (* A comparison function that
   871:                                                 * throws Failure if no match *)
   872:     : unit =
   873:   H.iter (fun n node ->
   874:     if not node.nmergedSyns then begin
   875:       (* find all the nodes for the same name *)
   876:       let all = H.find_all syn n in
   877:       let rec tryone (classes: 'a node list) (* A number of representatives
   878:                                               * for this name *)
   879:                      (nd: 'a node) : 'a node list (* Returns an expanded set
   880:                                                    * of classes *) =
   881:         nd.nmergedSyns <- true;
   882:         (* Compare in turn with all the classes we have so far *)
   883:         let rec compareWithClasses = function
   884:             [] -> [nd](* No more classes. Add this as a new class *)
   885:           | c :: restc ->
   886:               try
   887:                 compare c.nfidx c.ndata  nd.nfidx nd.ndata;
   888:                 (* Success. Stop here the comparison *)
   889:                 c :: restc
   890:               with Failure _ -> (* Failed. Try next class *)
   891:                 c :: (compareWithClasses restc)
   892:         in
   893:         compareWithClasses classes
   894:       in
   895:       (* Start with an empty set of classes for this name *)
   896:       let _ = List.fold_left tryone [] all in
   897:       ()
   898:     end)
   899:     syn
   900: 
   901: 
   902: let matchInlines (oldfidx: int) (oldi: varinfo)
   903:                  (fidx: int) (i: varinfo) =
   904:   let oldinode = getNode iEq iSyn oldfidx oldi.vname oldi None in
   905:   let    inode = getNode iEq iSyn    fidx    i.vname    i None in
   906:   if oldinode == inode then
   907:     ()
   908:   else begin
   909:     (* Replace with the representative data *)
   910:     let oldi = oldinode.ndata in
   911:     let oldfidx = oldinode.nfidx in
   912:     let i = inode.ndata in
   913:     let fidx = inode.nfidx in
   914:     (* There is an old definition. We must combine the types. Do this first
   915:      * because it might fail *)
   916:     oldi.vtype <-
   917:        combineTypes CombineOther
   918:          oldfidx oldi.vtype fidx i.vtype;
   919:     (* We get here if we have success *)
   920:     (* Combine the attributes as well *)
   921:     oldi.vattr <- addAttributes oldi.vattr i.vattr;
   922:     (* Do not union them yet because we do not know that they are the same.
   923:      * We have checked only the types so far *)
   924:     ()
   925:   end
   926: 
   927: (************************************************************
   928:  *
   929:  *  PASS 2
   930:  *
   931:  *
   932:  ************************************************************)
   933: 
   934: (** Keep track of the functions we have used already in the file. We need
   935:   * this to avoid removing an inline function that has been used already.
   936:   * This can only occur if the inline function is defined after it is used
   937:   * already; a bad style anyway *)
   938: let varUsedAlready: (string, unit) H.t = H.create 111
   939: 
   940: (** A visitor that renames uses of variables and types *)
   941: class renameVisitorClass = object (self)
   942:   inherit nopCilVisitor
   943: 
   944:       (* This is either a global variable which we took care of, or a local
   945:        * variable. Must do its type and attributes. *)
   946:   method vvdec (vi: varinfo) = DoChildren
   947: 
   948:       (* This is a variable use. See if we must change it *)
   949:   method vvrbl (vi: varinfo) : varinfo visitAction =
   950:     if not vi.vglob then DoChildren else
   951:     if vi.vreferenced then begin
   952:       H.add varUsedAlready vi.vname ();
   953:       DoChildren
   954:     end else begin
   955:       match findReplacement true vEq !currentFidx vi.vname with
   956:         None -> DoChildren
   957:       | Some (vi', oldfidx) ->
   958:           if debugMerge then
   959:               ignore (E.log "Renaming use of var %s(%d) to %s(%d)\n"
   960:                         vi.vname !currentFidx vi'.vname oldfidx);
   961:           vi'.vreferenced <- true;
   962:           H.add varUsedAlready vi'.vname ();
   963:           ChangeTo vi'
   964:     end
   965: 
   966: 
   967:         (* The use of a type. Change only those types whose underlying info
   968:          * is not a root. *)
   969:   method vtype (t: typ) =
   970:     match t with
   971:       TComp (ci, a) when not ci.creferenced -> begin
   972:         match findReplacement true sEq !currentFidx ci.cname with
   973:           None -> DoChildren
   974:         | Some (ci', oldfidx) ->
   975:             if debugMerge then
   976:               ignore (E.log "Renaming use of %s(%d) to %s(%d)\n"
   977:                         ci.cname !currentFidx ci'.cname oldfidx);
   978:             ChangeTo (TComp (ci', visitCilAttributes (self :> cilVisitor) a))
   979:       end
   980:     | TEnum (ei, a) when not ei.ereferenced -> begin
   981:         match findReplacement true eEq !currentFidx ei.ename with
   982:           None -> DoChildren
   983:         | Some (ei', _) ->
   984:             if ei' == intEnumInfo then
   985:               (* This is actually our friend intEnumInfo *)
   986:               ChangeTo (TInt(IInt, visitCilAttributes (self :> cilVisitor) a))
   987:             else
   988:               ChangeTo (TEnum (ei', visitCilAttributes (self :> cilVisitor) a))
   989:       end
   990: 
   991:     | TNamed (ti, a) when not ti.treferenced -> begin
   992:         match findReplacement true tEq !currentFidx ti.tname with
   993:           None -> DoChildren
   994:         | Some (ti', _) ->
   995:             ChangeTo (TNamed (ti', visitCilAttributes (self :> cilVisitor) a))
   996:     end
   997: 
   998:     | _ -> DoChildren
   999: 
  1000:   (* The Field offset might need to be changed to use new compinfo *)
  1001:   method voffs = function
  1002:       Field (f, o) -> begin
  1003:         (* See if the compinfo was changed *)
  1004:         if f.fcomp.creferenced then
  1005:           DoChildren
  1006:         else begin
  1007:           match findReplacement true sEq !currentFidx f.fcomp.cname with
  1008:             None -> DoChildren (* We did not replace it *)
  1009:           | Some (ci', oldfidx) -> begin
  1010:               (* First, find out the index of the original field *)
  1011:               let rec indexOf (i: int) = function
  1012:                   [] ->
  1013:                     E.s (bug "Cannot find field %s in %s(%d)\n"
  1014:                            f.fname (compFullName f.fcomp) !currentFidx)
  1015:                 | f' :: rest when f' == f -> i
  1016:                 | _ :: rest -> indexOf (i + 1) rest
  1017:               in
  1018:               let index = indexOf 0 f.fcomp.cfields in
  1019:               if List.length ci'.cfields <= index then
  1020:                 E.s (bug "Too few fields in replacement %s(%d) for %s(%d)\n"
  1021:                        (compFullName ci') oldfidx
  1022:                        (compFullName f.fcomp) !currentFidx);
  1023:               let f' = List.nth ci'.cfields index in
  1024:               ChangeDoChildrenPost (Field (f', o), fun x -> x)
  1025:           end
  1026:         end
  1027:       end
  1028:     | _ -> DoChildren
  1029: 
  1030:   method vinitoffs o =
  1031:     (self#voffs o)      (* treat initializer offsets same as lvalue offsets *)
  1032: 
  1033: end
  1034: 
  1035: let renameVisitor = new renameVisitorClass
  1036: 
  1037: 
  1038: (** A visitor that renames uses of inline functions that were discovered in
  1039:  * pass 2 to be used before they are defined. This is like the renameVisitor
  1040:  * except it only looks at the variables (thus it is a bit more efficient)
  1041:  * and it also renames forward declarations of the inlines to be removed. *)
  1042: 
  1043: class renameInlineVisitorClass = object (self)
  1044:   inherit nopCilVisitor
  1045: 
  1046:       (* This is a variable use. See if we must change it *)
  1047:   method vvrbl (vi: varinfo) : varinfo visitAction =
  1048:     if not vi.vglob then DoChildren else
  1049:     if vi.vreferenced then begin (* Already renamed *)
  1050:       DoChildren
  1051:     end else begin
  1052:       match findReplacement true vEq !currentFidx vi.vname with
  1053:         None -> DoChildren
  1054:       | Some (vi', oldfidx) ->
  1055:           if debugMerge then
  1056:               ignore (E.log "Renaming var %s(%d) to %s(%d)\n"
  1057:                         vi.vname !currentFidx vi'.vname oldfidx);
  1058:           vi'.vreferenced <- true;
  1059:           ChangeTo vi'
  1060:     end
  1061: 
  1062:   (* And rename some declarations of inlines to remove. We cannot drop this
  1063:    * declaration (see small1/combineinline6) *)
  1064:   method vglob = function
  1065:       GVarDecl(vi, l) when vi.vinline -> begin
  1066:         (* Get the original name *)
  1067:         let origname =
  1068:           try H.find originalVarNames vi.vname
  1069:           with Not_found -> vi.vname
  1070:         in
  1071:         (* Now see if this must be replaced *)
  1072:         match findReplacement true vEq !currentFidx origname with
  1073:           None -> DoChildren
  1074:         | Some (vi', _) -> ChangeTo [GVarDecl (vi', l)]
  1075:       end
  1076:     | _ -> DoChildren
  1077: 
  1078: end
  1079: let renameInlinesVisitor = new renameInlineVisitorClass
  1080: 
  1081: 
  1082: (* sm: First attempt at a semantic checksum for function bodies.
  1083:  * Ideally, two function's checksums would be equal only when their
  1084:  * bodies were provably equivalent; but I'm using a much simpler and
  1085:  * less accurate heuristic here.  It should be good enough for the
  1086:  * purpose I have in mind, which is doing duplicate removal of
  1087:  * multiply-instantiated template functions. *)
  1088: let functionFlx_cil_checksum (dec: fundec) : int =
  1089: begin
  1090:   (* checksum the structure of the statements (only) *)
  1091:   let rec stmtListSum (lst : stmt list) : int =
  1092:     (List.fold_left (fun acc s -> acc + (stmtSum s)) 0 lst)
  1093:   and stmtSum (s: stmt) : int =
  1094:     (* strategy is to just throw a lot of prime numbers into the
  1095:      * computation in hopes of avoiding accidental collision.. *)
  1096:     match s.skind with
  1097:     | Instr(l) -> 13 + 67*(List.length l)
  1098:     | Return(_) -> 17
  1099:     | Goto(_) -> 19
  1100:     | Break(_) -> 23
  1101:     | Continue(_) -> 29
  1102:     | If(_,b1,b2,_) -> 31 + 37*(stmtListSum b1.bstmts)
  1103:                           + 41*(stmtListSum b2.bstmts)
  1104:     | Switch(_,b,_,_) -> 43 + 47*(stmtListSum b.bstmts)
  1105:                             (* don't look at stmt list b/c is not part of tree *)
  1106:     | Loop(b,_,_,_) -> 49 + 53*(stmtListSum b.bstmts)
  1107:     | Block(b) -> 59 + 61*(stmtListSum b.bstmts)
  1108:     | TryExcept (b, (il, e), h, _) ->
  1109:         67 + 83*(stmtListSum b.bstmts) + 97*(stmtListSum h.bstmts)
  1110:     | TryFinally (b, h, _) ->
  1111:         103 + 113*(stmtListSum b.bstmts) + 119*(stmtListSum h.bstmts)
  1112:   in
  1113: 
  1114:   (* disabled 2nd and 3rd measure because they appear to get different
  1115:    * values, for the same code, depending on whether the code was just
  1116:    * parsed into CIL or had previously been parsed into CIL, printed
  1117:    * out, then re-parsed into CIL *)
  1118:   let a,b,c,d,e =
  1119:     (List.length dec.sformals),        (* # formals *)
  1120:     0 (*(List.length dec.slocals)*),         (* # locals *)
  1121:     0 (*dec.smaxid*),                        (* estimate of internal statement count *)
  1122:     (List.length dec.sbody.bstmts),    (* number of statements at outer level *)
  1123:     (stmtListSum dec.sbody.bstmts) in  (* checksum of statement structure *)
  1124:   (*(trace "sm" (P.dprintf "sum: %s is %d %d %d %d %d\n"*)
  1125:   (*                       dec.svar.vname a b c d e));*)
  1126:   2*a + 3*b + 5*c + 7*d + 11*e
  1127: end
  1128: 
  1129: 
  1130: (* sm: equality for initializers, etc.; this is like '=', except
  1131:  * when we reach shared pieces (like references into the type
  1132:  * structure), we use '==', to prevent circularity *)
  1133: (* update: that's no good; I'm using this to find things which
  1134:  * are equal but from different CIL trees, so nothing will ever
  1135:  * be '=='.. as a hack I'll just change those places to 'true',
  1136:  * so these functions are not now checking proper equality..
  1137:  * places where equality is not complete are marked "INC" *)
  1138: let rec equalInits (x: init) (y: init) : bool =
  1139: begin
  1140:   match x,y with
  1141:   | SingleInit(xe), SingleInit(ye) -> (equalExps xe ye)
  1142:   | CompoundInit(xt, xoil), CompoundInit(yt, yoil) ->
  1143:       (*(xt == yt) &&*)  (* INC *)       (* types need to be identically equal *)
  1144:       let rec equalLists xoil yoil : bool =
  1145:         match xoil,yoil with
  1146:         | ((xo,xi) :: xrest), ((yo,yi) :: yrest) ->
  1147:             (equalOffsets xo yo) &&
  1148:             (equalInits xi yi) &&
  1149:             (equalLists xrest yrest)
  1150:         | [], [] -> true
  1151:         | _, _ -> false
  1152:       in
  1153:       (equalLists xoil yoil)
  1154:   | _, _ -> false
  1155: end
  1156: 
  1157: and equalOffsets (x: offset) (y: offset) : bool =
  1158: begin
  1159:   match x,y with
  1160:   | NoOffset, NoOffset -> true
  1161:   | Field(xfi,xo), Field(yfi,yo) ->
  1162:       (xfi.fname = yfi.fname) &&     (* INC: same fieldinfo name.. *)
  1163:       (equalOffsets xo yo)
  1164:   | Index(xe,xo), Index(ye,yo) ->
  1165:       (equalExps xe ye) &&
  1166:       (equalOffsets xo yo)
  1167:   | _,_ -> false
  1168: end
  1169: 
  1170: and equalExps (x: exp) (y: exp) : bool =
  1171: begin
  1172:   match x,y with
  1173:   | Const(xc), Const(yc) ->        xc = yc   ||    (* safe to use '=' on literals *)
  1174:     (
  1175:       (* CIL changes (unsigned)0 into 0U during printing.. *)
  1176:       match xc,yc with
  1177:       | CInt64(xv,_,_),CInt64(yv,_,_) ->
  1178:           (Int64.to_int xv) = 0   &&     (* ok if they're both 0 *)
  1179:           (Int64.to_int yv) = 0
  1180:       | _,_ -> false
  1181:     )
  1182:   | Lval(xl), Lval(yl) ->          (equalLvals xl yl)
  1183:   | SizeOf(xt), SizeOf(yt) ->      true (*INC: xt == yt*)  (* identical types *)
  1184:   | SizeOfE(xe), SizeOfE(ye) ->    (equalExps xe ye)
  1185:   | AlignOf(xt), AlignOf(yt) ->    true (*INC: xt == yt*)
  1186:   | AlignOfE(xe), AlignOfE(ye) ->  (equalExps xe ye)
  1187:   | UnOp(xop,xe,xt), UnOp(yop,ye,yt) ->
  1188:       xop = yop &&
  1189:       (equalExps xe ye) &&
  1190:       true  (*INC: xt == yt*)
  1191:   | BinOp(xop,xe1,xe2,xt), BinOp(yop,ye1,ye2,yt) ->
  1192:       xop = yop &&
  1193:       (equalExps xe1 ye1) &&
  1194:       (equalExps xe2 ye2) &&
  1195:       true  (*INC: xt == yt*)
  1196:   | CastE(xt,xe), CastE(yt,ye) ->
  1197:       (*INC: xt == yt &&*)
  1198:       (equalExps xe ye)
  1199:   | AddrOf(xl), AddrOf(yl) ->      (equalLvals xl yl)
  1200:   | StartOf(xl), StartOf(yl) ->    (equalLvals xl yl)
  1201: 
  1202:   (* initializers that go through CIL multiple times sometimes lose casts they
  1203:    * had the first time; so allow a different of a cast *)
  1204:   | CastE(xt,xe), ye ->
  1205:       (equalExps xe ye)
  1206:   | xe, CastE(yt,ye) ->
  1207:       (equalExps xe ye)
  1208: 
  1209:   | _,_ -> false
  1210: end
  1211: 
  1212: and equalLvals (x: lval) (y: lval) : bool =
  1213: begin
  1214:   match x,y with
  1215:   | (Var(xv),xo), (Var(yv),yo) ->
  1216:       (* I tried, I really did.. the problem is I see these names
  1217:        * before merging collapses them, so __T123 != __T456,
  1218:        * so whatever *)
  1219:       (*(xv.vname = vy.vname) &&      (* INC: same varinfo names.. *)*)
  1220:       (equalOffsets xo yo)
  1221: 
  1222:   | (Mem(xe),xo), (Mem(ye),yo) ->
  1223:       (equalExps xe ye) &&
  1224:       (equalOffsets xo yo)
  1225:   | _,_ -> false
  1226: end
  1227: 
  1228: let equalInitOpts (x: init option) (y: init option) : bool =
  1229: begin
  1230:   match x,y with
  1231:   | None,None -> true
  1232:   | Some(xi), Some(yi) -> (equalInits xi yi)
  1233:   | _,_ -> false
  1234: end
  1235: 
  1236: 
  1237:   (* Now we go once more through the file and we rename the globals that we
  1238:    * keep. We also scan the entire body and we replace references to the
  1239:    * representative types or variables. We set the referenced flags once we
  1240:    * have replaced the names. *)
  1241: let oneFilePass2 (f: file) =
  1242:   if debugMerge || !E.verboseFlag then
  1243:     ignore (E.log "Final merging phase (%d): %s\n"
  1244:               !currentFidx f.fileName);
  1245:   currentDeclIdx := 0; (* Even though we don't need it anymore *)
  1246:   H.clear varUsedAlready;
  1247:   H.clear originalVarNames;
  1248:   (* If we find inline functions that are used before being defined, and thus
  1249:    * before knowing that we can throw them away, then we mark this flag so
  1250:    * that we can make another pass over the file *)
  1251:   let repeatPass2 = ref false in
  1252:   (* Keep a pointer to the contents of the file so far *)
  1253:   let savedTheFile = !theFile in
  1254: 
  1255:   let processOneGlobal (g: global) : unit =
  1256:       (* Process a varinfo. Reuse an old one, or rename it if necessary *)
  1257:     let processVarinfo (vi: varinfo) (vloc: location) : varinfo =
  1258:       if vi.vreferenced then
  1259:         vi (* Already done *)
  1260:       else begin
  1261:         (* Maybe it is static. Rename it then *)
  1262:         if vi.vstorage = Static then begin
  1263:           let newName, _ = newAlphaName vtAlpha None vi.vname in
  1264:           (* Remember the original name *)
  1265:           H.add originalVarNames newName vi.vname;
  1266:           if debugMerge then ignore (E.log "renaming %s at %a to %s\n"
  1267:                                            vi.vname d_loc vloc newName);
  1268:           vi.vname <- newName;
  1269:           vi.vid <- H.hash vi.vname;
  1270:           vi.vreferenced <- true;
  1271:           vi
  1272:         end else begin
  1273:           (* Find the representative *)
  1274:           match findReplacement true vEq !currentFidx vi.vname with
  1275:             None -> vi (* This is the representative *)
  1276:           | Some (vi', _) -> (* Reuse some previous one *)
  1277:               vi'.vreferenced <- true; (* Mark it as done already *)
  1278:               vi'.vaddrof <- vi.vaddrof || vi'.vaddrof;
  1279:               vi'
  1280:         end
  1281:       end
  1282:     in
  1283:     try
  1284:       match g with
  1285:       | GVarDecl (vi, l) as g ->
  1286:           currentLoc := l;
  1287:           incr currentDeclIdx;
  1288:           let vi' = processVarinfo vi l in
  1289:           if vi != vi' then (* Drop this declaration *) ()
  1290:           else if H.mem emittedVarDecls vi'.vname then (* No need to keep it *)
  1291:             ()
  1292:           else begin
  1293:             H.add emittedVarDecls vi'.vname true; (* Remember that we emitted
  1294:                                                    * it  *)
  1295:             mergePushGlobals (visitCilGlobal renameVisitor g)
  1296:           end
  1297: 
  1298:       | GVar (vi, init, l) as g ->
  1299:           currentLoc := l;
  1300:           incr currentDeclIdx;
  1301:           let vi' = processVarinfo vi l in
  1302:           (* We must keep this definition even if we reuse this varinfo,
  1303:            * because maybe the previous one was a declaration *)
  1304:           H.add emittedVarDecls vi.vname true; (* Remember that we emitted it*)
  1305: 
  1306:           let emitIt:bool = (not mergeGlobals) ||
  1307:             try
  1308:               let prevVar, prevInitOpt, prevLoc =
  1309:                 (H.find emittedVarDefn vi'.vname) in
  1310:               (* previously defined; same initializer? *)
  1311:               if (equalInitOpts prevInitOpt init.init) then (
  1312:                 (trace "mergeGlob"
  1313:                   (P.dprintf "dropping global var %s at %a in favor of the one at %a\n"
  1314:                              vi'.vname  d_loc l  d_loc prevLoc));
  1315:                 false  (* do not emit *)
  1316:               )
  1317:               else (
  1318:                 (ignore (warn "global var %s at %a has different initializer than %a\n"
  1319:                               vi'.vname  d_loc l  d_loc prevLoc));
  1320:                 (* emit it so we get a compiler error.. I think it would be
  1321:                  * better to give an error message and *not* emit, since doing
  1322:                  * this explicitly violates the CIL invariant of only one GVar
  1323:                  * per name, but the rest of this file is very permissive so
  1324:                  * I'll be similarly permissive.. *)
  1325:                 true
  1326:               )
  1327:             with Not_found -> (
  1328:               (* no previous definition *)
  1329:               (H.add emittedVarDefn vi'.vname (vi', init.init, l));
  1330:               true     (* emit it *)
  1331:             )
  1332:           in
  1333: 
  1334:           if emitIt then
  1335:             mergePushGlobals (visitCilGlobal renameVisitor (GVar(vi', init, l)))
  1336: 
  1337:       | GFun (fdec, l) as g ->
  1338:           currentLoc := l;
  1339:           incr currentDeclIdx;
  1340:           (* We apply the renaming *)
  1341:           fdec.svar <- processVarinfo fdec.svar l;
  1342:           (* Get the original name. *)
  1343:           let origname =
  1344:             try H.find originalVarNames fdec.svar.vname
  1345:             with Not_found -> fdec.svar.vname
  1346:           in
  1347:           (* Go in there and rename everything as needed *)
  1348:           let fdec' =
  1349:             match visitCilGlobal renameVisitor g with
  1350:               [GFun(fdec', _)] -> fdec'
  1351:             | _ -> E.s (unimp "renameVisitor for GFun returned something else")
  1352:           in
  1353:           let g' = GFun(fdec', l) in
  1354:           (* Now restore the parameter names *)
  1355:           let _, args, _, _ = splitFunctionTypeVI fdec'.svar in
  1356:           let oldnames, foundthem =
  1357:             try H.find formalNames (!currentFidx, origname), true
  1358:             with Not_found -> begin
  1359:               ignore (warnOpt "Cannot find %s in formalNames" origname);
  1360:               [], false
  1361:             end
  1362:           in
  1363:           if foundthem then begin
  1364:             let argl = argsToList args in
  1365:             if List.length oldnames <> List.length argl then
  1366:               E.s (unimp "After merging the function has more arguments");
  1367:             List.iter2
  1368:               (fun oldn a -> if oldn <> "" then a.vname <- oldn)
  1369:               oldnames fdec.sformals;
  1370:             (* Reflect them in the type *)
  1371:             setFormals fdec fdec.sformals
  1372:           end;
  1373:           (** See if we can remove this inline function *)
  1374:           if fdec'.svar.vinline && mergeInlines then begin
  1375:             let printout =
  1376:               (* Temporarily turn of printing of lines *)
  1377:               let oldprintln = !lineDirectiveStyle in
  1378:               lineDirectiveStyle := None;
  1379:               (* Temporarily set the name to all functions in the same way *)
  1380:               let newname = fdec'.svar.vname in
  1381:               fdec'.svar.vname <- "@@alphaname@@";
  1382:               (* If we must do alpha conversion then temporarily set the
  1383:                * names of the local variables and formals in a standard way *)
  1384:               let nameId = ref 0 in
  1385:               let newName () = incr nameId;  in
  1386:               let oldNames : string list ref = ref [] in
  1387:               let renameOne (v: varinfo) =
  1388:                 oldNames := v.vname :: !oldNames;
  1389:                 incr nameId;
  1390:                 v.vname <- "___alpha" ^ string_of_int !nameId
  1391:               in
  1392:               let undoRenameOne (v: varinfo) =
  1393:                 match !oldNames with
  1394:                   n :: rest ->
  1395:                     oldNames := rest;
  1396:                     v.vname <- n
  1397:                 | _ -> E.s (bug "undoRenameOne")
  1398:               in
  1399:               (* Remember the original type *)
  1400:               let origType = fdec'.svar.vtype in
  1401:               if mergeInlinesWithAlphaConvert then begin
  1402:                 (* Rename the formals *)
  1403:                 List.iter renameOne fdec'.sformals;
  1404:                 (* Reflect in the type *)
  1405:                 setFormals fdec' fdec'.sformals;
  1406:                 (* Now do the locals *)
  1407:                 List.iter renameOne fdec'.slocals
  1408:               end;
  1409:               (* Now print it *)
  1410:               let res = d_global () g' in
  1411:               lineDirectiveStyle := oldprintln;
  1412:               fdec'.svar.vname <- newname;
  1413:               if mergeInlinesWithAlphaConvert then begin
  1414:                 (* Do the locals in reverse order *)
  1415:                 List.iter undoRenameOne (List.rev fdec'.slocals);
  1416:                 (* Do the formals in reverse order *)
  1417:                 List.iter undoRenameOne (List.rev fdec'.sformals);
  1418:                 (* Restore the type *)
  1419:                 fdec'.svar.vtype <- origType;
  1420:               end;
  1421:               res
  1422:             in
  1423:             (* Make a node for this inline function using the original name. *)
  1424:             let inode =
  1425:               getNode vEq vSyn !currentFidx origname fdec'.svar
  1426:                 (Some (l, !currentDeclIdx))
  1427:             in
  1428:             if debugInlines then begin
  1429:               ignore (E.log "getNode %s(%d) with loc=%a. declidx=%d\n"
  1430:                         inode.nname inode.nfidx
  1431:                         d_nloc inode.nloc
  1432:                         !currentDeclIdx);
  1433:               ignore (E.log
  1434:                         "Looking for previous definition of inline %s(%d)\n"
  1435:                         origname !currentFidx);
  1436:             end;
  1437:             try
  1438:               let oldinode = H.find inlineBodies printout in
  1439:               if debugInlines then
  1440:                 ignore (E.log "  Matches %s(%d)\n"
  1441:                           oldinode.nname oldinode.nfidx);
  1442:               (* There is some other inline function with the same printout.
  1443:                * We should reuse this, but watch for the case when the inline
  1444:                * was already used. *)
  1445:               if H.mem varUsedAlready fdec'.svar.vname then begin
  1446:                 if mergeInlinesRepeat then begin
  1447:                   repeatPass2 := true
  1448:                 end else begin
  1449:                   ignore (warn "Inline function %s because it is used before it is defined" fdec'.svar.vname);
  1450:                   raise Not_found
  1451:                 end
  1452:               end;
  1453:               let _ = union oldinode inode in
  1454:               (* Clean up the vreferenced bit in the new inline, so that we
  1455:                * can rename it. Reset the name to the original one so that
  1456:                * we can find the replacement name. *)
  1457:               fdec'.svar.vreferenced <- false;
  1458:               fdec'.svar.vname <- origname;
  1459:               () (* Drop this definition *)
  1460:             with Not_found -> begin
  1461:               if debugInlines then ignore (E.log " Not found\n");
  1462:               H.add inlineBodies printout inode;
  1463:               mergePushGlobal g'
  1464:             end
  1465:           end else begin
  1466:             (* either the function is not inline, or we're not attempting to
  1467:              * merge inlines *)
  1468:             if (mergeGlobals &&
  1469:                 not fdec'.svar.vinline &&
  1470:                 fdec'.svar.vstorage <> Static) then
  1471:               begin
  1472:                 (* sm: this is a non-inline, non-static function.  I want to
  1473:                 * consider dropping it if a same-named function has already
  1474:                 * been put into the merged file *)
  1475:                 let curSum = (functionFlx_cil_checksum fdec') in
  1476:                 (*(trace "mergeGlob" (P.dprintf "I see extern function %s, sum is %d\n"*)
  1477:               (*                              fdec'.svar.vname curSum));*)
  1478:                 try
  1479:                   let prevFun, prevLoc, prevSum =
  1480:                     (H.find emittedFunDefn fdec'.svar.vname) in
  1481:                   (* previous was found *)
  1482:                   if (curSum = prevSum) then
  1483:                     (trace "mergeGlob"
  1484:                        (P.dprintf "dropping duplicate def'n of func %s at %a in favor of that at %a\n"
  1485:                           fdec'.svar.vname  d_loc l  d_loc prevLoc))
  1486:                   else begin
  1487:                     (* the checksums differ, so print a warning but keep the
  1488:                      * older one to avoid a link error later.  I think this is
  1489:                      * a reasonable approximation of what ld does. *)
  1490:                     (ignore (warn "def'n of func %s at %a (sum %d) conflicts with the one at %a (sum %d); keeping the one at %a.\n"
  1491:                                fdec'.svar.vname  d_loc l  curSum  d_loc prevLoc
  1492:                                prevSum d_loc prevLoc))
  1493:                   end
  1494:                 with Not_found -> begin
  1495:                   (* there was no previous definition *)
  1496:                   (mergePushGlobal g');
  1497:                   (H.add emittedFunDefn fdec'.svar.vname (fdec', l, curSum))
  1498:                 end
  1499:               end else begin
  1500:                 (* not attempting to merge global functions, or it was static
  1501:                  * or inline *)
  1502:                 mergePushGlobal g'
  1503:               end
  1504:           end
  1505: 
  1506:       | GCompTag (ci, l) as g -> begin
  1507:           currentLoc := l;
  1508:           incr currentDeclIdx;
  1509:           if ci.creferenced then
  1510:             ()
  1511:           else begin
  1512:             match findReplacement true sEq !currentFidx ci.cname with
  1513:               None ->
  1514:                 (* A new one, we must rename it and keep the definition *)
  1515:                 (* Make sure this is root *)
  1516:                 (try
  1517:                   let nd = H.find sEq (!currentFidx, ci.cname) in
  1518:                   if nd.nrep != nd then
  1519:                     E.s (bug "Setting creferenced for struct %s(%d) which is not root!\n"
  1520:                            ci.cname !currentFidx);
  1521:                 with Not_found -> begin
  1522:                   E.s (bug "Setting creferenced for struct %s(%d) which is not in the sEq!\n"
  1523:                          ci.cname !currentFidx);
  1524:                 end);
  1525:                 let newname, _ = newAlphaName sAlpha None ci.cname in
  1526:                 ci.cname <- newname;
  1527:                 ci.creferenced <- true;
  1528:                 ci.ckey <- H.hash (compFullName ci);
  1529:                 (* Now we should visit the fields as well *)
  1530:                 H.add emittedCompDecls ci.cname true; (* Remember that we
  1531:                                                        * emitted it  *)
  1532:                 mergePushGlobals (visitCilGlobal renameVisitor g)
  1533:             | Some (oldci, oldfidx) -> begin
  1534:                 (* We are not the representative. Drop this declaration
  1535:                  * because we'll not be using it. *)
  1536:                 ()
  1537:             end
  1538:           end
  1539:       end
  1540:       | GEnumTag (ei, l) as g -> begin
  1541:           currentLoc := l;
  1542:           incr currentDeclIdx;
  1543:           if ei.ereferenced then
  1544:             ()
  1545:           else begin
  1546:             match findReplacement true eEq !currentFidx ei.ename with
  1547:               None -> (* We must rename it *)
  1548:                 let newname, _ = newAlphaName eAlpha None ei.ename in
  1549:                 ei.ename <- newname;
  1550:                 ei.ereferenced <- true;
  1551:                 (* And we must rename the items to using the same name space
  1552:                  * as the variables *)
  1553:                 ei.eitems <-
  1554:                    List.map
  1555:                      (fun (n, i, loc) ->
  1556:                        let newname, _ = newAlphaName vtAlpha None n in
  1557:                        newname, i, loc)
  1558:                      ei.eitems;
  1559:                 mergePushGlobals (visitCilGlobal renameVisitor g);
  1560:             | Some (ei', _) -> (* Drop this since we are reusing it from
  1561:                                 * before *)
  1562:                 ()
  1563:           end
  1564:       end
  1565:       | GCompTagDecl (ci, l) -> begin
  1566:           currentLoc := l; (* This is here just to introduce an undefined
  1567:                             * structure. But maybe the structure was defined
  1568:                             * already.  *)
  1569:           (* Do not increment currentDeclIdx because it is not incremented in
  1570:            * pass 1*)
  1571:           if H.mem emittedCompDecls ci.cname then
  1572:             () (* It was already declared *)
  1573:           else begin
  1574:             H.add emittedCompDecls ci.cname true;
  1575:             (* Keep it as a declaration *)
  1576:             mergePushGlobal g;
  1577:           end
  1578:       end
  1579: 
  1580:       | GEnumTagDecl (ei, l) ->
  1581:           currentLoc := l;
  1582:           (* Do not increment currentDeclIdx because it is not incremented in
  1583:            * pass 1*)
  1584:           (* Keep it as a declaration *)
  1585:           mergePushGlobal g
  1586: 
  1587: 
  1588:       | GType (ti, l) as g -> begin
  1589:           currentLoc := l;
  1590:           incr currentDeclIdx;
  1591:           if ti.treferenced then
  1592:             ()
  1593:           else begin
  1594:             match findReplacement true tEq !currentFidx ti.tname with
  1595:               None -> (* We must rename it and keep it *)
  1596:                 let newname, _ = newAlphaName vtAlpha None ti.tname in
  1597:                 ti.tname <- newname;
  1598:                 ti.treferenced <- true;
  1599:                 mergePushGlobals (visitCilGlobal renameVisitor g);
  1600:             | Some (ti', _) ->(* Drop this since we are reusing it from
  1601:                 * before *)
  1602:                   ()
  1603:           end
  1604:       end
  1605:       | g -> mergePushGlobals (visitCilGlobal renameVisitor g)
  1606:   with e -> begin
  1607:     let globStr:string = (P.sprint 1000 (P.dprintf
  1608:       "error when merging global %a: %s"
  1609:       d_global g  (Printexc.to_string e))) in
  1610:     ignore (E.log "%s\n" globStr);
  1611:     (*"error when merging global: %s\n" (Printexc.to_string e);*)
  1612:     mergePushGlobal (GText (P.sprint 80
  1613:                               (P.dprintf "/* error at %t:" d_thisloc)));
  1614:     mergePushGlobal g;
  1615:     mergePushGlobal (GText ("*************** end of error*/"));
  1616:     raise e
  1617:   end
  1618:   in
  1619:   (* Now do the real PASS 2 *)
  1620:   List.iter processOneGlobal f.globals;
  1621:   (* See if we must re-visit the globals in this file because an inline that
  1622:    * is being removed was used before we saw the definition and we decided to
  1623:    * remove it *)
  1624:   if mergeInlinesRepeat && !repeatPass2 then begin
  1625:     if debugMerge || !E.verboseFlag then
  1626:       ignore (E.log "Repeat final merging phase (%d): %s\n"
  1627:                 !currentFidx f.fileName);
  1628:     (* We are going to rescan the globals we have added while processing this
  1629:      * file. *)
  1630:     let theseGlobals : global list ref = ref [] in
  1631:     (* Scan a list of globals until we hit a given tail *)
  1632:     let rec scanUntil (tail: 'a list) (l: 'a list) =
  1633:       if tail == l then ()
  1634:       else
  1635:         match l with
  1636:         | [] -> E.s (bug "mergecil: scanUntil could not find the marker\n")
  1637:         | g :: rest ->
  1638:             theseGlobals := g :: !theseGlobals;
  1639:             scanUntil tail rest
  1640:     in
  1641:     (* Collect in theseGlobals all the globals from this file *)
  1642:     theseGlobals := [];
  1643:     scanUntil savedTheFile !theFile;
  1644:     (* Now reprocess them *)
  1645:     theFile := savedTheFile;
  1646:     List.iter (fun g ->
  1647:                  theFile := (visitCilGlobal renameInlinesVisitor g) @ !theFile)
  1648:       !theseGlobals;
  1649:     (* Now check if we have inlines that we could not remove
  1650:     H.iter (fun name _ ->
  1651:       if not (H.mem inlinesRemoved name) then
  1652:         ignore (warn "Could not remove inline %s. I have no idea why!\n"
  1653:                   name))
  1654:       inlinesToRemove *)
  1655:   end
  1656: 
  1657: 
  1658: let merge (files: file list) (newname: string) : file =
  1659:   init ();
  1660: 
  1661:   (* Make the first pass over the files *)
  1662:   currentFidx := 0;
  1663:   List.iter (fun f -> oneFilePass1 f; incr currentFidx) files;
  1664: 
  1665:   (* Now maybe try to force synonyms to be equal *)
  1666:   if mergeSynonyms then begin
  1667:     doMergeSynonyms sSyn sEq matchCompInfo;
  1668:     doMergeSynonyms eSyn eEq matchEnumInfo;
  1669:     doMergeSynonyms tSyn tEq matchTypeInfo;
  1670:     if mergeInlines then begin
  1671:       (* Copy all the nodes from the iEq to vEq as well. This is needed
  1672:        * because vEq will be used for variable renaming *)
  1673:       H.iter (fun k n -> H.add vEq k n) iEq;
  1674:       doMergeSynonyms iSyn iEq matchInlines;
  1675:     end
  1676:   end;
  1677: 
  1678:   (* Now maybe dump the graph *)
  1679:   if debugMerge then begin
  1680:     dumpGraph "type" tEq;
  1681:     dumpGraph "struct and union" sEq;
  1682:     dumpGraph "enum" eEq;
  1683:     dumpGraph "variable" vEq;
  1684:     if mergeInlines then dumpGraph "inline" iEq;
  1685:   end;
  1686:   (* Make the second pass over the files. This is when we start rewriting the
  1687:    * file *)
  1688:   currentFidx := 0;
  1689:   List.iter (fun f -> oneFilePass2 f; incr currentFidx) files;
  1690: 
  1691:   (* Now reverse the result and return the resulting file *)
  1692:   let rec revonto acc = function
  1693:       [] -> acc
  1694:     | x :: t -> revonto (x :: acc) t
  1695:   in
  1696:   let res =
  1697:     { fileName = newname;
  1698:       globals  = revonto (revonto [] !theFile) !theFileTypes;
  1699:       globinit = None;
  1700:       globinitcalled = false } in
  1701:   init (); (* Make the GC happy *)
  1702:   (* We have made many renaming changes and sometimes we have just guessed a
  1703:    * name wrong. Make sure now that the local names are unique. *)
  1704:   uniqueVarNames res;
  1705:   res
  1706: 
  1707: 
  1708: 
  1709: 
  1710: 
End ocaml section to src/flx_cil_mergecil.ml[1]
Start ocaml section to src/flx_cil_mergecil.mli[1 /1 ]
     1: # 13420 "./lpsrc/flx_cil.ipk"
     2: (** Set this to true to ignore the merge conflicts *)
     3: val ignore_merge_conflicts: bool ref
     4: 
     5: (** Merge a number of CIL files *)
     6: val merge: Flx_cil_cil.file list -> string -> Flx_cil_cil.file
     7: 
End ocaml section to src/flx_cil_mergecil.mli[1]
Start ocaml section to src/flx_cil_rmtmps.ml[1 /1 ]
     1: # 13428 "./lpsrc/flx_cil.ipk"
     2: (* rmtmps.ml *)
     3: (* implementation for rmtmps.mli *)
     4: 
     5: open Flx_cil_pretty
     6: open Flx_cil_cil
     7: module H = Hashtbl
     8: module E = Flx_cil_errormsg
     9: module U = Flx_cil_util
    10: 
    11: 
    12: 
    13: let trace = Flx_cil_trace.trace "rmtmps"
    14: 
    15: 
    16: 
    17: (***********************************************************************
    18:  *
    19:  *  Clearing of "referenced" bits
    20:  *
    21:  *)
    22: 
    23: 
    24: let clearReferencedBits file =
    25:   let considerGlobal global =
    26:     match global with
    27:     | GType (info, _) ->
    28:         trace (dprintf "clearing mark: %a\n" d_shortglobal global);
    29:         info.treferenced <- false
    30: 
    31:     | GEnumTag (info, _)
    32:     | GEnumTagDecl (info, _) ->
    33:         trace (dprintf "clearing mark: %a\n" d_shortglobal global);
    34:         info.ereferenced <- false
    35: 
    36:     | GCompTag (info, _)
    37:     | GCompTagDecl (info, _) ->
    38:         trace (dprintf "clearing mark: %a\n" d_shortglobal global);
    39:         info.creferenced <- false
    40: 
    41:     | GVar ({vname = name} as info, _, _)
    42:     | GVarDecl ({vname = name} as info, _) ->
    43:         trace (dprintf "clearing mark: %a\n" d_shortglobal global);
    44:         info.vreferenced <- false
    45: 
    46:     | GFun ({svar = info} as func, _) ->
    47:         trace (dprintf "clearing mark: %a\n" d_shortglobal global);
    48:         info.vreferenced <- false;
    49:         let clearMark local =
    50:           trace (dprintf "clearing mark: local %s\n" local.vname);
    51:           local.vreferenced <- false
    52:         in
    53:         List.iter clearMark func.slocals
    54: 
    55:     | _ ->
    56:         ()
    57:   in
    58:   iterGlobals file considerGlobal
    59: 
    60: 
    61: (***********************************************************************
    62:  *
    63:  *  Scanning and categorization of pragmas
    64:  *
    65:  *)
    66: 
    67: 
    68: (* collections of names of things to keep *)
    69: type collection = (string, unit) H.t
    70: type keepers = {
    71:     typedefs : collection;
    72:     enums : collection;
    73:     structs : collection;
    74:     unions : collection;
    75:     defines : collection;
    76:   }
    77: 
    78: 
    79: (* rapid transfer of control when we find a malformed pragma *)
    80: exception Bad_pragma
    81: 
    82: let ccureddeepcopystring = "ccureddeepcopy"
    83: (* Save this length so we don't recompute it each time. *)
    84: let ccureddeepcopystring_length = String.length ccureddeepcopystring
    85: 
    86: (* CIL and CCured define several pragmas which prevent removal of
    87:  * various global symbols.  Here we scan for those pragmas and build
    88:  * up collections of the corresponding symbols' names.
    89:  *)
    90: 
    91: let categorizePragmas file =
    92: 
    93:   (* names of things which should be retained *)
    94:   let keepers = {
    95:     typedefs = H.create 0;
    96:     enums = H.create 0;
    97:     structs = H.create 0;
    98:     unions = H.create 0;
    99:     defines = H.create 1
   100:   } in
   101: 
   102:   (* populate these name collections in light of each pragma *)
   103:   let considerPragma =
   104: 
   105:     let badPragma location pragma =
   106:       ignore (warnLoc location "Invalid argument to pragma %s" pragma)
   107:     in
   108: 
   109:     function
   110:       | GPragma (Attr ("cilnoremove" as directive, args), location) ->
   111:           (* a very flexible pragma: can retain typedefs, enums,
   112:            * structs, unions, or globals (functions or variables) *)
   113:           begin
   114:             let processArg arg =
   115:               try
   116:                 match arg with
   117:                 | AStr specifier ->
   118:                     (* isolate and categorize one symbol name *)
   119:                     let collection, name =
   120:                       (* Two words denotes a typedef, enum, struct, or
   121:                        * union, as in "type foo" or "enum bar".  A
   122:                        * single word denotes a global function or
   123:                        * variable. *)
   124:                       let whitespace = Str.regexp "[ \t]+" in
   125:                       let words = Str.split whitespace specifier in
   126:                       match words with
   127:                       | ["type"; name] ->
   128:                           keepers.typedefs, name
   129:                       | ["enum"; name] ->
   130:                           keepers.enums, name
   131:                       | ["struct"; name] ->
   132:                           keepers.structs, name
   133:                       | ["union"; name] ->
   134:                           keepers.unions, name
   135:                       | [name] ->
   136:                           keepers.defines, name
   137:                       | _ ->
   138:                           raise Bad_pragma
   139:                     in
   140:                     H.add collection name ()
   141:                 | _ ->
   142:                     raise Bad_pragma
   143:               with Bad_pragma ->
   144:                 badPragma location directive
   145:             in
   146:             List.iter processArg args
   147:           end
   148: 
   149:       (*** Begin CCured-specific checks:  ***)
   150:       (* these pragmas indirectly require that we keep the function named in
   151:           -- the first arguments of boxmodelof and ccuredwrapperof, and
   152:           -- the third argument of ccureddeepcopy*. *)
   153:       | GPragma (Attr("ccuredwrapper" as directive, attribute :: _), location) ->
   154:           begin
   155:             match attribute with
   156:             | AStr name ->
   157:                 H.add keepers.defines name ()
   158:             | _ ->
   159:                 badPragma location directive
   160:           end
   161:       | GPragma (Attr("ccuredvararg" as directive, funcname :: (ASizeOf t) :: _), location) ->
   162:           begin
   163:             match t with
   164:             | TComp(c,_) when c.cstruct -> (* struct *)
   165:                 H.add keepers.structs c.cname ()
   166:             | TComp(c,_) -> (* union *)
   167:                 H.add keepers.unions c.cname ()
   168:             | TNamed(ti,_) ->
   169:                 H.add keepers.typedefs ti.tname ()
   170:             | TEnum(ei, _) ->
   171:                 H.add keepers.enums ei.ename ()
   172:             | _ ->
   173:                 ()
   174:           end
   175:       | GPragma (Attr(directive, _ :: _ :: attribute :: _), location)
   176:            when String.length directive > ccureddeepcopystring_length
   177:                && (Str.first_chars directive ccureddeepcopystring_length)
   178:                    = ccureddeepcopystring ->
   179:           begin
   180:             match attribute with
   181:             | AStr name ->
   182:                 H.add keepers.defines name ()
   183:             | _ ->
   184:                 badPragma location directive
   185:           end
   186:       (** end CCured-specific stuff **)
   187:       | _ ->
   188:           ()
   189:   in
   190:   iterGlobals file considerPragma;
   191:   keepers
   192: 
   193: 
   194: 
   195: (***********************************************************************
   196:  *
   197:  *  Function body elimination from pragmas
   198:  *
   199:  *)
   200: 
   201: 
   202: (* When performing global slicing, any functions not explicitly marked
   203:  * as pragma roots are reduced to mere declarations.  This leaves one
   204:  * with a reduced source file that still compiles to object code, but
   205:  * which contains the bodies of only explicitly retained functions.
   206:  *)
   207: 
   208: let amputateFunctionBodies keptGlobals file =
   209:   let considerGlobal = function
   210:     | GFun ({svar = {vname = name} as info}, location)
   211:       when not (H.mem keptGlobals name) ->
   212:         trace (dprintf "slicing: reducing to prototype: function %s\n" name);
   213:         GVarDecl (info, location)
   214:     | other ->
   215:         other
   216:   in
   217:   mapGlobals file considerGlobal
   218: 
   219: 
   220: 
   221: (***********************************************************************
   222:  *
   223:  *  Root collection from pragmas
   224:  *
   225:  *)
   226: 
   227: 
   228: let isPragmaRoot keepers = function
   229:   | GType ({tname = name} as info, _) ->
   230:       H.mem keepers.typedefs name
   231:   | GEnumTag ({ename = name} as info, _)
   232:   | GEnumTagDecl ({ename = name} as info, _) ->
   233:       H.mem keepers.enums name
   234:   | GCompTag ({cname = name; cstruct = structure} as info, _)
   235:   | GCompTagDecl ({cname = name; cstruct = structure} as info, _) ->
   236:       let collection = if structure then keepers.structs else keepers.unions in
   237:       H.mem collection name
   238:   | GVar ({vname = name} as info, _, _)
   239:   | GVarDecl ({vname = name} as info, _)
   240:   | GFun ({svar = {vname = name} as info}, _) ->
   241:       H.mem keepers.defines name
   242:   | _ ->
   243:       false
   244: 
   245: 
   246: 
   247: (***********************************************************************
   248:  *
   249:  *  Common root collecting utilities
   250:  *
   251:  *)
   252: 
   253: 
   254: let traceRoot reason global =
   255:   trace (dprintf "root (%s): %a@!" reason d_shortglobal global);
   256:   true
   257: 
   258: 
   259: let traceNonRoot reason global =
   260:   trace (dprintf "non-root (%s): %a@!" reason d_shortglobal global);
   261:   false
   262: 
   263: 
   264: let hasExportingAttribute funvar =
   265:   let rec isExportingAttribute = function
   266:     | Attr ("constructor", []) -> true
   267:     | Attr ("destructor", []) -> true
   268:     | _ -> false
   269:   in
   270:   List.exists isExportingAttribute funvar.vattr
   271: 
   272: 
   273: 
   274: (***********************************************************************
   275:  *
   276:  *  Root collection from external linkage
   277:  *
   278:  *)
   279: 
   280: 
   281: (* Exported roots are those global symbols which are visible to the
   282:  * linker and dynamic loader.  For variables, this consists of
   283:  * anything that is not "static".  For functions, this consists of:
   284:  *
   285:  * - functions declared extern inline
   286:  * - functions declared neither inline nor static
   287:  * - functions bearing a "constructor" or "destructor" attribute
   288:  *)
   289: 
   290: let isExportedRoot global =
   291:   let result = match global with
   292:   | GVar ({vstorage = storage}, _, _) as global
   293:     when storage != Static ->
   294:       true
   295:   | GFun ({svar = v} as fundec, _) as global ->
   296:       if hasExportingAttribute v then
   297:         true
   298:       else if v.vstorage = Extern then (* Keep all extern functions *)
   299:         true
   300:       else if v.vstorage = Static then (* Do not keep static functions *)
   301:         false
   302:       else if v.vinline then (* Do not keep inline functions, unless they
   303:                               * are Extern also *)
   304:         false
   305:       else
   306:         true
   307:   | global ->
   308:       false
   309:   in
   310:   trace (dprintf "exported root -> %b for %a@!" result d_shortglobal global);
   311:   result
   312: 
   313: 
   314: 
   315: (***********************************************************************
   316:  *
   317:  *  Root collection for complete programs
   318:  *
   319:  *)
   320: 
   321: 
   322: (* Exported roots are "main()" and functions bearing a "constructor"
   323:  * or "destructor" attribute.  These are the only things which must be
   324:  * retained in a complete program.
   325:  *)
   326: 
   327: let isCompleteProgramRoot global =
   328:   let result = match global with
   329:   | GFun ({svar = {vname = "main"; vstorage = vstorage} as info}, _) ->
   330:       vstorage <> Static
   331:   | GFun (fundec, _)
   332:     when hasExportingAttribute fundec.svar ->
   333:       true
   334:   | _ ->
   335:       false
   336:   in
   337:   trace (dprintf "complete program root -> %b for %a@!" result d_shortglobal global);
   338:   result
   339: 
   340: 
   341: (***********************************************************************
   342:  *
   343:  *  Transitive reachability closure from roots
   344:  *
   345:  *)
   346: 
   347: 
   348: (* This visitor recursively marks all reachable types and variables as used. *)
   349: class markReachableVisitor globalMap = object (self)
   350:   inherit nopCilVisitor
   351: 
   352:   method vglob = function
   353:     | GType (typeinfo, _) ->
   354:         typeinfo.treferenced <- true;
   355:         DoChildren
   356:     | GCompTag (compinfo, _)
   357:     | GCompTagDecl (compinfo, _) ->
   358:         compinfo.creferenced <- true;
   359:         DoChildren
   360:     | GEnumTag (enuminfo, _)
   361:     | GEnumTagDecl (enuminfo, _) ->
   362:         enuminfo.ereferenced <- true;
   363:         DoChildren
   364:     | GVar (varinfo, _, _)
   365:     | GVarDecl (varinfo, _)
   366:     | GFun ({svar = varinfo}, _) ->
   367:         varinfo.vreferenced <- true;
   368:         DoChildren
   369:     | _ ->
   370:         SkipChildren
   371: 
   372:   method vvrbl v =
   373:     if not v.vreferenced then
   374:       begin
   375:         let name = v.vname in
   376:         if v.vglob then
   377:           trace (dprintf "marking transitive use: global %s\n" name)
   378:         else
   379:           trace (dprintf "marking transitive use: local %s\n" name);
   380: 
   381:         (* If this is a global, we need to keep everything used in its
   382:          * definition and declarations. *)
   383:         if v.vglob then
   384:           begin
   385:             trace (dprintf "descending: global %s\n" name);
   386:             let descend global =
   387:               ignore (visitCilGlobal (self :> cilVisitor) global)
   388:             in
   389:             let globals = Hashtbl.find_all globalMap name in
   390:             List.iter descend globals
   391:           end
   392:         else
   393:           v.vreferenced <- true;
   394:       end;
   395:     SkipChildren
   396: 
   397:   method vtype typ =
   398:     let old : bool =
   399:       let visitAttrs attrs =
   400:         ignore (visitCilAttributes (self :> cilVisitor) attrs)
   401:       in
   402:       let visitType typ =
   403:         ignore (visitCilType (self :> cilVisitor) typ)
   404:       in
   405:       match typ with
   406:       | TEnum(e, attrs) ->
   407:           let old = e.ereferenced in
   408:           if not old then
   409:             begin
   410:               trace (dprintf "marking transitive use: enum %s\n" e.ename);
   411:               e.ereferenced <- true;
   412:               visitAttrs attrs;
   413:               visitAttrs e.eattr
   414:             end;
   415:           old
   416: 
   417:       | TComp(c, attrs) ->
   418:           let old = c.creferenced in
   419:           if not old then
   420:             begin
   421:               trace (dprintf "marking transitive use: compound %s\n" c.cname);
   422:               c.creferenced <- true;
   423: 
   424:               (* to recurse, we must ask explicitly *)
   425:               let recurse f = visitType f.ftype in
   426:               List.iter recurse c.cfields;
   427:               visitAttrs attrs;
   428:               visitAttrs c.cattr
   429:             end;
   430:           old
   431: 
   432:       | TNamed(ti, attrs) ->
   433:           let old = ti.treferenced in
   434:           if not old then
   435:             begin
   436:               trace (dprintf "marking transitive use: typedef %s\n" ti.tname);
   437:               ti.treferenced <- true;
   438: 
   439:               (* recurse deeper into the type referred-to by the typedef *)
   440:               (* to recurse, we must ask explicitly *)
   441:               visitType ti.ttype;
   442:               visitAttrs attrs
   443:             end;
   444:           old
   445: 
   446:       | _ ->
   447:           (* for anything else, just look inside it *)
   448:           false
   449:     in
   450:     if old then
   451:       SkipChildren
   452:     else
   453:       DoChildren
   454: end
   455: 
   456: 
   457: let markReachable file isRoot =
   458:   (* build a mapping from global names back to their definitions & declarations *)
   459:   let globalMap = Hashtbl.create 137 in
   460:   let considerGlobal global =
   461:     match global with
   462:     | GFun ({svar = info}, _)
   463:     | GVar (info, _, _)
   464:     | GVarDecl (info, _) ->
   465:         Hashtbl.add globalMap info.vname global
   466:     | _ ->
   467:         ()
   468:   in
   469:   iterGlobals file considerGlobal;
   470: 
   471:   (* mark everything reachable from the global roots *)
   472:   let visitor = new markReachableVisitor globalMap in
   473:   let visitIfRoot global =
   474:     if isRoot global then
   475:       begin
   476:         trace (dprintf "traversing root global: %a\n" d_shortglobal global);
   477:         ignore (visitCilGlobal visitor global)
   478:       end
   479:     else
   480:       trace (dprintf "skipping non-root global: %a\n" d_shortglobal global)
   481:   in
   482:   iterGlobals file visitIfRoot
   483: 
   484: 
   485: (**********************************************************************
   486:  *
   487:  * Marking and removing of unused labels
   488:  *
   489:  **********************************************************************)
   490: 
   491: (* We keep only one label, preferably one that was not introduced by CIL.
   492:  * Scan a list of labels and return the data for the label that should be
   493:  * kept, and the remaining filtered list of labels *)
   494: let labelsToKeep (ll: label list) : (string * location * bool) * label list =
   495:   let rec loop (sofar: string * location * bool) = function
   496:       [] -> sofar, []
   497:     | l :: rest ->
   498:         let newlabel, keepl =
   499:           match l with
   500:           | Case _ | Default _ -> sofar, true
   501:           | Label (ln, lloc, isorig) -> begin
   502:               match isorig, sofar with
   503:               | false, ("", _, _) ->
   504:                   (* keep this one only if we have no label so far *)
   505:                   (ln, lloc, isorig), false
   506:               | false, _ -> sofar, false
   507:               | true, (_, _, false) ->
   508:                   (* this is an original label; prefer it to temporary or
   509:                    * missing labels *)
   510:                   (ln, lloc, isorig), false
   511:               | true, _ -> sofar, false
   512:           end
   513:         in
   514:         let newlabel', rest' = loop newlabel rest in
   515:         newlabel', (if keepl then l :: rest' else rest')
   516:   in
   517:   loop ("", locUnknown, false) ll
   518: 
   519: class markUsedLabels (labelMap: (string, unit) H.t) = object
   520:   inherit nopCilVisitor
   521: 
   522:   method vstmt (s: stmt) =
   523:     match s.skind with
   524:       Goto (dest, _) ->
   525:         let (ln, _, _), _ = labelsToKeep !dest.labels in
   526:         if ln = "" then
   527:           E.s (E.bug "rmtmps: destination of statement does not have labels");
   528:         (* Mark it as used *)
   529:         H.replace labelMap ln ();
   530:         DoChildren
   531: 
   532:     | _ -> DoChildren
   533: 
   534:    (* No need to go into expressions or instructions *)
   535:   method vexpr _ = SkipChildren
   536:   method vinst _ = SkipChildren
   537:   method vtype _ = SkipChildren
   538: end
   539: 
   540: class removeUnusedLabels (labelMap: (string, unit) H.t) = object
   541:   inherit nopCilVisitor
   542: 
   543:   method vstmt (s: stmt) =
   544:     let (ln, lloc, lorig), lrest = labelsToKeep s.labels in
   545:     s.labels <-
   546:        (if ln <> "" && H.mem labelMap ln then (* We had labels *)
   547:          (Label(ln, lloc, lorig) :: lrest)
   548:        else
   549:          lrest);
   550:     DoChildren
   551: 
   552:    (* No need to go into expressions or instructions *)
   553:   method vexpr _ = SkipChildren
   554:   method vinst _ = SkipChildren
   555:   method vtype _ = SkipChildren
   556: end
   557: 
   558: (***********************************************************************
   559:  *
   560:  *  Removal of unused symbols
   561:  *
   562:  *)
   563: 
   564: 
   565: (* regular expression matching names of uninteresting locals *)
   566: let uninteresting =
   567:   let names = [
   568:     (* Flx_cil_cil.makeTempVar *)
   569:     "__cil_tmp";
   570: 
   571:     (* sm: I don't know where it comes from but these show up all over. *)
   572:     (* this doesn't seem to do what I wanted.. *)
   573:     "iter";
   574: 
   575:     (* various macros in glibc's <bits/string2.h> *)
   576:     "__result";
   577:     "__s"; "__s1"; "__s2";
   578:     "__s1_len"; "__s2_len";
   579:     "__retval"; "__len";
   580: 
   581:     (* various macros in glibc's <ctype.h> *)
   582:     "__c"; "__res";
   583: 
   584:     (* We remove the __malloc variables *)
   585:   ] in
   586: 
   587:   (* optional alpha renaming *)
   588:   let alpha = "\\(___[0-9]+\\)?" in
   589: 
   590:   let pattern = "\\(" ^ (String.concat "\\|" names) ^ "\\)" ^ alpha ^ "$" in
   591:   Str.regexp pattern
   592: 
   593: 
   594: let removeUnmarked file =
   595:   let removedLocals = ref [] in
   596: 
   597:   let filterGlobal global =
   598:     match global with
   599:     (* unused global types, variables, and functions are simply removed *)
   600:     | GType ({treferenced = false}, _)
   601:     | GCompTag ({creferenced = false}, _)
   602:     | GCompTagDecl ({creferenced = false}, _)
   603:     | GEnumTag ({ereferenced = false}, _)
   604:     | GEnumTagDecl ({ereferenced = false}, _)
   605:     | GVar ({vreferenced = false}, _, _)
   606:     | GVarDecl ({vreferenced = false}, _)
   607:     | GFun ({svar = {vreferenced = false}}, _) ->
   608:         trace (dprintf "removing global: %a\n" d_shortglobal global);
   609:         false
   610: 
   611:     (* retained functions may wish to discard some unused locals *)
   612:     | GFun (func, _) ->
   613:         let rec filterLocal local =
   614:           if not local.vreferenced then
   615:             begin
   616:               (* along the way, record the interesting locals that were removed *)
   617:               let name = local.vname in
   618:               trace (dprintf "removing local: %s\n" name);
   619:               if not (Str.string_match uninteresting name 0) then
   620:                 removedLocals := (func.svar.vname ^ "::" ^ name) :: !removedLocals;
   621:             end;
   622:           local.vreferenced
   623:         in
   624:         func.slocals <- List.filter filterLocal func.slocals;
   625:         (* We also want to remove unused labels. We do it all here, including
   626:          * marking the used labels *)
   627:         let usedLabels:(string, unit) H.t = H.create 13 in
   628:         ignore (visitCilBlock (new markUsedLabels usedLabels) func.sbody);
   629:         (* And now we scan again and we remove them *)
   630:         ignore (visitCilBlock (new removeUnusedLabels usedLabels) func.sbody);
   631:         true
   632: 
   633:     (* all other globals are retained *)
   634:     | _ ->
   635:         trace (dprintf "keeping global: %a\n" d_shortglobal global);
   636:         true
   637:   in
   638:   file.globals <- List.filter filterGlobal file.globals;
   639:   !removedLocals
   640: 
   641: 
   642: (***********************************************************************
   643:  *
   644:  *  Exported interface
   645:  *
   646:  *)
   647: 
   648: 
   649: type rootsFilter = global -> bool
   650: 
   651: let isDefaultRoot = isExportedRoot
   652: 
   653: 
   654: let keepUnused = ref false
   655: 
   656: let rec removeUnusedTemps ?(isRoot : rootsFilter = isDefaultRoot) file =
   657:   if !keepUnused || Flx_cil_trace.traceActive "disableTmpRemoval" then
   658:     Flx_cil_trace.trace "disableTmpRemoval" (dprintf "temp removal disabled\n")
   659:   else
   660:     begin
   661:       if !E.verboseFlag then
   662:         ignore (E.log "Removing unused temporaries\n" );
   663: 
   664:       if Flx_cil_trace.traceActive "printCilTree" then
   665:         dumpFile defaultCilPrinter stdout file;
   666: 
   667:       (* digest any pragmas that would create additional roots *)
   668:       let keepers = categorizePragmas file in
   669: 
   670:       (* if slicing, remove the bodies of non-kept functions *)
   671:       if !Flx_cil_cilutil.sliceGlobal then
   672:         amputateFunctionBodies keepers.defines file;
   673: 
   674:       (* build up the root set *)
   675:       let isRoot global =
   676:         isPragmaRoot keepers global ||
   677:         isRoot global
   678:       in
   679: 
   680:       (* mark everything reachable from the global roots *)
   681:       clearReferencedBits file;
   682:       markReachable file isRoot;
   683: 
   684:       (* take out the trash *)
   685:       let removedLocals = removeUnmarked file in
   686: 
   687:       (* print which original source variables were removed *)
   688:       if false && removedLocals != [] then
   689:         let count = List.length removedLocals in
   690:         if count > 2000 then
   691:           ignore (E.warn "%d unused local variables removed" count)
   692:         else
   693:           ignore (E.warn "%d unused local variables removed:@!%a"
   694:                     count (docList (chr ',' ++ break) text) removedLocals)
   695:     end
End ocaml section to src/flx_cil_rmtmps.ml[1]
Start ocaml section to src/flx_cil_rmtmps.mli[1 /1 ]
     1: # 14124 "./lpsrc/flx_cil.ipk"
     2: 
     3: (* rmtmps.mli *)
     4: (* remove unused things from cil files:               *)
     5: (*   - local temporaries introduced but not used      *)
     6: (*   - global declarations that are not used          *)
     7: (*   - types that are not used                        *)
     8: (*   - labels that are not used (gn)                  *)
     9: 
    10: 
    11: (* Some clients may wish to augment or replace the standard strategy
    12:  * for finding the initially reachable roots.  The optional
    13:  * "isRoot" argument to Flx_cil_rmtmps.removeUnusedTemps grants this
    14:  * flexibility.  If given, it should name a function which will return
    15:  * true if a given global should be treated as a retained root.
    16:  *
    17:  * Function Flx_cil_rmtmps.isDefaultRoot encapsulates the default root
    18:  * collection, which consists of those global variables and functions
    19:  * which are visible to the linker and runtime loader.  A client's
    20:  * root filter can use this if the goal is to augment rather than
    21:  * replace the standard logic.  Function Flx_cil_rmtmps.isExportedRoot is an
    22:  * alternate name for this same function.
    23:  *
    24:  * Function Flx_cil_rmtmps.isCompleteProgramRoot is an example of an alternate
    25:  * root collection.  This function assumes that it is operating on a
    26:  * complete program rather than just one object file.  It treats
    27:  * "main()" as a root, as well as any function carrying the
    28:  * "constructor" or "destructor" attribute.  All other globals are
    29:  * candidates for removal, regardless of their linkage.
    30:  *
    31:  * Note that certain CIL- and CCured-specific pragmas induce
    32:  * additional global roots.  This functionality is always present, and
    33:  * is not subject to replacement by "filterRoots".
    34:  *)
    35: 
    36: type rootsFilter = Flx_cil_cil.global -> bool
    37: val isDefaultRoot : rootsFilter
    38: val isExportedRoot : rootsFilter
    39: val isCompleteProgramRoot : rootsFilter
    40: 
    41: (* process a complete Flx_cil_cil file *)
    42: val removeUnusedTemps: ?isRoot:rootsFilter -> Flx_cil_cil.file -> unit
    43: 
    44: 
    45: val keepUnused: bool ref (* Set this to true to turn off this module *)
    46: 
End ocaml section to src/flx_cil_rmtmps.mli[1]
Start ocaml section to src/flx_cil_cabs2cil.ml[1 /1 ]
     1: # 14171 "./lpsrc/flx_cil.ipk"
     2: (* Type check and elaborate ABS to CIL *)
     3: 
     4: (* The references to ISO means ANSI/ISO 9899-1999 *)
     5: module A = Flx_cil_cabs
     6: module E = Flx_cil_errormsg
     7: module H = Hashtbl
     8: 
     9: open Flx_cil_cabs
    10: open Flx_cil_cabs_helper
    11: open Flx_cil_pretty
    12: open Flx_cil_cil
    13: open Flx_cil_trace
    14: 
    15: 
    16: let debugGlobal = false
    17: 
    18: (* Leave a certain global alone. Use a negative number to disable. *)
    19: let nocil: int ref = ref (-1)
    20: 
    21: (* Indicates whether we're allowed to duplicate small chunks. *)
    22: let allowDuplication: bool ref = ref true
    23: 
    24: (* ---------- source error message handling ------------- *)
    25: let lu = locUnknown
    26: let cabslu = {lineno = -10; filename = "cabs lu"; byteno = -10;}
    27: 
    28: 
    29: (** Interface to the Flx_cil_cprint printer *)
    30: let withFlx_cil_cprint (f: 'a -> unit) (x: 'a) : unit =
    31:   Flx_cil_cprint.commit (); Flx_cil_cprint.flush ();
    32:   let old = !Flx_cil_cprint.out in
    33:   Flx_cil_cprint.out := !E.logChannel;
    34:   f x;
    35:   Flx_cil_cprint.commit (); Flx_cil_cprint.flush ();
    36:   flush !Flx_cil_cprint.out;
    37:   Flx_cil_cprint.out := old
    38: 
    39: 
    40: (* Keep a list of functions that were called without a prototype. *)
    41: let noProtoFunctions : (int, bool) H.t = H.create 13
    42: 
    43: (* Flx_cil_check that s starts with the prefix p *)
    44: let prefix p s =
    45:   let lp = String.length p in
    46:   let ls = String.length s in
    47:   lp <= ls && String.sub s 0 lp = p
    48: 
    49: (***** COMPUTED GOTO ************)
    50: 
    51: (* The address of labels are small integers (starting from 0). A computed
    52:  * goto is replaced with a switch on the address of the label. We generate
    53:  * only one such switch and we'll jump to it from all computed gotos. To
    54:  * accomplish this we'll add a local variable to store the target of the
    55:  * goto. *)
    56: 
    57: (* The local variable in which to put the detination of the goto and the
    58:  * statement where to jump *)
    59: let gotoTargetData: (varinfo * stmt) option ref = ref None
    60: 
    61: (* The "addresses" of labels *)
    62: let gotoTargetHash: (string, int) H.t = H.create 13
    63: let gotoTargetNextAddr: int ref = ref 0
    64: 
    65: 
    66: (********** TRANSPARENT UNION ******)
    67: (* Flx_cil_check if a type is a transparent union, and return the first field if it
    68:  * is *)
    69: let isTransparentUnion (t: typ) : fieldinfo option =
    70:   match unrollType t with
    71:     TComp (comp, _) when not comp.cstruct ->
    72:       (* Turn transparent unions into the type of their first field *)
    73:       if hasAttribute "transparent_union" (typeAttrs t) then begin
    74:         match comp.cfields with
    75:           f :: _ -> Some f
    76:         | _ -> E.s (unimp "Empty transparent union: %s" (compFullName comp))
    77:       end else
    78:         None
    79:   | _ -> None
    80: 
    81: (* When we process an argument list, remember the argument index which has a
    82:  * transparent union type, along with the original type. We need this to
    83:  * process function definitions *)
    84: let transparentUnionArgs : (int * typ) list ref = ref []
    85: 
    86: let debugLoc = false
    87: let convLoc (l : cabsloc) =
    88:   if debugLoc then
    89:     ignore (E.log "convLoc at %s: line %d, btye %d\n" l.filename l.lineno l.byteno);
    90:   {line = l.lineno; file = l.filename; byte = l.byteno}
    91: 
    92: 
    93: let isOldStyleVarArgName n =
    94:   if !msvcMode then n = "va_alist"
    95:   else n = "__builtin_va_alist"
    96: 
    97: let isOldStyleVarArgTypeName n =
    98:   if !msvcMode then n = "va_list"  || n = "__ccured_va_list"
    99:   else n = "__builtin_va_alist_t"
   100: 
   101: (* Weimer
   102:  * multi-character character constants
   103:  * In MSCV, this code works:
   104:  *
   105:  * long l1 = 'abcd';  // note single quotes
   106:  * char * s = "dcba";
   107:  * long * lptr = ( long * )s;
   108:  * long l2 = *lptr;
   109:  * assert(l1 == l2);
   110:  *
   111:  * We need to change a multi-character character literal into the
   112:  * appropriate integer constant. However, the plot sickens: we
   113:  * must also be able to handle things like 'ab\nd' (value = * "d\nba")
   114:  * and 'abc' (vale = *"cba").
   115:  *
   116:  * First we convert 'AB\nD' into the list [ 65 ; 66 ; 10 ; 68 ], then we
   117:  * multiply and add to get the desired value.
   118:  *)
   119: 
   120: (* Given a character constant (like 'a' or 'abc') as a list of 64-bit
   121:  * values, turn it into a CIL constant.  Multi-character constants are
   122:  * treated as multi-digit numbers with radix given by the bit width of
   123:  * the specified type (either char or wchar_t). *)
   124: let reduce_multichar typ =
   125:   let radix = bitsSizeOf typ in
   126:   List.fold_left
   127:     (fun acc -> Int64.add (Int64.shift_left acc 8))
   128:     Int64.zero
   129: 
   130: let interpret_character_constant char_list =
   131:   let value = reduce_multichar charType char_list in
   132:   if value < (Int64.of_int 256) then
   133:     (CChr(Char.chr (Int64.to_int value))),(TInt(IChar,[]))
   134:   else begin
   135:     let orig_rep = None (* Some("'" ^ (String.escaped str) ^ "'") *) in
   136:     if value < (Int64.of_int 65536) then
   137:       (CInt64(value,IUShort,orig_rep)),(TInt(IUShort,[]))
   138:     else if value <= (Int64.of_int32 Int32.max_int) then
   139:       (CInt64(value,IULong,orig_rep)),(TInt(IULong,[]))
   140:     else
   141:       (CInt64(value,IULongLong,orig_rep)),(TInt(IULongLong,[]))
   142:   end
   143: 
   144: (*** EXPRESSIONS *************)
   145: 
   146:                                         (* We collect here the program *)
   147: let theFile : global list ref = ref []
   148: let theFileTypes : global list ref = ref []
   149: 
   150: let initGlobals () = theFile := []; theFileTypes := []
   151: 
   152: 
   153: let cabsPushGlobal (g: global) =
   154:   pushGlobal g ~types:theFileTypes ~variables:theFile
   155: 
   156: (* Keep track of some variable ids that must be turned into definitions. We
   157:  * do this when we encounter what appears a definition of a global but
   158:  * without initializer. We leave it a declaration because maybe down the road
   159:  * we see another definition with an initializer. But if we don't see any
   160:  * then we turn the last such declaration into a definition without
   161:  * initializer *)
   162: let mustTurnIntoDef: (int, bool) H.t = H.create 117
   163: 
   164: (* Globals that have already been defined. Indexed by the variable name. *)
   165: let alreadyDefined: (string, location) H.t = H.create 117
   166: 
   167: (* Globals that were created due to static local variables. We chose their
   168:  * names to be distinct from any global encountered at the time. But we might
   169:  * see a global with conflicting name later in the file. *)
   170: let staticLocals: (string, varinfo) H.t = H.create 13
   171: 
   172: 
   173: (* Typedefs. We chose their names to be distinct from any global encounterd
   174:  * at the time. But we might see a global with conflicting name later in the
   175:  * file *)
   176: let typedefs: (string, typeinfo) H.t = H.create 13
   177: 
   178: let popGlobals () =
   179:   let rec revonto (tail: global list) = function
   180:       [] -> tail
   181: 
   182:     | GVarDecl (vi, l) :: rest
   183:       when vi.vstorage != Extern && H.mem mustTurnIntoDef vi.vid ->
   184:         H.remove mustTurnIntoDef vi.vid;
   185:         revonto (GVar (vi, {init = None}, l) :: tail) rest
   186: 
   187:     | x :: rest -> revonto (x :: tail) rest
   188:   in
   189:   revonto (revonto [] !theFile) !theFileTypes
   190: 
   191: 
   192: (********* ENVIRONMENTS ***************)
   193: 
   194: (* The environment is kept in two distinct data structures. A hash table maps
   195:  * each original variable name into a varinfo (for variables, or an
   196:  * enumeration tag, or a type). (Note that the varinfo might contain an
   197:  * alpha-converted name different from that of the lookup name.) The Ocaml
   198:  * hash tables can keep multiple mappings for a single key. Each time the
   199:  * last mapping is returned and upon deletion the old mapping is restored. To
   200:  * keep track of local scopes we also maintain a list of scopes (represented
   201:  * as lists).  *)
   202: type envdata =
   203:     EnvVar of varinfo                   (* The name refers to a variable
   204:                                          * (which could also be a function) *)
   205:   | EnvEnum of exp * typ                (* The name refers to an enumeration
   206:                                          * tag for which we know the value
   207:                                          * and the host type *)
   208:   | EnvTyp of typ                       (* The name is of the form  "struct
   209:                                          * foo", or "union foo" or "enum foo"
   210:                                          * and refers to a type. Note that
   211:                                          * the name of the actual type might
   212:                                          * be different from foo due to alpha
   213:                                          * conversion *)
   214:   | EnvLabel of string                  (* The name refers to a label. This
   215:                                          * is useful for GCC's locally
   216:                                          * declared labels. The lookup name
   217:                                          * for this category is "label foo" *)
   218: 
   219: let env : (string, envdata * location) H.t = H.create 307
   220: (* We also keep a global environment. This is always a subset of the env *)
   221: let genv : (string, envdata * location) H.t = H.create 307
   222: 
   223:  (* In the scope we keep the original name, so we can remove them from the
   224:   * hash table easily *)
   225: type undoScope =
   226:     UndoRemoveFromEnv of string
   227:   | UndoResetAlphaCounter of alphaTableData ref * alphaTableData
   228:   | UndoRemoveFromAlphaTable of string
   229: 
   230: let scopes :  undoScope list ref list ref = ref []
   231: 
   232: let isAtTopLevel () =
   233:   !scopes = []
   234: 
   235: 
   236: (* When you add to env, you also add it to the current scope *)
   237: let addLocalToEnv (n: string) (d: envdata) =
   238: (*  ignore (E.log "%a: adding local %s to env\n" d_loc !currentLoc n); *)
   239:   H.add env n (d, !currentLoc);
   240:     (* If we are in a scope, then it means we are not at top level. Add the
   241:      * name to the scope *)
   242:   (match !scopes with
   243:     [] -> begin
   244:       match d with
   245:         EnvVar _ ->
   246:           E.s (E.bug "addLocalToEnv: not in a scope when adding %s!" n)
   247:       | _ -> () (* We might add types *)
   248:     end
   249:   | s :: _ ->
   250:       s := (UndoRemoveFromEnv n) :: !s)
   251: 
   252: 
   253: let addGlobalToEnv (k: string) (d: envdata) : unit =
   254: (*  ignore (E.log "%a: adding global %s to env\n" d_loc !currentLoc k); *)
   255:   H.add env k (d, !currentLoc);
   256:   (* Also add it to the global environment *)
   257:   H.add genv k (d, !currentLoc)
   258: 
   259: 
   260: 
   261: (* Create a new name based on a given name. The new name is formed from a
   262:  * prefix (obtained from the given name as the longest prefix that ends with
   263:  * a non-digit), followed by a '_' and then by a positive integer suffix. The
   264:  * first argument is a table mapping name prefixes with the largest suffix
   265:  * used so far for that prefix. The largest suffix is one when only the
   266:  * version without suffix has been used. *)
   267: let alphaTable : (string, alphaTableData ref) H.t = H.create 307
   268:         (* vars and enum tags. For composite types we have names like "struct
   269:          * foo" or "union bar" *)
   270: 
   271: (* To keep different name scopes different, we add prefixes to names
   272:  * specifying the kind of name: the kind can be one of "" for variables or
   273:  * enum tags, "struct" for structures and unions (they share the name space),
   274:  * "enum" for enumerations, or "type" for types *)
   275: let kindPlusName (kind: string)
   276:                  (origname: string) : string =
   277:   if kind = "" then origname else
   278:   kind ^ " " ^ origname
   279: 
   280: 
   281: let stripKind (kind: string) (kindplusname: string) : string =
   282:   let l = 1 + String.length kind in
   283:   if l > 1 then
   284:     String.sub kindplusname l (String.length kindplusname - l)
   285:   else
   286:     kindplusname
   287: 
   288: let newAlphaName (globalscope: bool) (* The name should have global scope *)
   289:                  (kind: string)
   290:                  (origname: string) : string * location =
   291:   let lookupname = kindPlusName kind origname in
   292:   (* If we are in a scope then it means that we are alpha-converting a local
   293:    * name. Go and add stuff to reset the state of the alpha table but only to
   294:    * the top-most scope (that of the enclosing function) *)
   295:   let rec findEnclosingFun = function
   296:       [] -> (* At global scope *)()
   297:     | [s] -> begin
   298:         let prefix = getAlphaPrefix lookupname in
   299:         try
   300:           let countref = H.find alphaTable prefix in
   301:           s := (UndoResetAlphaCounter (countref, !countref)) :: !s
   302:         with Not_found ->
   303:           s := (UndoRemoveFromAlphaTable prefix) :: !s
   304:     end
   305:     | _ :: rest -> findEnclosingFun rest
   306:   in
   307:   if not globalscope then
   308:     findEnclosingFun !scopes;
   309:   let newname, oldloc = Flx_cil_cil.newAlphaName alphaTable None lookupname in
   310:   stripKind kind newname, oldloc
   311: 
   312: 
   313: 
   314: 
   315: let explodeString (nullterm: bool) (s: string) : char list =
   316:   let rec allChars i acc =
   317:     if i < 0 then acc
   318:     else allChars (i - 1) ((String.get s i) :: acc)
   319:   in
   320:   allChars (-1 + String.length s)
   321:     (if nullterm then [Char.chr 0] else [])
   322: 
   323: (*** In order to process GNU_BODY expressions we must record that a given
   324:  *** COMPUTATION is interesting *)
   325: let gnu_body_result : (A.statement * ((exp * typ) option ref)) ref
   326:     = ref (A.NOP cabslu, ref None)
   327: 
   328: (*** When we do statements we need to know the current return type *)
   329: let currentReturnType : typ ref = ref (TVoid([]))
   330: let currentFunctionFDEC: fundec ref = ref dummyFunDec
   331: 
   332: 
   333: let lastStructId = ref 0
   334: let anonStructName (k: string) (suggested: string) =
   335:   incr lastStructId;
   336:   "__anon" ^ k ^ (if suggested <> "" then "_"  ^ suggested else "")
   337:   ^ "_" ^ (string_of_int (!lastStructId))
   338: 
   339: 
   340: let constrExprId = ref 0
   341: 
   342: 
   343: let startFile () =
   344:   H.clear env;
   345:   H.clear genv;
   346:   H.clear alphaTable;
   347:   lastStructId := 0
   348: 
   349: 
   350: 
   351: let enterScope () =
   352:   scopes := (ref []) :: !scopes
   353: 
   354:      (* Exit a scope and clean the environment. We do not yet delete from
   355:       * the name table *)
   356: let exitScope () =
   357:   let this, rest =
   358:     match !scopes with
   359:       car :: cdr -> car, cdr
   360:     | [] -> E.s (error "Not in a scope")
   361:   in
   362:   scopes := rest;
   363:   let rec loop = function
   364:       [] -> ()
   365:     | UndoRemoveFromEnv n :: t ->
   366:         H.remove env n; loop t
   367:     | UndoRemoveFromAlphaTable n :: t -> H.remove alphaTable n; loop t
   368:     | UndoResetAlphaCounter (vref, oldv) :: t ->
   369:         vref := oldv;
   370:         loop t
   371:   in
   372:   loop !this
   373: 
   374: (* Lookup a variable name. Return also the location of the definition. Might
   375:  * raise Not_found  *)
   376: let lookupVar (n: string) : varinfo * location =
   377:   match H.find env n with
   378:     (EnvVar vi), loc -> vi, loc
   379:   | _ -> raise Not_found
   380: 
   381: let lookupGlobalVar (n: string) : varinfo * location =
   382:   match H.find genv n with
   383:     (EnvVar vi), loc -> vi, loc
   384:   | _ -> raise Not_found
   385: 
   386: let docEnv () =
   387:   let acc : (string * (envdata * location)) list ref = ref [] in
   388:   let doone () = function
   389:       EnvVar vi, l ->
   390:         dprintf "Var(%s,global=%b) (at %a)" vi.vname vi.vglob d_loc l
   391:     | EnvEnum (tag, typ), l -> dprintf "Enum (at %a)" d_loc l
   392:     | EnvTyp t, l -> text "typ"
   393:     | EnvLabel l, _ -> text ("label " ^ l)
   394:   in
   395:   H.iter (fun k d -> acc := (k, d) :: !acc) env;
   396:   docList line (fun (k, d) -> dprintf "  %s -> %a" k doone d) () !acc
   397: 
   398: 
   399: 
   400: (* Add a new variable. Do alpha-conversion if necessary *)
   401: let alphaConvertVarAndAddToEnv (addtoenv: bool) (vi: varinfo) : varinfo =
   402: (*
   403:   ignore (E.log "%t: alphaConvert(addtoenv=%b) %s" d_thisloc addtoenv vi.vname);
   404: *)
   405:   (* Announce the name to the alpha conversion table *)
   406:   let newname, oldloc = newAlphaName (addtoenv && vi.vglob) "" vi.vname in
   407:   (* Make a copy of the vi if the name has changed. Never change the name for
   408:    * global variables *)
   409:   let newvi =
   410:     if vi.vname = newname then
   411:       vi
   412:     else begin
   413:       if vi.vglob then begin
   414:         (* Perhaps this is because we have seen a static local which happened
   415:          * to get the name that we later want to use for a global. *)
   416:         try
   417:           let static_local_vi = H.find staticLocals vi.vname in
   418:           H.remove staticLocals vi.vname;
   419:           (* Use the new name for the static local *)
   420:           static_local_vi.vname <- newname;
   421:           (* And continue using the last one *)
   422:           vi
   423:         with Not_found -> begin
   424:           (* Or perhaps we have seen a typedef which stole our name. This is
   425:            possible because typedefs use the same name space *)
   426:           try
   427:             let typedef_ti = H.find typedefs vi.vname in
   428:             H.remove typedefs vi.vname;
   429:             (* Use the new name for the typedef instead *)
   430:             typedef_ti.tname <- newname;
   431:             (* And continue using the last name *)
   432:             vi
   433:           with Not_found ->
   434:             E.s (E.error "It seems that we would need to rename global %s (to %s) because of previous occurrence at %a"
   435:                    vi.vname newname d_loc oldloc);
   436:         end
   437:       end else
   438:         copyVarinfo vi newname
   439:     end
   440:   in
   441:   (* Store all locals in the slocals (in reversed order). We'll reverse them
   442:    * and take out the formals at the end of the function *)
   443:   if not vi.vglob then
   444:     !currentFunctionFDEC.slocals <- newvi :: !currentFunctionFDEC.slocals;
   445: 
   446:   (if addtoenv then
   447:     if vi.vglob then
   448:       addGlobalToEnv vi.vname (EnvVar newvi)
   449:     else
   450:       addLocalToEnv vi.vname (EnvVar newvi));
   451: (*
   452:   ignore (E.log "  new=%s\n" newvi.vname);
   453: *)
   454: (*  ignore (E.log "After adding %s alpha table is: %a\n"
   455:             newvi.vname docAlphaTable alphaTable); *)
   456:   newvi
   457: 
   458: 
   459: (* Strip the "const" from the type. It is unfortunate that const variables
   460:  * can only be set in initialization. Once we decided to move all
   461:  * declarations to the top of the functions, we have no way of setting a
   462:  * "const" variable. Furthermore, if the type of the variable is an array or
   463:  * a struct we must recursively strip the "const" from fields and array
   464:  * elements. *)
   465: let rec stripConstLocalType (t: typ) : typ =
   466:   let dc a =
   467:     if hasAttribute "const" a then
   468:       dropAttribute "const" a
   469:     else a
   470:   in
   471:   match t with
   472:   | TPtr (bt, a) ->
   473:       (* We want to be able to detect by pointer equality if the type has
   474:        * changed. So, don't realloc the type unless necessary. *)
   475:       let a' = dc a in if a != a' then TPtr(bt, a') else t
   476:   | TInt (ik, a) ->
   477:       let a' = dc a in if a != a' then TInt(ik, a') else t
   478:   | TFloat(fk, a) ->
   479:       let a' = dc a in if a != a' then TFloat(fk, a') else t
   480:   | TNamed (ti, a) ->
   481:       (* We must go and drop the consts from the typeinfo as well ! *)
   482:       let t' = stripConstLocalType ti.ttype in
   483:       if t != t' then begin
   484:         (* ignore (warn "Stripping \"const\" from typedef %s\n" ti.tname); *)
   485:         ti.ttype <- t'
   486:       end;
   487:       let a' = dc a in if a != a' then TNamed(ti, a') else t
   488: 
   489:   | TEnum (ei, a) ->
   490:       let a' = dc a in if a != a' then TEnum(ei, a') else t
   491: 
   492:   | TArray(bt, leno, a) ->
   493:       (* We never assign to the array. So, no need to change the const. But
   494:        * we must change it on the base type *)
   495:       let bt' = stripConstLocalType bt in
   496:       if bt' != bt then TArray(bt', leno, a) else t
   497: 
   498:   | TComp(ci, a) -> (* Again, no need to change the a. But we must change the
   499:                      * fields. *)
   500:       List.iter
   501:         (fun f ->
   502:           let t' = stripConstLocalType f.ftype in
   503:           if t' != f.ftype then begin
   504:             ignore (warnOpt "Stripping \"const\" from field %s of %s\n"
   505:                       f.fname (compFullName ci));
   506:             f.ftype <- t'
   507:           end)
   508:         ci.cfields;
   509:       t
   510: 
   511:     (* We never assign functions either *)
   512:   | TFun(rt, args, va, a) -> t
   513:   | TVoid _ -> E.s (bug "cabs2cil: stripConstLocalType: void")
   514:   | TBuiltin_va_list a ->
   515:       let a' = dc a in if a != a' then TBuiltin_va_list a' else t
   516: 
   517: 
   518: 
   519: 
   520: (* Create a new temporary variable *)
   521: let newTempVar typ =
   522:   let stripConst t =
   523:     let a = typeAttrs t in
   524:     let a1 = dropAttribute "const" a in
   525:     setTypeAttrs t a1
   526:   in
   527:   if !currentFunctionFDEC == dummyFunDec then
   528:     E.s (bug "newTempVar called outside a function");
   529: (*  ignore (E.log "stripConstLocalType(%a) for temporary\n" d_type typ); *)
   530:   let t' = stripConstLocalType typ in
   531:   (* Start with the name "tmp". The alpha converter will fix it *)
   532:   let vi = makeVarinfo false "tmp" t' in
   533:   alphaConvertVarAndAddToEnv false  vi (* Do not add to the environment *)
   534: (*
   535:     { vname = "tmp";  (* addNewVar will make the name fresh *)
   536:       vid   = newVarId "tmp" false;
   537:       vglob = false;
   538:       vtype = t';
   539:       vdecl = locUnknown;
   540:       vinline = false;
   541:       vattr = [];
   542:       vaddrof = false;
   543:       vreferenced = false;   (* sm *)
   544:       vstorage = NoStorage;
   545:     }
   546: *)
   547: 
   548: let mkAddrOfAndMark ((b, off) as lval) : exp =
   549:   (* Mark the vaddrof flag if b is a variable *)
   550:   (match b with
   551:     Var vi -> vi.vaddrof <- true
   552:   | _ -> ());
   553:   mkAddrOf lval
   554: 
   555: (* Call only on arrays *)
   556: let mkStartOfAndMark ((b, off) as lval) : exp =
   557:   (* Mark the vaddrof flag if b is a variable *)
   558:   (match b with
   559:     Var vi -> vi.vaddrof <- true
   560:   | _ -> ());
   561:   let res = StartOf lval in
   562:   res
   563: 
   564: 
   565: 
   566:    (* Keep a set of self compinfo for composite types *)
   567: let compInfoNameEnv : (string, compinfo) H.t = H.create 113
   568: let enumInfoNameEnv : (string, enuminfo) H.t = H.create 113
   569: 
   570: 
   571: let lookupTypeNoError (kind: string)
   572:                       (n: string) : typ * location =
   573:   let kn = kindPlusName kind n in
   574:   match H.find env kn with
   575:     EnvTyp t, l -> t, l
   576:   | _ -> raise Not_found
   577: 
   578: let lookupType (kind: string)
   579:                (n: string) : typ * location =
   580:   try
   581:     lookupTypeNoError kind n
   582:   with Not_found ->
   583:     E.s (error "Cannot find type %s (kind:%s)\n" n kind)
   584: 
   585: (* Create the self ref cell and add it to the map. Return also an indication
   586:  * if this is a new one. *)
   587: let createCompInfo (iss: bool) (n: string) : compinfo * bool =
   588:   (* Add to the self cell set *)
   589:   let key = (if iss then "struct " else "union ") ^ n in
   590:   try
   591:     H.find compInfoNameEnv key, false (* Only if not already in *)
   592:   with Not_found -> begin
   593:     (* Create a compinfo. This will have "cdefined" false. *)
   594:     let res = mkCompInfo iss n (fun _ -> []) [] in
   595:     H.add compInfoNameEnv key res;
   596:     res, true
   597:   end
   598: 
   599: (* Create the self ref cell and add it to the map. Return an indication
   600:  * whether this is a new one. *)
   601: let createEnumInfo (n: string) : enuminfo * bool =
   602:   (* Add to the self cell set *)
   603:   try
   604:     H.find enumInfoNameEnv n, false (* Only if not already in *)
   605:   with Not_found -> begin
   606:     (* Create a enuminfo *)
   607:     let enum = { ename = n; eitems = [];
   608:                  eattr = []; ereferenced = false; } in
   609:     H.add enumInfoNameEnv n enum;
   610:     enum, true
   611:   end
   612: 
   613: 
   614:    (* kind is either "struct" or "union" or "enum" and n is a name *)
   615: let findCompType kind n a =
   616:   let key = kind ^ " " ^ n in
   617:   let makeForward () =
   618:     (* This is a forward reference, either because we have not seen this
   619:      * struct already or because we want to create a version with different
   620:      * attributes  *)
   621:     if kind = "enum" then
   622:       let enum, isnew = createEnumInfo n in
   623:       if isnew then
   624:         cabsPushGlobal (GEnumTagDecl (enum, !currentLoc));
   625:       TEnum (enum, a)
   626:     else
   627:       let iss = if kind = "struct" then true else false in
   628:       let self, isnew = createCompInfo iss n in
   629:       if isnew then
   630:         cabsPushGlobal (GCompTagDecl (self, !currentLoc));
   631:       TComp (self, a)
   632:   in
   633:   try
   634:     let old, _ = lookupTypeNoError kind n in (* already defined  *)
   635:     let olda = typeAttrs old in
   636:     if olda = a then old else makeForward ()
   637:   with Not_found -> makeForward ()
   638: 
   639: 
   640: (* A simple visitor that searchs a statement for labels *)
   641: class canDropStmtClass pRes = object
   642:   inherit nopCilVisitor
   643: 
   644:   method vstmt s =
   645:     if s.labels != [] then
   646:       (pRes := false; SkipChildren)
   647:     else
   648:       if !pRes then DoChildren else SkipChildren
   649: 
   650:   method vinst _ = SkipChildren
   651:   method vexpr _ = SkipChildren
   652: 
   653: end
   654: let canDropStatement (s: stmt) : bool =
   655:   let pRes = ref true in
   656:   let vis = new canDropStmtClass pRes in
   657:   ignore (visitCilStmt vis s);
   658:   !pRes
   659: 
   660: (**** Occasionally we see structs with no name and no fields *)
   661: 
   662: 
   663: module BlockChunk =
   664:   struct
   665:     type chunk = {
   666:         stmts: stmt list;
   667:         postins: instr list;              (* Some instructions to append at
   668:                                            * the ends of statements (in
   669:                                            * reverse order)  *)
   670:                                         (* A list of case statements visible at the
   671:                                          * outer level *)
   672:         cases: (label * stmt) list
   673:       }
   674: 
   675:     let empty =
   676:       { stmts = []; postins = []; cases = []; }
   677: 
   678:     let isEmpty (c: chunk) =
   679:       c.postins == [] && c.stmts == []
   680: 
   681:     let isNotEmpty (c: chunk) = not (isEmpty c)
   682: 
   683:     let i2c (i: instr) =
   684:       { empty with postins = [i] }
   685: 
   686:     (* Occasionally, we'll have to push postins into the statements *)
   687:     let pushPostIns (c: chunk) : stmt list =
   688:       if c.postins = [] then c.stmts
   689:       else
   690:         let rec toLast = function
   691:             [{skind=Instr il} as s] as stmts ->
   692:               s.skind <- Instr (il @ (List.rev c.postins));
   693:               stmts
   694: 
   695:           | [] -> [mkStmt (Instr (List.rev c.postins))]
   696: 
   697:           | a :: rest -> a :: toLast rest
   698:         in
   699:         compactStmts (toLast c.stmts)
   700: 
   701: 
   702:     let c2block (c: chunk) : block =
   703:       { battrs = [];
   704:         bstmts = pushPostIns c;
   705:       }
   706: 
   707:     (* Add an instruction at the end. Never refer to this instruction again
   708:      * after you call this *)
   709:     let (+++) (c: chunk) (i : instr) =
   710:       {c with postins = i :: c.postins}
   711: 
   712:     (* Append two chunks. Never refer to the original chunks after you call
   713:      * this. And especially never share c2 with somebody else *)
   714:     let (@@) (c1: chunk) (c2: chunk) =
   715:       { stmts = compactStmts (pushPostIns c1 @ c2.stmts);
   716:         postins = c2.postins;
   717:         cases = c1.cases @ c2.cases;
   718:       }
   719: 
   720:     let skipChunk = empty
   721: 
   722:     let returnChunk (e: exp option) (l: location) : chunk =
   723:       { stmts = [ mkStmt (Return(e, l)) ];
   724:         postins = [];
   725:         cases = []
   726:       }
   727: 
   728:     let ifChunk (be: exp) (l: location) (t: chunk) (e: chunk) : chunk =
   729: 
   730:       { stmts = [ mkStmt(If(be, c2block t, c2block e, l))];
   731:         postins = [];
   732:         cases = t.cases @ e.cases;
   733:       }
   734: 
   735:         (* We can duplicate a chunk if it has a few simple statements, and if
   736:          * it does not have cases *)
   737:     let duplicateChunk (c: chunk) = (* raises Failure if you should not
   738:                                      * duplicate this chunk *)
   739:       if not !allowDuplication then
   740:         raise (Failure "cannot duplicate: disallowed by user");
   741:       if c.cases != [] then raise (Failure "cannot duplicate: has cases") else
   742:       let pCount = ref (List.length c.postins) in
   743:       { stmts =
   744:         List.map
   745:           (fun s ->
   746:             if s.labels != [] then
   747:               raise (Failure "cannot duplicate: has labels");
   748:             (match s.skind with
   749:               If _ | Switch _ | Loop _ | Block _ ->
   750:                 raise (Failure "cannot duplicate: complex stmt")
   751:             | Instr il ->
   752:                 pCount := !pCount + List.length il
   753:             | _ -> incr pCount);
   754:             if !pCount > 5 then raise (Failure ("cannot duplicate: too many instr"));
   755:             (* We can just copy it because there is nothing to share here.
   756:              * Except maybe for the ref cell in Goto but it is Ok to share
   757:              * that, I think *)
   758:             { s with sid = s.sid}) c.stmts;
   759:         postins = c.postins; (* There is no shared stuff in instructions *)
   760:         cases = []
   761:       }
   762: (*
   763:     let duplicateChunk (c: chunk) =
   764:       if isEmpty c then c else raise (Failure ("cannot duplicate: isNotEmpty"))
   765: *)
   766:     (* We can drop a chunk if it does not have labels inside *)
   767:     let canDrop (c: chunk) =
   768:       List.for_all canDropStatement c.stmts
   769: 
   770:     let loopChunk (body: chunk) : chunk =
   771:       (* Make the statement *)
   772:       let loop = mkStmt (Loop (c2block body, !currentLoc, None, None)) in
   773:       { stmts = [ loop (* ; n *) ];
   774:         postins = [];
   775:         cases = body.cases;
   776:       }
   777: 
   778:     let breakChunk (l: location) : chunk =
   779:       { stmts = [ mkStmt (Break l) ];
   780:         postins = [];
   781:         cases = [];
   782:       }
   783: 
   784:     let continueChunk (l: location) : chunk =
   785:       { stmts = [ mkStmt (Continue l) ];
   786:         postins = [];
   787:         cases = []
   788:       }
   789: 
   790:         (* Keep track of the gotos *)
   791:     let backFlx_cil_patchGotos : (string, stmt ref list ref) H.t = H.create 17
   792:     let addGoto (lname: string) (bref: stmt ref) : unit =
   793:       let gotos =
   794:         try
   795:           H.find backFlx_cil_patchGotos lname
   796:         with Not_found -> begin
   797:           let gotos = ref [] in
   798:           H.add backFlx_cil_patchGotos lname gotos;
   799:           gotos
   800:         end
   801:       in
   802:       gotos := bref :: !gotos
   803: 
   804:         (* Keep track of the labels *)
   805:     let labelStmt : (string, stmt) H.t = H.create 17
   806:     let initLabels () =
   807:       H.clear backFlx_cil_patchGotos;
   808:       H.clear labelStmt
   809: 
   810:     let resolveGotos () =
   811:       H.iter
   812:         (fun lname gotos ->
   813:           try
   814:             let dest = H.find labelStmt lname in
   815:             List.iter (fun gref -> gref := dest) !gotos
   816:           with Not_found -> begin
   817:             E.s (error "Label %s not found\n" lname)
   818:           end)
   819:         backFlx_cil_patchGotos
   820: 
   821:         (* Get the first statement in a chunk. Might need to change the
   822:          * statements in the chunk *)
   823:     let getFirstInChunk (c: chunk) : stmt * stmt list =
   824:       (* Get the first statement and add the label to it *)
   825:       match c.stmts with
   826:         s :: _ -> s, c.stmts
   827:       | [] -> (* Add a statement *)
   828:           let n = mkEmptyStmt () in
   829:           n, n :: c.stmts
   830: 
   831:     let consLabel (l: string) (c: chunk) (loc: location)
   832:                                 (in_original_program_text : bool) : chunk =
   833:       (* Get the first statement and add the label to it *)
   834:       let labstmt, stmts' = getFirstInChunk c in
   835:       (* Add the label *)
   836:       labstmt.labels <- Label (l, loc, in_original_program_text) ::
   837:                                 labstmt.labels;
   838:       H.add labelStmt l labstmt;
   839:       if c.stmts == stmts' then c else {c with stmts = stmts'}
   840: 
   841:     let s2c (s:stmt) : chunk =
   842:       { stmts = [ s ];
   843:         postins = [];
   844:         cases = [];
   845:       }
   846: 
   847:     let gotoChunk (ln: string) (l: location) : chunk =
   848:       let gref = ref dummyStmt in
   849:       addGoto ln gref;
   850:       { stmts = [ mkStmt (Goto (gref, l)) ];
   851:         postins = [];
   852:         cases = [];
   853:       }
   854: 
   855:     let caseRangeChunk (el: exp list) (l: location) (next: chunk) =
   856:       let fst, stmts' = getFirstInChunk next in
   857:       let labels = List.map (fun e -> Case (e, l)) el in
   858:       let cases  = List.map (fun l -> (l, fst)) labels in
   859:       fst.labels <- labels @ fst.labels;
   860:       { next with stmts = stmts'; cases = cases @ next.cases}
   861: 
   862:     let defaultChunk (l: location) (next: chunk) =
   863:       let fst, stmts' = getFirstInChunk next in
   864:       let lb = Default l in
   865:       fst.labels <- lb :: fst.labels;
   866:       { next with stmts = stmts'; cases = (lb, fst) :: next.cases}
   867: 
   868: 
   869:     let switchChunk (e: exp) (body: chunk) (l: location) =
   870:       (* Make the statement *)
   871:       let switch = mkStmt (Switch (e, c2block body,
   872:                                    List.map (fun (_, s) -> s) body.cases,
   873:                                    l)) in
   874:       { stmts = [ switch (* ; n *) ];
   875:         postins = [];
   876:         cases = [];
   877:       }
   878: 
   879:     let mkFunctionBody (c: chunk) : block =
   880:       resolveGotos (); initLabels ();
   881:       if c.cases <> [] then
   882:         E.s (error "Switch cases not inside a switch statement\n");
   883:       c2block c
   884: 
   885:   end
   886: 
   887: open BlockChunk
   888: 
   889: 
   890: (************ Labels ***********)
   891: (* Since we turn dowhile and for loops into while we need to take care in
   892:  * processing the continue statement. For each loop that we enter we place a
   893:  * marker in a list saying what kinds of loop it is. When we see a continue
   894:  * for a Non-while loop we must generate a label for the continue *)
   895: type loopstate =
   896:     While
   897:   | NotWhile of string ref
   898: 
   899: let continues : loopstate list ref = ref []
   900: 
   901: let startLoop iswhile =
   902:   continues := (if iswhile then While else NotWhile (ref "")) :: !continues
   903: 
   904: (* Sometimes we need to create new label names *)
   905: let newLabelName (base: string) = fst (newAlphaName false "label" base)
   906: 
   907: let continueOrLabelChunk (l: location) : chunk =
   908:   match !continues with
   909:     [] -> E.s (error "continue not in a loop")
   910:   | While :: _ -> continueChunk l
   911:   | NotWhile lr :: _ ->
   912:       if !lr = "" then begin
   913:         lr := newLabelName "__Cont"
   914:       end;
   915:       gotoChunk !lr l
   916: 
   917: let consLabContinue (c: chunk) =
   918:   match !continues with
   919:     [] -> E.s (error "labContinue not in a loop")
   920:   | While :: rest -> c
   921:   | NotWhile lr :: rest -> if !lr = "" then c else consLabel !lr c !currentLoc false
   922: 
   923: let exitLoop () =
   924:   match !continues with
   925:     [] -> E.s (error "exit Loop not in a loop")
   926:   | _ :: rest -> continues := rest
   927: 
   928: 
   929: (* In GCC we can have locally declared labels. *)
   930: let genNewLocalLabel (l: string) =
   931:   (* Call the newLabelName to register the label name in the alpha conversion
   932:    * table. *)
   933:   let l' = newLabelName l in
   934:   (* Add it to the environment *)
   935:   addLocalToEnv (kindPlusName "label" l) (EnvLabel l');
   936:   l'
   937: 
   938: let lookupLabel (l: string) =
   939:   try
   940:     match H.find env (kindPlusName "label" l) with
   941:       EnvLabel l', _ -> l'
   942:     | _ -> raise Not_found
   943:   with Not_found ->
   944:     l
   945: 
   946: 
   947: (** ALLOCA ***)
   948: let allocaFun =
   949:   let fdec = emptyFunction "alloca" in
   950:   fdec.svar.vtype <-
   951:      TFun(voidPtrType, Some [ ("len", uintType, []) ], false, []);
   952:   fdec
   953: 
   954: (* Maps local variables that are variable sized arrays to the expression that
   955:  * denotes their length *)
   956: let varSizeArrays : (int, exp) H.t = H.create 17
   957: 
   958: (**** EXP actions ***)
   959: type expAction =
   960:     ADrop                               (* Drop the result. Only the
   961:                                          * side-effect is interesting *)
   962:   | ASet of lval * typ                  (* Put the result in a given lval,
   963:                                          * provided it matches the type. The
   964:                                          * type is the type of the lval. *)
   965:   | AExp of typ option                  (* Return the exp as usual.
   966:                                          * Optionally we can specify an
   967:                                          * expected type. This is useful for
   968:                                          * constants. The expected type is
   969:                                          * informational only, we do not
   970:                                          * guarantee that the converted
   971:                                          * expression has that type.You must
   972:                                          * use a doCast afterwards to make
   973:                                          * sure. *)
   974:   | AExpLeaveArrayFun                   (* Do it like an expression, but do
   975:                                          * not convert arrays of functions
   976:                                          * into pointers *)
   977: 
   978: 
   979: (*** Result of compiling conditional expressions *)
   980: type condExpRes =
   981:     CEExp of chunk * exp (* Do a chunk and then an expression *)
   982:   | CEAnd of condExpRes * condExpRes
   983:   | CEOr  of condExpRes * condExpRes
   984:   | CENot of condExpRes
   985: 
   986: (******** CASTS *********)
   987: let integralPromotion (t : typ) : typ = (* c.f. ISO 6.3.1.1 *)
   988:   match unrollType t with
   989:           (* We assume that an IInt can hold even an IUShort *)
   990:     TInt ((IShort|IUShort|IChar|ISChar|IUChar), a) -> TInt(IInt, a)
   991:   | TInt _ -> t
   992:   | TEnum (_, a) -> TInt(IInt, a)
   993:   | t -> E.s (error "integralPromotion: not expecting %a" d_type t)
   994: 
   995: 
   996: let arithmeticConversion    (* c.f. ISO 6.3.1.8 *)
   997:     (t1: typ)
   998:     (t2: typ) : typ =
   999:   let checkToInt _ = () in  (* dummies for now *)
  1000:   let checkToFloat _ = () in
  1001:   match unrollType t1, unrollType t2 with
  1002:     TFloat(FLongDouble, _), _ -> checkToFloat t2; t1
  1003:   | _, TFloat(FLongDouble, _) -> checkToFloat t1; t2
  1004:   | TFloat(FDouble, _), _ -> checkToFloat t2; t1
  1005:   | _, TFloat (FDouble, _) -> checkToFloat t1; t2
  1006:   | TFloat(FFloat, _), _ -> checkToFloat t2; t1
  1007:   | _, TFloat (FFloat, _) -> checkToFloat t1; t2
  1008:   | _, _ -> begin
  1009:       let t1' = integralPromotion t1 in
  1010:       let t2' = integralPromotion t2 in
  1011:       match unrollType t1', unrollType t2' with
  1012:         TInt(IULongLong, _), _ -> checkToInt t2'; t1'
  1013:       | _, TInt(IULongLong, _) -> checkToInt t1'; t2'
  1014: 
  1015:       (* We assume a long long is always larger than a long  *)
  1016:       | TInt(ILongLong, _), _ -> checkToInt t2'; t1'
  1017:       | _, TInt(ILongLong, _) -> checkToInt t1'; t2'
  1018: 
  1019:       | TInt(IULong, _), _ -> checkToInt t2'; t1'
  1020:       | _, TInt(IULong, _) -> checkToInt t1'; t2'
  1021: 
  1022: 
  1023:       | TInt(ILong,_), TInt(IUInt,_)
  1024:             when bitsSizeOf t1' <= bitsSizeOf t2' -> TInt(IULong,[])
  1025:       | TInt(IUInt,_), TInt(ILong,_)
  1026:             when bitsSizeOf t2' <= bitsSizeOf t1' -> TInt(IULong,[])
  1027: 
  1028:       | TInt(ILong, _), _ -> checkToInt t2'; t1'
  1029:       | _, TInt(ILong, _) -> checkToInt t1'; t2'
  1030: 
  1031:       | TInt(IUInt, _), _ -> checkToInt t2'; t1'
  1032:       | _, TInt(IUInt, _) -> checkToInt t1'; t2'
  1033: 
  1034:       | TInt(IInt, _), TInt (IInt, _) -> t1'
  1035: 
  1036:       | _, _ -> E.s (error "arithmeticConversion")
  1037:   end
  1038: 
  1039: 
  1040: (* Specify whether the cast is from the source code *)
  1041: let rec castTo ?(fromsource=false)
  1042:                 (ot : typ) (nt : typ) (e : exp) : (typ * exp ) =
  1043: (*
  1044:   ignore (E.log "%t: castTo:%s %a->%a\n"
  1045:             d_thisloc
  1046:             (if fromsource then "(source)" else "")
  1047:             d_type ot d_type nt);
  1048: *)
  1049:   if not fromsource && typeSig ot = typeSig nt then
  1050:     (* Do not put the cast if it is not necessary, unless it is from the
  1051:      * source. *)
  1052:     (ot, e)
  1053:   else begin
  1054:     let result = (nt, mkCastT e ot nt) in
  1055: (*
  1056:     ignore (E.log "castTo: ot=%a nt=%a\n  result is %a\n"
  1057:               d_type ot d_type nt
  1058:               d_plainexp (snd result));
  1059: *)
  1060:     (* Now see if we can have a cast here *)
  1061:     match ot, nt with
  1062:       TNamed(r, _), _ -> castTo r.ttype nt e
  1063:     | _, TNamed(r, _) -> castTo ot r.ttype e
  1064:     | TInt(ikindo,_), TInt(ikindn,_) ->
  1065:         (* We used to ignore attributes on integer-integer casts. Not anymore *)
  1066:         (* if ikindo = ikindn then (nt, e) else *)
  1067:         result
  1068: 
  1069:     | TPtr (told, _), TPtr(tnew, _) -> result
  1070: 
  1071:     | TInt _, TPtr _ -> result
  1072: 
  1073:     | TPtr _, TInt _ -> result
  1074: 
  1075:     | TArray _, TPtr _ -> result
  1076: 
  1077:     | TArray(t1,_,_), TArray(t2,None,_) when typeSig t1 = typeSig t2 -> (nt, e)
  1078: 
  1079:     | TPtr _, TArray(_,_,_) -> (nt, e)
  1080: 
  1081:     | TEnum _, TInt _ -> result
  1082:     | TFloat _, (TInt _|TEnum _) -> result
  1083:     | (TInt _|TEnum _), TFloat _ -> result
  1084:     | TFloat _, TFloat _ -> result
  1085:     | TInt _, TEnum _ -> result
  1086:     | TEnum _, TEnum _ -> result
  1087: 
  1088:     | TEnum _, TPtr _ -> result
  1089:     | TBuiltin_va_list _, (TInt _ | TPtr _) ->
  1090:         result
  1091: 
  1092:     | (TInt _ | TPtr _), TBuiltin_va_list _ ->
  1093:         ignore (warnOpt "Casting %a to __builtin_va_list" d_type ot);
  1094:         result
  1095: 
  1096:     | TPtr _, TEnum _ ->
  1097:         ignore (warnOpt "Casting a pointer into an enumeration type");
  1098:         result
  1099: 
  1100:           (* The expression is evaluated for its side-effects *)
  1101:     | (TInt _ | TEnum _ | TPtr _ ), TVoid _ ->
  1102:         (ot, e)
  1103: 
  1104:           (* Even casts between structs are allowed when we are only
  1105:            * modifying some attributes *)
  1106:     | TComp (comp1, a1), TComp (comp2, a2) when comp1.ckey = comp2.ckey ->
  1107:         (nt, e)
  1108: 
  1109:     | _ -> E.s (error "cabs2cil: castTo %a -> %a@!" d_type ot d_type nt)
  1110:   end
  1111: 
  1112: 
  1113: (* A cast that is used for conditional expressions. Pointers are Ok *)
  1114: let checkBool (ot : typ) (e : exp) : bool =
  1115:   match unrollType ot with
  1116:     TInt _ -> true
  1117:   | TPtr _ -> true
  1118:   | TEnum _ -> true
  1119:   | TFloat _ -> true
  1120:   |  _ -> E.s (error "castToBool %a" d_type ot)
  1121: 
  1122: 
  1123: (* We have our own version of addAttributes that does not allow duplicates *)
  1124: let cabsAddAttributes al0 (al: attributes) : attributes =
  1125:   if al0 == [] then al else
  1126:   List.fold_left
  1127:     (fun acc (Attr(an, _) as a) ->
  1128:       (* See if the attribute is already in there *)
  1129:       match filterAttributes an acc with
  1130:         [] -> addAttribute a acc (* Nothing with that name *)
  1131:       | a' :: _ ->
  1132:           if a = a' then
  1133:             acc (* Already in *)
  1134:           else begin
  1135:             ignore (warnOpt
  1136:                       "Duplicate attribute %a along with %a"
  1137:                       d_attr a d_attr a');
  1138:             (* let acc' = dropAttribute an acc in *)
  1139:             (** Keep both attributes *)
  1140:             addAttribute a acc
  1141:           end)
  1142:     al
  1143:     al0
  1144: 
  1145: let cabsTypeAddAttributes a0 t =
  1146:   begin
  1147:     match a0 with
  1148:     | [] ->
  1149:         (* no attributes, keep same type *)
  1150:           t
  1151:     | _ ->
  1152:         (* anything else: add a0 to existing attributes *)
  1153:           let add (a: attributes) = cabsAddAttributes a0 a in
  1154:           match t with
  1155:             TVoid a -> TVoid (add a)
  1156:           | TInt (ik, a) ->
  1157:               (* Here we have to watch for the mode attribute *)
  1158: (* sm: This stuff is to handle a GCC extension where you can request integers*)
  1159: (* of specific widths using the "mode" attribute syntax; for example:     *)
  1160: (*   typedef int int8_t __attribute__ ((__mode__ (  __QI__ ))) ;          *)
  1161: (* The cryptic "__QI__" defines int8_t to be 8 bits wide, instead of the  *)
  1162: (* 32 bits you'd guess if you didn't know about "mode".  The relevant     *)
  1163: (* testcase is test/small2/mode_sizes.c, and it was inspired by my        *)
  1164: (* /usr/include/sys/types.h.                                              *)
  1165: (*                                                                        *)
  1166: (* A consequence of this handling is that we throw away the mode          *)
  1167: (* attribute, which we used to go out of our way to avoid printing anyway.*)
  1168:               let ik', a0' =
  1169:                 (* Go over the list of new attributes and come back with a
  1170:                  * filtered list and a new integer kind *)
  1171:                 List.fold_left
  1172:                   (fun (ik', a0') a0one ->
  1173:                     match a0one with
  1174:                       Attr("mode", [ACons(mode,[])]) -> begin
  1175:                         (trace "gccwidth" (dprintf "I see mode %s applied to an int type\n"
  1176:                                              mode (* #$@!#@ ML! d_type t *) ));
  1177:                         (* the cases below encode the 32-bit assumption.. *)
  1178:                         match (ik', mode) with
  1179:                         | (IInt, "__QI__")      -> (IChar, a0')
  1180:                         | (IInt, "__byte__")    -> (IChar, a0')
  1181:                         | (IInt, "__HI__")      -> (IShort,  a0')
  1182:                         | (IInt, "__SI__")      -> (IInt, a0')   (* same as t *)
  1183:                         | (IInt, "__word__")    -> (IInt, a0')
  1184:                         | (IInt, "__pointer__") -> (IInt, a0')
  1185:                         | (IInt, "__DI__")      -> (ILongLong, a0')
  1186: 
  1187:                         | (IUInt, "__QI__")     -> (IUChar, a0')
  1188:                         | (IUInt, "__byte__")   -> (IUChar, a0')
  1189:                         | (IUInt, "__HI__")     -> (IUShort, a0')
  1190:                         | (IUInt, "__SI__")     -> (IUInt, a0')
  1191:                         | (IUInt, "__word__")   -> (IUInt, a0')
  1192:                         | (IUInt, "__pointer__")-> (IUInt, a0')
  1193:                         | (IUInt, "__DI__")     -> (IULongLong, a0')
  1194: 
  1195:                         | _ ->
  1196:                             (ignore (error "GCC width mode %s applied to unexpected type, or unexpected mode"
  1197:                                        mode));
  1198:                             (ik', a0one :: a0')
  1199: 
  1200:                       end
  1201:                     | _ -> (ik', a0one :: a0'))
  1202:                   (ik, [])
  1203:                   a0
  1204:               in
  1205:               TInt (ik', cabsAddAttributes a0' a)
  1206: 
  1207:           | TFloat (fk, a) -> TFloat (fk, add a)
  1208:           | TEnum (enum, a) -> TEnum (enum, add a)
  1209:           | TPtr (t, a) -> TPtr (t, add a)
  1210:           | TArray (t, l, a) -> TArray (t, l, add a)
  1211:           | TFun (t, args, isva, a) -> TFun(t, args, isva, add a)
  1212:           | TComp (comp, a) -> TComp (comp, add a)
  1213:           | TNamed (t, a) -> TNamed (t, add a)
  1214:           | TBuiltin_va_list a -> TBuiltin_va_list (add a)
  1215:   end
  1216: 
  1217: 
  1218: (* Do types *)
  1219:     (* Combine the types. Raises the Failure exception with an error message.
  1220:      * isdef says whether the new type is for a definition *)
  1221: type combineWhat =
  1222:     CombineFundef (* The new definition is for a function definition. The old
  1223:                    * is for a prototype *)
  1224:   | CombineFunarg (* Comparing a function argument type with an old prototype
  1225:                    * arg *)
  1226:   | CombineFunret (* Comparing the return of a function with that from an old
  1227:                    * prototype *)
  1228:   | CombineOther
  1229: 
  1230: (* We sometimes want to succeed in combining two structure types that are
  1231:  * identical except for the names of the structs. We keep a list of types
  1232:  * that are known to be equal *)
  1233: let isomorphicStructs : (string * string, bool) H.t = H.create 15
  1234: 
  1235: let rec combineTypes (what: combineWhat) (oldt: typ) (t: typ) : typ =
  1236:   match oldt, t with
  1237:   | TVoid olda, TVoid a -> TVoid (cabsAddAttributes olda a)
  1238:   | TInt (oldik, olda), TInt (ik, a) ->
  1239:       let combineIK oldk k =
  1240:         if oldk = k then oldk else
  1241:         (* GCC allows a function definition to have a more precise integer
  1242:          * type than a prototype that says "int" *)
  1243:         if not !msvcMode && oldk = IInt && bitsSizeOf t <= 32
  1244:            && (what = CombineFunarg || what = CombineFunret) then
  1245:           k
  1246:         else
  1247:           raise (Failure "different integer types")
  1248:       in
  1249:       TInt (combineIK oldik ik, cabsAddAttributes olda a)
  1250:   | TFloat (oldfk, olda), TFloat (fk, a) ->
  1251:       let combineFK oldk k =
  1252:         if oldk = k then oldk else
  1253:         (* GCC allows a function definition to have a more precise integer
  1254:          * type than a prototype that says "double" *)
  1255:         if not !msvcMode && oldk = FDouble && k = FFloat
  1256:            && (what = CombineFunarg || what = CombineFunret) then
  1257:           k
  1258:         else
  1259:           raise (Failure "different floating point types")
  1260:       in
  1261:       TFloat (combineFK oldfk fk, cabsAddAttributes olda a)
  1262:   | TEnum (_, olda), TEnum (ei, a) ->
  1263:       TEnum (ei, cabsAddAttributes olda a)
  1264: 
  1265:         (* Strange one. But seems to be handled by GCC *)
  1266:   | TEnum (oldei, olda) , TInt(IInt, a) -> TEnum(oldei,
  1267:                                                  cabsAddAttributes olda a)
  1268:         (* Strange one. But seems to be handled by GCC *)
  1269:   | TInt(IInt, olda), TEnum (ei, a) -> TEnum(ei, cabsAddAttributes olda a)
  1270: 
  1271: 
  1272:   | TComp (oldci, olda) , TComp (ci, a) ->
  1273:       if oldci.cstruct <> ci.cstruct then
  1274:         raise (Failure "different struct/union types");
  1275:       let comb_a = cabsAddAttributes olda a in
  1276:       if oldci.cname = ci.cname then
  1277:         TComp (oldci, comb_a)
  1278:       else
  1279:         (* Now maybe they are actually the same *)
  1280:         if H.mem isomorphicStructs (oldci.cname, ci.cname) then
  1281:           (* We know they are the same *)
  1282:           TComp (oldci, comb_a)
  1283:         else begin
  1284:           (* If one has 0 fields (undefined) while the other has some fields
  1285:            * we accept it *)
  1286:           let oldci_nrfields = List.length oldci.cfields in
  1287:           let ci_nrfields = List.length ci.cfields in
  1288:           if oldci_nrfields = 0 then
  1289:             TComp (ci, comb_a)
  1290:           else if ci_nrfields = 0 then
  1291:             TComp (oldci, comb_a)
  1292:           else begin
  1293:             (* Make sure that at least they have the same number of fields *)
  1294:             if  oldci_nrfields <> ci_nrfields then begin
  1295: (*
  1296:               ignore (E.log "different number of fields: %s had %d and %s had %d\n"
  1297:                         oldci.cname oldci_nrfields
  1298:                         ci.cname ci_nrfields);
  1299: *)
  1300:               raise (Failure "different structs(number of fields)");
  1301:             end;
  1302:             (* Assume they are the same *)
  1303:             H.add isomorphicStructs (oldci.cname, ci.cname) true;
  1304:             H.add isomorphicStructs (ci.cname, oldci.cname) true;
  1305:             (* Flx_cil_check that the fields are isomorphic and watch for Failure *)
  1306:             (try
  1307:               List.iter2 (fun oldf f ->
  1308:                 if oldf.fbitfield <> f.fbitfield then
  1309:                   raise (Failure "different structs(bitfield info)");
  1310:                 if oldf.fattr <> f.fattr then
  1311:                   raise (Failure "different structs(field attributes)");
  1312:                 (* Make sure the types are compatible *)
  1313:                 ignore (combineTypes CombineOther oldf.ftype f.ftype);
  1314:                 ) oldci.cfields ci.cfields
  1315:             with Failure _ as e -> begin
  1316:               (* Our assumption was wrong. Forget the isomorphism *)
  1317:               ignore (E.log "\tFailed in our assumption that %s and %s are isomorphic\n"
  1318:                         oldci.cname ci.cname);
  1319:               H.remove isomorphicStructs (oldci.cname, ci.cname);
  1320:               H.remove isomorphicStructs (ci.cname, oldci.cname);
  1321:               raise e
  1322:             end);
  1323:             (* We get here if we succeeded *)
  1324:             TComp (oldci, comb_a)
  1325:           end
  1326:         end
  1327: 
  1328:   | TArray (oldbt, oldsz, olda), TArray (bt, sz, a) ->
  1329:       let newbt = combineTypes CombineOther oldbt bt in
  1330:       let newsz =
  1331:         if oldsz = sz then sz else
  1332:         match oldsz, sz with
  1333:           None, Some _ -> sz
  1334:         | Some _, None -> oldsz
  1335:         | _ -> raise (Failure "different array lengths")
  1336:       in
  1337:       TArray (newbt, newsz, cabsAddAttributes olda a)
  1338: 
  1339:   | TPtr (oldbt, olda), TPtr (bt, a) ->
  1340:       TPtr (combineTypes CombineOther oldbt bt, cabsAddAttributes olda a)
  1341: 
  1342:   | TFun (_, _, _, [Attr("missingproto",_)]), TFun _ -> t
  1343: 
  1344:   | TFun (oldrt, oldargs, oldva, olda), TFun (rt, args, va, a) ->
  1345:       let newrt = combineTypes
  1346:           (if what = CombineFundef then CombineFunret else CombineOther)
  1347:           oldrt rt
  1348:       in
  1349:       if oldva != va then
  1350:         raise (Failure "diferent vararg specifiers");
  1351:       (* If one does not have arguments, believe the one with the
  1352:       * arguments *)
  1353:       let newargs =
  1354:         if oldargs = None then args else
  1355:         if args = None then oldargs else
  1356:         let oldargslist = argsToList oldargs in
  1357:         let argslist = argsToList args in
  1358:         if List.length oldargslist <> List.length argslist then
  1359:           raise (Failure "different number of arguments")
  1360:         else begin
  1361:           (* Go over the arguments and update the old ones with the
  1362:           * adjusted types *)
  1363:           Some
  1364:             (List.map2
  1365:                (fun (on, ot, oa) (an, at, aa) ->
  1366:                  (* Update the names. Always prefer the new name. This is
  1367:                   * very important if the prototype uses different names than
  1368:                   * the function definition. *)
  1369:                  let n = if an <> "" then an else on in
  1370:                  let t =
  1371:                    combineTypes
  1372:                      (if what = CombineFundef then
  1373:                        CombineFunarg else CombineOther)
  1374:                      ot at
  1375:                  in
  1376:                  let a = addAttributes oa aa in
  1377:                  (n, t, a))
  1378:                oldargslist argslist)
  1379:         end
  1380:       in
  1381:       TFun (newrt, newargs, oldva, cabsAddAttributes olda a)
  1382: 
  1383:   | TNamed (oldt, olda), TNamed (t, a) when oldt.tname = t.tname ->
  1384:       TNamed (oldt, cabsAddAttributes olda a)
  1385: 
  1386:         (* Unroll first the new type *)
  1387:   | _, TNamed (t, a) ->
  1388:       let res = combineTypes what oldt t.ttype in
  1389:       cabsTypeAddAttributes a res
  1390: 
  1391:         (* And unroll the old type as well if necessary *)
  1392:   | TNamed (oldt, a), _ ->
  1393:       let res = combineTypes what oldt.ttype t in
  1394:       cabsTypeAddAttributes a res
  1395: 
  1396:   | _ -> raise (Failure "different type constructors")
  1397: 
  1398: 
  1399: (* Create and cache varinfo's for globals. Starts with a varinfo but if the
  1400:  * global has been declared already it might come back with another varinfo.
  1401:  * Returns the varinfo to use (might be the old one), and an indication
  1402:  * whether the variable exists already in the environment *)
  1403: let makeGlobalVarinfo (isadef: bool) (vi: varinfo) : varinfo * bool =
  1404:   try (* See if already defined, in the global environment. We could also
  1405:        * look it up in the whole environment but in that case we might see a
  1406:        * local. This can happen when we declare an extern variable with
  1407:        * global scope but we are in a local scope. *)
  1408:     let oldvi, oldloc = lookupGlobalVar vi.vname in
  1409:     begin
  1410:       try
  1411:         oldvi.vtype <-
  1412:            combineTypes
  1413:              (if isadef then CombineFundef else CombineOther)
  1414:              oldvi.vtype vi.vtype
  1415:          ;
  1416:         (* It was already defined. We must reuse the varinfo.
  1417:          * But clean up the storage.  *)
  1418:         let newstorage =
  1419:           match oldvi.vstorage, vi.vstorage with
  1420:           | Extern, other
  1421:           | NoStorage, other
  1422:           | other, Extern
  1423:           | other, NoStorage ->
  1424:               other
  1425:           | _ ->
  1426:               if vi.vstorage != oldvi.vstorage then
  1427:                 ignore (warn
  1428:                           "Inconsistent storage specification for %s. Previous declaration: %a"
  1429:                           vi.vname d_loc oldloc);
  1430:               vi.vstorage
  1431:         in
  1432:         oldvi.vinline <- oldvi.vinline || vi.vinline;
  1433:         oldvi.vstorage <- newstorage;
  1434:         oldvi.vattr <- cabsAddAttributes oldvi.vattr vi.vattr;
  1435:         oldvi, true
  1436: 
  1437:       with Failure reason ->
  1438:         ignore (E.log "old type = %a\n" d_plaintype oldvi.vtype);
  1439:         ignore (E.log "new type = %a\n" d_plaintype vi.vtype);
  1440:         if !Flx_cil_lexerhack.get_lang () =`C then
  1441:           E.s (error "Declaration of %s does not match previous declaration from %a (%s)."
  1442:                vi.vname d_loc oldloc reason)
  1443:         else begin
  1444:           ignore (E.log "[Overload] %s." vi.vname);
  1445:           vi, false
  1446:         end
  1447:     end;
  1448: 
  1449: 
  1450:   with Not_found -> begin (* A new one.  *)
  1451:     (* Announce the name to the alpha conversion table. This will not
  1452:      * actually change the name of the vi. See the definition of
  1453:      * alphaConvertVarAndAddToEnv *)
  1454:     alphaConvertVarAndAddToEnv true vi, false
  1455:   end
  1456: 
  1457: let conditionalConversion (t2: typ) (t3: typ) : typ =
  1458:   let is_char k = match k with
  1459:     IChar | ISChar | IUChar -> true
  1460:   | _ -> false in
  1461:   let tresult =  (* ISO 6.5.15 *)
  1462:     match unrollType t2, unrollType t3 with
  1463:       (TInt _ | TEnum _ | TFloat _),
  1464:       (TInt _ | TEnum _ | TFloat _) ->
  1465:         arithmeticConversion t2 t3
  1466:     | TComp (comp2,_), TComp (comp3,_)
  1467:           when comp2.ckey = comp3.ckey -> t2
  1468:     | TPtr(_, _), TPtr(TVoid _, _) -> t2
  1469:     | TPtr(TVoid _, _), TPtr(_, _) -> t3
  1470:     | TPtr _, TPtr _ when typeSig t2 = typeSig t3 -> t2
  1471:     | TPtr _, TInt _  -> t2 (* most likely comparison with 0 *)
  1472:     | TInt _, TPtr _ -> t3 (* most likely comparison with 0 *)
  1473: 
  1474:           (* When we compare two pointers of diffent type, we combine them
  1475:            * using the same algorithm when combining multiple declarations of
  1476:            * a global *)
  1477:     | (TPtr _) as t2', (TPtr _ as t3') -> begin
  1478:         try combineTypes CombineOther t2' t3'
  1479:         with Failure msg -> begin
  1480:           ignore (warn "A.QUESTION: %a does not match %a (%s)"
  1481:                     d_type (unrollType t2) d_type (unrollType t3) msg);
  1482:           t2 (* Just pick one *)
  1483:         end
  1484:     end
  1485:     | _, _ -> E.s (error "A.QUESTION for invalid combination of types")
  1486:   in
  1487:   tresult
  1488: 
  1489: (* Some utilitites for doing initializers *)
  1490: 
  1491: let debugInit = false
  1492: 
  1493: type preInit =
  1494:   | NoInitPre
  1495:   | SinglePre of exp
  1496:   | CompoundPre of int ref (* the maximum used index *)
  1497:                  * preInit array ref (* an array with initializers *)
  1498: 
  1499: (* Instructions on how to handle designators *)
  1500: type handleDesignators =
  1501:   | Handle (* Handle them yourself *)
  1502:   | DoNotHandle (* Do not handle them your self *)
  1503:   | HandleAsNext (* First behave as if you have a NEXT_INIT. Useful for going
  1504:                   * into nested designators *)
  1505:   | HandleFirst (* Handle only the first designator *)
  1506: 
  1507: (* Set an initializer *)
  1508: let rec setOneInit (this: preInit)
  1509:                    (o: offset) (e: exp) : preInit =
  1510:   match o with
  1511:     NoOffset -> SinglePre e
  1512:   | _ ->
  1513:       let idx, (* Index in the current comp *)
  1514:           restoff (* Rest offset *) =
  1515:         match o with
  1516:         | Index(Const(CInt64(i,_,_)), off) -> Int64.to_int i, off
  1517:         | Field (f, off) ->
  1518:             (* Find the index of the field *)
  1519:             let rec loop (idx: int) = function
  1520:                 [] -> E.s (bug "Cannot find field %s" f.fname)
  1521:               | f' :: _ when f'.fname = f.fname -> idx
  1522:               | _ :: restf -> loop (idx + 1) restf
  1523:             in
  1524:             loop 0 f.fcomp.cfields, off
  1525:         | _ -> E.s (bug "setOneInit: non-constant index")
  1526:       in
  1527:       let pMaxIdx, pArray =
  1528:         match this  with
  1529:           NoInitPre  -> (* No initializer so far here *)
  1530:             ref idx, ref (Array.create (max 32 (idx + 1)) NoInitPre)
  1531: 
  1532:         | CompoundPre (pMaxIdx, pArray) ->
  1533:             if !pMaxIdx < idx then begin
  1534:               pMaxIdx := idx;
  1535:               (* Maybe we also need to grow the array *)
  1536:               let l = Array.length !pArray in
  1537:               if l <= idx then begin
  1538:                 let growBy = max (max 32 (idx + 1 - l)) (l / 2) in
  1539:                 let newarray = Array.make (growBy + idx) NoInitPre in
  1540:                 Array.blit !pArray 0 newarray 0 l;
  1541:                 pArray := newarray
  1542:               end
  1543:             end;
  1544:             pMaxIdx, pArray
  1545:         | SinglePre e ->
  1546:             E.s (unimp "Index %d is already initialized" idx)
  1547:       in
  1548:       assert (idx >= 0 && idx < Array.length !pArray);
  1549:       let this' = setOneInit !pArray.(idx) restoff e in
  1550:       !pArray.(idx) <- this';
  1551:       CompoundPre (pMaxIdx, pArray)
  1552: 
  1553: 
  1554: (* collect a CIL initializer, given the original syntactic initializer
  1555:  * 'preInit'; this returns a type too, since initialization of an array
  1556:  * with unspecified size actually changes the array's type
  1557:  * (ANSI C, 6.7.8, para 22) *)
  1558: let rec collectInitializer
  1559:     (this: preInit)
  1560:     (thistype: typ) : (init * typ) =
  1561:   if this = NoInitPre then (makeZeroInit thistype), thistype
  1562:   else
  1563:     match unrollType thistype, this with
  1564:     | _ , SinglePre e -> SingleInit e, thistype
  1565:     | TArray (bt, leno, at), CompoundPre (pMaxIdx, pArray) ->
  1566:         let (len, newtype) =
  1567:           (* normal case: use array's declared length, newtype=thistype *)
  1568:           try (lenOfArray leno, thistype)
  1569: 
  1570:           (* unsized array case, length comes from initializers *)
  1571:           with LenOfArray ->
  1572:             (!pMaxIdx + 1,
  1573:              TArray (bt, Some (integer (!pMaxIdx + 1)), at))
  1574:         in
  1575:         if !pMaxIdx >= len then
  1576:           E.s (E.bug "collectInitializer: too many initializers(%d >= %d)\n"
  1577:                  !pMaxIdx len);
  1578:         (* len could be extremely big. So omit the last initializers, if they
  1579:          * are many (more than 16) *)
  1580: (*
  1581:         ignore (E.log "collectInitializer: len = %d, pMaxIdx= %d\n"
  1582:                   len !pMaxIdx); *)
  1583:         let endAt =
  1584:           if len - 1 > !pMaxIdx + 16 then
  1585:             !pMaxIdx
  1586:           else
  1587:             len - 1
  1588:         in
  1589:         (* Make one zero initializer to be used next *)
  1590:         let oneZeroInit = makeZeroInit bt in
  1591:         let rec collect (acc: (offset * init) list) (idx: int) =
  1592:           if idx = -1 then acc
  1593:           else
  1594:             let thisi =
  1595:               if idx > !pMaxIdx then oneZeroInit
  1596:               else (fst (collectInitializer !pArray.(idx) bt))
  1597:             in
  1598:             collect ((Index(integer idx, NoOffset), thisi) :: acc) (idx - 1)
  1599:         in
  1600: 
  1601:         CompoundInit (thistype, collect [] endAt), newtype
  1602: 
  1603:     | TComp (comp, _), CompoundPre (pMaxIdx, pArray) when comp.cstruct ->
  1604:         let rec collect (idx: int) = function
  1605:             [] -> []
  1606:           | f :: restf ->
  1607:               if f.fname = missingFieldName then
  1608:                 collect (idx + 1) restf
  1609:               else
  1610:                 let thisi =
  1611:                   if idx > !pMaxIdx then
  1612:                     makeZeroInit f.ftype
  1613:                   else
  1614:                     collectFieldInitializer !pArray.(idx) f
  1615:                 in
  1616:                 (Field(f, NoOffset), thisi) :: collect (idx + 1) restf
  1617:         in
  1618:         CompoundInit (thistype, collect 0 comp.cfields), thistype
  1619: 
  1620:     | TComp (comp, _), CompoundPre (pMaxIdx, pArray) when not comp.cstruct ->
  1621:         (* Find the field to initialize *)
  1622:         let rec findField (idx: int) = function
  1623:             [] -> E.s (bug "collectInitializer: union")
  1624:           | _ :: rest when idx < !pMaxIdx && !pArray.(idx) = NoInitPre ->
  1625:               findField (idx + 1) rest
  1626:           | f :: _ when idx = !pMaxIdx ->
  1627:               Field(f, NoOffset),
  1628:               collectFieldInitializer !pArray.(idx) f
  1629:           | _ -> E.s (error "Can initialize only one field for union")
  1630:         in
  1631:         if !msvcMode && !pMaxIdx != 0 then
  1632:           ignore (warn "On MSVC we can initialize only the first field of a union");
  1633:         CompoundInit (thistype, [ findField 0 comp.cfields ]), thistype
  1634: 
  1635:     | _ -> E.s (unimp "collectInitializer")
  1636: 
  1637: and collectFieldInitializer
  1638:     (this: preInit)
  1639:     (f: fieldinfo) : init =
  1640:   (* collect, and rewrite type *)
  1641:   let init,newtype = (collectInitializer this f.ftype) in
  1642:   f.ftype <- newtype;
  1643:   init
  1644: 
  1645: 
  1646: type stackElem =
  1647:     InArray of offset * typ * int * int ref (* offset of parent, base type,
  1648:                                              * length, current index. If the
  1649:                                              * array length is unspecified we
  1650:                                              * use Int.max_int  *)
  1651:   | InComp  of offset * compinfo * fieldinfo list (* offset of parent,
  1652:                                                    base comp, current fields *)
  1653: 
  1654: 
  1655: (* A subobject is given by its address. The address is read from the end of
  1656:  * the list (the bottom of the stack), starting with the current object *)
  1657: type subobj = { mutable stack: stackElem list; (* With each stack element we
  1658:                                                 * store the offset of its
  1659:                                                 * PARENT  *)
  1660:                 mutable eof: bool; (* The stack is empty and we reached the
  1661:                                     * end *)
  1662:                 mutable soTyp: typ; (* The type of the subobject. Set using
  1663:                                      * normalSubobj after setting stack. *)
  1664:                 mutable soOff: offset; (* The offset of the subobject. Set
  1665:                                         * using normalSubobj after setting
  1666:                                         * stack.  *)
  1667:                         curTyp: typ; (* Type of current object. See ISO for
  1668:                                       * the definition of the current object *)
  1669:                         curOff: offset; (* The offset of the current obj *)
  1670:                         host: varinfo; (* The host that we are initializing.
  1671:                                         * For error messages *)
  1672:               }
  1673: 
  1674: 
  1675: (* Make a subobject iterator *)
  1676: let rec makeSubobj
  1677:     (host: varinfo)
  1678:     (curTyp: typ)
  1679:     (curOff: offset) =
  1680:   let so =
  1681:     { host = host; curTyp = curTyp; curOff = curOff;
  1682:       stack = []; eof = false;
  1683:       (* The next are fixed by normalSubobj *)
  1684:       soTyp = voidType; soOff = NoOffset } in
  1685:   normalSubobj so;
  1686:   so
  1687: 
  1688:   (* Normalize a stack so the we always point to a valid subobject. Do not
  1689:    * descend into type *)
  1690: and normalSubobj (so: subobj) : unit =
  1691:   match so.stack with
  1692:     [] -> so.soOff <- so.curOff; so.soTyp <- so.curTyp
  1693:         (* The array is over *)
  1694:   | InArray (parOff, bt, leno, current) :: rest ->
  1695:       if leno = !current then begin (* The array is over *)
  1696:         if debugInit then ignore (E.log "Past the end of array\n");
  1697:         so.stack <- rest;
  1698:         advanceSubobj so
  1699:       end else begin
  1700:         so.soTyp <- bt;
  1701:         so.soOff <- addOffset (Index(integer !current, NoOffset)) parOff
  1702:       end
  1703: 
  1704:         (* The fields are over *)
  1705:   | InComp (parOff, comp, nextflds) :: rest ->
  1706:       if nextflds = [] then begin (* No more fields here *)
  1707:         if debugInit then ignore (E.log "Past the end of structure\n");
  1708:         so.stack <- rest;
  1709:         advanceSubobj so
  1710:       end else begin
  1711:         let fst = List.hd nextflds in
  1712:         so.soTyp <- fst.ftype;
  1713:         so.soOff <- addOffset (Field(fst, NoOffset)) parOff
  1714:       end
  1715: 
  1716:   (* Advance to the next subobject. Always apply to a normalized object *)
  1717: and advanceSubobj (so: subobj) : unit =
  1718:   if so.eof then E.s (bug "advanceSubobj past end");
  1719:   match so.stack with
  1720:   | [] -> if debugInit then ignore (E.log "Setting eof to true\n");
  1721:           so.eof <- true
  1722:   | InArray (parOff, bt, leno, current) :: rest ->
  1723:       if debugInit then ignore (E.log "  Advancing to [%d]\n" (!current + 1));
  1724:       (* so.stack <- InArray (parOff, bt, leno, current + 1) :: rest; *)
  1725:       incr current;
  1726:       normalSubobj so
  1727: 
  1728:         (* The fields are over *)
  1729:   | InComp (parOff, comp, nextflds) :: rest ->
  1730:       if debugInit then
  1731:         ignore (E.log "Advancing past .%s\n" (List.hd nextflds).fname);
  1732:       let flds' = try List.tl nextflds with _ -> E.s (bug "advanceSubobj") in
  1733:       so.stack <- InComp(parOff, comp, flds') :: rest;
  1734:       normalSubobj so
  1735: 
  1736: 
  1737: 
  1738: (* Find the fields to initialize in a composite. *)
  1739: let fieldsToInit
  1740:     (comp: compinfo)
  1741:     (designator: string option)
  1742:     : fieldinfo list =
  1743:   (* Never look at anonymous fields *)
  1744:   let flds1 =
  1745:     List.filter (fun f -> f.fname <> missingFieldName) comp.cfields in
  1746:   let flds2 =
  1747:     match designator with
  1748:       None -> flds1
  1749:     | Some fn ->
  1750:         let rec loop = function
  1751:             [] -> E.s (error "Cannot find designated field %s" fn)
  1752:           | (f :: _) as nextflds when f.fname = fn -> nextflds
  1753:           | _ :: rest -> loop rest
  1754:         in
  1755:         loop flds1
  1756:   in
  1757:   (* If it is a union we only initialize one field *)
  1758:   match flds2 with
  1759:     [] -> []
  1760:   | (f :: rest) as toinit ->
  1761:       if comp.cstruct then toinit else [f]
  1762: 
  1763: 
  1764: let integerArrayLength (leno: exp option) : int =
  1765:   match leno with
  1766:     None -> max_int
  1767:   | Some len -> begin
  1768:       try lenOfArray leno
  1769:       with LenOfArray ->
  1770:         E.s (error "Initializing non-constant-length array\n  length=%a\n"
  1771:                d_exp len)
  1772:   end
  1773: 
  1774: (* sm: I'm sure something like this already exists, but ... *)
  1775: let isNone (o : 'a option) : bool =
  1776:   match o with
  1777:   | None -> true
  1778:   | Some _ -> false
  1779: 
  1780: 
  1781: let annonCompFieldNameId = ref 0
  1782: let annonCompFieldName = "__annonCompField"
  1783: 
  1784: 
  1785: 
  1786: (* Flx_cil_utility ***)
  1787: let rec replaceLastInList
  1788:     (lst: A.expression list)
  1789:     (how: A.expression -> A.expression) : A.expression list=
  1790:   match lst with
  1791:     [] -> []
  1792:   | [e] -> [how e]
  1793:   | h :: t -> h :: replaceLastInList t how
  1794: 
  1795: 
  1796: 
  1797: 
  1798: 
  1799: let convBinOp (bop: A.binary_operator) : binop =
  1800:   match bop with
  1801:     A.ADD -> PlusA
  1802:   | A.SUB -> MinusA
  1803:   | A.MUL -> Mult
  1804:   | A.DIV -> Div
  1805:   | A.MOD -> Mod
  1806:   | A.BAND -> BAnd
  1807:   | A.BOR -> BOr
  1808:   | A.XOR -> BXor
  1809:   | A.SHL -> Shiftlt
  1810:   | A.SHR -> Shiftrt
  1811:   | A.EQ -> Eq
  1812:   | A.NE -> Ne
  1813:   | A.LT -> Lt
  1814:   | A.LE -> Le
  1815:   | A.GT -> Gt
  1816:   | A.GE -> Ge
  1817:   | _ -> E.s (error "convBinOp")
  1818: 
  1819: (**** PEEP-HOLE optimizations ***)
  1820: let afterConversion (c: chunk) : chunk =
  1821:   (* Now scan the statements and find Instr blocks *)
  1822:   let collapseCallCast = function
  1823:       Call(Some(Var vi, NoOffset), f, args, l),
  1824:       Set(destlv, CastE (newt, Lval(Var vi', NoOffset)), _)
  1825:       when (not vi.vglob &&
  1826:             String.length vi.vname >= 3 &&
  1827:             String.sub vi.vname 0 3 = "tmp" &&
  1828:             vi' == vi)
  1829:       -> Some [Call(Some destlv, f, args, l)]
  1830:     | _ -> None
  1831:   in
  1832:   (* First add in the postins *)
  1833:   let sl = pushPostIns c in
  1834:   peepHole2 collapseCallCast sl;
  1835:   { c with stmts = sl; postins = [] }
  1836: 
  1837: (***** Try to suggest a name for the anonymous structures *)
  1838: let suggestAnonName (nl: A.name list) =
  1839:   match nl with
  1840:     [] -> ""
  1841:   | (n, _, _, _) :: _ -> n
  1842: 
  1843: (****** TYPE SPECIFIERS *******)
  1844: let rec doSpecList (suggestedAnonName: string) (* This string will be part of
  1845:                                                 * the names for anonymous
  1846:                                                 * structures and enums  *)
  1847:                    (specs: A.spec_elem list)
  1848:        (* Returns the base type, the storage, whether it is inline and the
  1849:         * (unprocessed) attributes *)
  1850:     : typ * storage * bool * A.attribute list =
  1851:   (* Do one element and collect the type specifiers *)
  1852:   let isinline = ref false in (* If inline appears *)
  1853:   (* The storage is placed here *)
  1854:   let storage : storage ref = ref NoStorage in
  1855: 
  1856:   (* Collect the attributes.  Unfortunately, we cannot treat GCC
  1857:    * __attributes__ and ANSI C const/volatile the same way, since they
  1858:    * associate with structures differently.  Specifically, ANSI
  1859:    * qualifiers never apply to structures (ISO 6.7.3), whereas GCC
  1860:    * attributes always do (GCC manual 4.30).  Therefore, they are
  1861:    * collected and processed separately. *)
  1862:   let attrs : A.attribute list ref = ref [] in      (* __attribute__, etc. *)
  1863:   let cvattrs : A.cvspec list ref = ref [] in       (* const/volatile *)
  1864: 
  1865:   let doSpecElem (se: A.spec_elem)
  1866:                  (acc: A.typeSpecifier list)
  1867:                   : A.typeSpecifier list =
  1868:     match se with
  1869:       A.SpecTypedef -> acc
  1870:     | A.SpecInline -> isinline := true; acc
  1871:     | A.SpecStorage st ->
  1872:         if !storage <> NoStorage then
  1873:           E.s (error "Multiple storage specifiers");
  1874:         let sto' =
  1875:           match st with
  1876:             A.NO_STORAGE -> NoStorage
  1877:           | A.AUTO -> NoStorage
  1878:           | A.REGISTER -> Register
  1879:           | A.STATIC -> Static
  1880:           | A.EXTERN -> Extern
  1881:         in
  1882:         storage := sto';
  1883:         acc
  1884: 
  1885:     | A.SpecCV cv -> cvattrs := cv :: !cvattrs; acc
  1886:     | A.SpecAttr a -> attrs := a :: !attrs; acc
  1887:     | A.SpecType ts -> ts :: acc
  1888:     | A.SpecPattern _ -> E.s (E.bug "SpecPattern in cabs2cil input")
  1889:   in
  1890:   (* Now scan the list and collect the type specifiers. Preserve the order *)
  1891:   let tspecs = List.fold_right doSpecElem specs [] in
  1892: 
  1893:   let tspecs' =
  1894:     (* GCC allows a named type that appears first to be followed by things
  1895:      * like "short", "signed", "unsigned" or "long". *)
  1896:     match tspecs with
  1897:       A.Tnamed n :: (_ :: _ as rest) when not !msvcMode ->
  1898:         (* If rest contains "short" or "long" then drop the Tnamed *)
  1899:         if List.exists (function A.Tshort -> true
  1900:                                | A.Tlong -> true | _ -> false) rest then
  1901:           rest
  1902:         else
  1903:           tspecs
  1904: 
  1905:     | _ -> tspecs
  1906:   in
  1907:   (* Sort the type specifiers *)
  1908:   let sortedspecs =
  1909:     let order = function (* Don't change this *)
  1910:       | A.Tvoid -> 0
  1911:       | A.Tbool -> 0
  1912:       | A.Tsigned -> 1
  1913:       | A.Tunsigned -> 2
  1914:       | A.Tchar -> 3
  1915:       | A.Tshort -> 4
  1916:       | A.Tlong -> 5
  1917:       | A.Tint -> 6
  1918:       | A.Tint64 -> 7
  1919:       | A.Tfloat -> 8
  1920:       | A.Tdouble -> 9
  1921:       | A.Tcomplex -> 10
  1922:       | A.Timaginary -> 10
  1923:       | _ -> 11 (* There should be at most one of the others *)
  1924:     in
  1925:     (* Hopefully this is stable sort *)
  1926:     List.sort (fun ts1 ts2 -> compare (order ts1) (order ts2)) tspecs'
  1927:   in
  1928:   (* And now try to make sense of it. See ISO 6.7.2 *)
  1929:   let bt =
  1930:     match sortedspecs with
  1931:       [A.Tvoid] -> TVoid []
  1932:     | [A.Tchar] -> TInt(IChar, [])
  1933:     | [A.Tsigned; A.Tchar] -> TInt(ISChar, [])
  1934:     | [A.Tunsigned; A.Tchar] -> TInt(IUChar, [])
  1935: 
  1936:     | [A.Tshort] -> TInt(IShort, [])
  1937:     | [A.Tsigned; A.Tshort] -> TInt(IShort, [])
  1938:     | [A.Tshort; A.Tint] -> TInt(IShort, [])
  1939:     | [A.Tsigned; A.Tshort; A.Tint] -> TInt(IShort, [])
  1940: 
  1941:     | [A.Tunsigned; A.Tshort] -> TInt(IUShort, [])
  1942:     | [A.Tunsigned; A.Tshort; A.Tint] -> TInt(IUShort, [])
  1943: 
  1944:     | [] -> TInt(IInt, [])
  1945:     | [A.Tint] -> TInt(IInt, [])
  1946:     | [A.Tsigned] -> TInt(IInt, [])
  1947:     | [A.Tsigned; A.Tint] -> TInt(IInt, [])
  1948: 
  1949:     | [A.Tunsigned] -> TInt(IUInt, [])
  1950:     | [A.Tunsigned; A.Tint] -> TInt(IUInt, [])
  1951: 
  1952:     | [A.Tlong] -> TInt(ILong, [])
  1953:     | [A.Tsigned; A.Tlong] -> TInt(ILong, [])
  1954:     | [A.Tlong; A.Tint] -> TInt(ILong, [])
  1955:     | [A.Tsigned; A.Tlong; A.Tint] -> TInt(ILong, [])
  1956: 
  1957:     | [A.Tunsigned; A.Tlong] -> TInt(IULong, [])
  1958:     | [A.Tunsigned; A.Tlong; A.Tint] -> TInt(IULong, [])
  1959: 
  1960:     | [A.Tlong; A.Tlong] -> TInt(ILongLong, [])
  1961:     | [A.Tsigned; A.Tlong; A.Tlong] -> TInt(ILongLong, [])
  1962:     | [A.Tlong; A.Tlong; A.Tint] -> TInt(ILongLong, [])
  1963:     | [A.Tsigned; A.Tlong; A.Tlong; A.Tint] -> TInt(ILongLong, [])
  1964: 
  1965:     | [A.Tunsigned; A.Tlong; A.Tlong] -> TInt(IULongLong, [])
  1966:     | [A.Tunsigned; A.Tlong; A.Tlong; A.Tint] -> TInt(IULongLong, [])
  1967: 
  1968:     (* int64 is to support MSVC *)
  1969:     | [A.Tint64] -> TInt(ILongLong, [])
  1970:     | [A.Tsigned; A.Tint64] -> TInt(ILongLong, [])
  1971: 
  1972:     | [A.Tunsigned; A.Tint64] -> TInt(IULongLong, [])
  1973: 
  1974:     | [A.Tfloat] -> TFloat(FFloat, [])
  1975:     | [A.Tdouble] -> TFloat(FDouble, [])
  1976:     | [A.Tlong; A.Tdouble] -> TFloat(FLongDouble, [])
  1977: 
  1978: 
  1979:     | [A.Tcomplex] -> TFloat(CFloat, [])
  1980:     | [A.Tfloat; A.Tcomplex] -> TFloat(CFloat, [])
  1981:     | [A.Tdouble; A.Tcomplex] -> TFloat(CDouble, [])
  1982:     | [A.Tlong; A.Tdouble; A.Tcomplex] -> TFloat(CLongDouble, [])
  1983: 
  1984:     | [A.Timaginary] -> TFloat(IFloat, [])
  1985:     | [A.Tdouble; A.Timaginary] -> TFloat(IDouble, [])
  1986:     | [A.Tlong; A.Tdouble; A.Timaginary] -> TFloat(ILongDouble, [])
  1987: 
  1988:      (* Now the other type specifiers *)
  1989:     | [A.Tnamed n] -> begin
  1990:         if n = "__builtin_va_list" &&
  1991:           Flx_cil_machdep.gccHas__builtin_va_list then begin
  1992:             TBuiltin_va_list []
  1993:         end else
  1994:           let t =
  1995:             match lookupType "type" n with
  1996:               (TNamed _) as x, _ -> x
  1997:             | typ -> E.s (error "Named type %s is not mapped correctly\n" n)
  1998:           in
  1999:           t
  2000:     end
  2001: 
  2002:     | [A.Tstruct (n, None, _)] -> (* A reference to a struct *)
  2003:         if n = "" then E.s (error "Missing struct tag on incomplete struct");
  2004:         findCompType "struct" n []
  2005:     | [A.Tstruct (n, Some nglist, extraAttrs)] -> (* A definition of a struct *)
  2006:       let n' =
  2007:         if n <> "" then n else anonStructName "struct" suggestedAnonName in
  2008:       (* Use the (non-cv) attributes now *)
  2009:       let a = extraAttrs @ !attrs in
  2010:       attrs := [];
  2011:       makeCompType true n' nglist (doAttributes a)
  2012: 
  2013:     | [A.Tunion (n, None, _)] -> (* A reference to a union *)
  2014:         if n = "" then E.s (error "Missing union tag on incomplete union");
  2015:         findCompType "union" n []
  2016:     | [A.Tunion (n, Some nglist, extraAttrs)] -> (* A definition of a union *)
  2017:         let n' =
  2018:           if n <> "" then n else anonStructName "union" suggestedAnonName in
  2019:         (* Use the attributes now *)
  2020:         let a = extraAttrs @ !attrs in
  2021:         attrs := [];
  2022:         makeCompType false n' nglist (doAttributes a)
  2023: 
  2024:     | [A.Tenum (n, None, _)] -> (* Just a reference to an enum *)
  2025:         if n = "" then E.s (error "Missing enum tag on incomplete enum");
  2026:         findCompType "enum" n []
  2027: 
  2028:     | [A.Tenum (n, Some eil, extraAttrs)] -> (* A definition of an enum *)
  2029:         let n' =
  2030:           if n <> "" then n else anonStructName "enum" suggestedAnonName in
  2031:         (* make a new name for this enumeration *)
  2032:         let n'', _  = newAlphaName true "enum" n' in
  2033:         (* Create the enuminfo, or use one that was created already for a
  2034:          * forward reference *)
  2035:         (* Use the attributes now *)
  2036:         let a = extraAttrs @ !attrs in
  2037:         attrs := [];
  2038:         let enum, _ = createEnumInfo n'' in
  2039:         enum.eattr <- doAttributes a;
  2040:         let res = TEnum (enum, []) in
  2041: 
  2042:         (* sm: start a scope for the enum tag values, since they *
  2043:         * can refer to earlier tags *)
  2044:         enterScope ();
  2045: 
  2046:         (* as each name,value pair is determined, this is called *)
  2047:         let rec processName kname i loc rest = begin
  2048:           (* add the name to the environment, but with a faked 'typ' field;
  2049:            * we don't know the full type yet (since that includes all of the
  2050:            * tag values), but we won't need them in here  *)
  2051:           addLocalToEnv kname (EnvEnum (i, res));
  2052: 
  2053:           (* add this tag to the list so that it ends up in the real
  2054:           * environment when we're finished  *)
  2055:           let newname, _  = newAlphaName true "" kname in
  2056:           (kname, (newname, i, loc)) :: loop (increm i 1) rest
  2057:         end
  2058: 
  2059:         and loop i = function
  2060:             [] -> []
  2061:           | (kname, A.NOTHING, cloc) :: rest ->
  2062:               (* use the passed-in 'i' as the value, since none specified *)
  2063:               processName kname i (convLoc cloc) rest
  2064: 
  2065:           | (kname, e, cloc) :: rest ->
  2066:               (* constant-eval 'e' to determine tag value *)
  2067:               let i = match isIntConstExp e with
  2068:                   Some e' -> e'
  2069:                 | _ -> E.s (error "enum without const integer initializer")
  2070:               in
  2071:               processName kname i (convLoc cloc) rest
  2072:         in
  2073: 
  2074:         (* sm: now throw away the environment we built for eval'ing the enum
  2075:         * tags, so we can add to the new one properly  *)
  2076:         exitScope ();
  2077: 
  2078:         let fields = loop zero eil in
  2079:         (* Now set the right set of items *)
  2080:         enum.eitems <- List.map (fun (_, x) -> x) fields;
  2081:         (* Record the enum name in the environment *)
  2082:         addLocalToEnv (kindPlusName "enum" n'') (EnvTyp res);
  2083:         (* And define the tag *)
  2084:         cabsPushGlobal (GEnumTag (enum, !currentLoc));
  2085:         res
  2086: 
  2087: 
  2088:     | [A.TtypeofE e] ->
  2089:         (* We process e as AExpLeaveArrayfun to avoid conversion of arrays
  2090:         * and functions into pointers *)
  2091:         let (c, e', t) = doExp false e AExpLeaveArrayFun in
  2092:         let t' =
  2093:           match e' with
  2094:             StartOf(lv) -> typeOfLval lv
  2095:                 (* If this is a string literal, then we treat it as in sizeof*)
  2096:           | Const (CStr s) -> begin
  2097:               match typeOf e' with
  2098:                 TPtr(bt, _) -> (* This is the type of arary elements *)
  2099:                   TArray(bt, Some (SizeOfStr s), [])
  2100:               | _ -> E.s (bug "The typeOf a string is not a pointer type")
  2101:           end
  2102:           | _ -> t
  2103:         in
  2104: (*
  2105:         ignore (E.log "typeof(%a) = %a\n" d_exp e' d_plaintype t');
  2106: *)
  2107:         t'
  2108: 
  2109:     | [A.TtypeofT (specs, dt)] ->
  2110:         let typ = doOnlyType specs dt in
  2111:         typ
  2112: 
  2113:     | _ ->
  2114:         E.s (error "Invalid combination of type specifiers")
  2115:   in
  2116:   bt,!storage,!isinline,List.rev (!attrs @ (convertCVtoAttr !cvattrs))
  2117: 
  2118: (* given some cv attributes, convert them into named attributes for
  2119:  * uniform processing *)
  2120: and convertCVtoAttr (src: A.cvspec list) : A.attribute list =
  2121:   match src with
  2122:   | [] -> []
  2123:   | CV_CONST    :: tl -> ("const",[])    :: (convertCVtoAttr tl)
  2124:   | CV_VOLATILE :: tl -> ("volatile",[]) :: (convertCVtoAttr tl)
  2125:   | CV_RESTRICT :: tl -> ("restrict",[]) :: (convertCVtoAttr tl)
  2126: 
  2127: 
  2128: and makeVarInfoFlx_cil_cabs
  2129:                 ~(isformal: bool)
  2130:                 ~(isglobal: bool)
  2131:                 (ldecl : location)
  2132:                 (bt, sto, inline, attrs)
  2133:                 (n,ndt,a)
  2134:       : varinfo =
  2135:   let vtype, nattr =
  2136:     doType (AttrName false) bt (A.PARENTYPE(attrs, ndt, a)) in
  2137:   if inline && not (isFunctionType vtype) then
  2138:     ignore (error "inline for a non-function: %s" n);
  2139:   let t =
  2140:     if not isglobal && not isformal then begin
  2141:       (* Sometimes we call this on the formal argument of a function with no
  2142:        * arguments. Don't call stripConstLocalType in that case *)
  2143: (*      ignore (E.log "stripConstLocalType(%a) for %s\n" d_type vtype n); *)
  2144:       stripConstLocalType vtype
  2145:     end else
  2146:       vtype
  2147:   in
  2148:   let vi = makeVarinfo isglobal n t in
  2149:   vi.vstorage <- sto;
  2150:   vi.vattr <- nattr;
  2151:   vi.vdecl <- ldecl;
  2152:   (* ignore (E.log "Created local %s : %a\n" vi.vname d_type vi.vtype); *)
  2153:   vi
  2154: 
  2155: (* Process a local variable declaration and allow variable-sized arrays *)
  2156: and makeVarSizeVarInfo (ldecl : location)
  2157:                        spec_res
  2158:                        (n,ndt,a)
  2159:    : varinfo * chunk * exp * bool =
  2160:   if not !msvcMode then
  2161:     match isVariableSizedArray ndt with
  2162:       None ->
  2163:         makeVarInfoFlx_cil_cabs ~isformal:false
  2164:                         ~isglobal:false
  2165:                         ldecl spec_res (n,ndt,a), empty, zero, false
  2166:     | Some (ndt', se, len) ->
  2167:         makeVarInfoFlx_cil_cabs ~isformal:false
  2168:                         ~isglobal:false
  2169:                         ldecl spec_res (n,ndt',a), se, len, true
  2170:   else
  2171:     makeVarInfoFlx_cil_cabs ~isformal:false
  2172:                     ~isglobal:false
  2173:                     ldecl spec_res (n,ndt,a), empty, zero, false
  2174: 
  2175: and doAttr (a: A.attribute) : attribute list =
  2176:   (* Strip the leading and trailing underscore *)
  2177:   let stripUnderscore (n: string) : string =
  2178:     let l = String.length n in
  2179:     let rec start i =
  2180:       if i >= l then
  2181:         E.s (error "Invalid attribute name %s" n);
  2182:       if String.get n i = '_' then start (i + 1) else i
  2183:     in
  2184:     let st = start 0 in
  2185:     let rec finish i =
  2186:       (* We know that we will stop at >= st >= 0 *)
  2187:       if String.get n i = '_' then finish (i - 1) else i
  2188:     in
  2189:     let fin = finish (l - 1) in
  2190:     String.sub n st (fin - st + 1)
  2191:   in
  2192:   match a with
  2193: (*    ("restrict", []) -> [] *)
  2194:   | (s, []) -> [Attr (stripUnderscore s, [])]
  2195:   | (s, el) ->
  2196:       let rec attrOfExp (strip: bool) (a: A.expression) : attrparam =
  2197:         match a with
  2198:           A.VARIABLE n -> begin
  2199:             let n' = if strip then stripUnderscore n else n in
  2200:             (** See if this is an enumeration *)
  2201:             try
  2202:               match H.find env n' with
  2203:                 EnvEnum (tag, _), _ -> begin
  2204:                   match isInteger (constFold true tag) with
  2205:                     Some i64 -> AInt (Int64.to_int i64)
  2206:                   |  _ -> ACons(n', [])
  2207:                 end
  2208:               | _ -> ACons (n', [])
  2209:             with Not_found -> ACons(n', [])
  2210:           end
  2211:         | A.CONSTANT (A.CONST_STRING s) -> AStr s
  2212:         | A.CONSTANT (A.CONST_INT str) -> AInt (int_of_string str)
  2213:         | A.CALL(A.VARIABLE n, args) -> begin
  2214:             let n' = if strip then stripUnderscore n else n in
  2215:             let ae' = List.map ae args in
  2216:             ACons(n', ae')
  2217:         end
  2218:         | A.EXPR_SIZEOF e -> ASizeOfE (ae e)
  2219:         | A.TYPE_SIZEOF (bt, dt) -> ASizeOf (doOnlyType bt dt)
  2220:         | A.EXPR_ALIGNOF e -> AAlignOfE (ae e)
  2221:         | A.TYPE_ALIGNOF (bt, dt) -> AAlignOf (doOnlyType bt dt)
  2222:         | A.BINARY(A.AND, aa1, aa2) ->
  2223:             ABinOp(LAnd, ae aa1, ae aa2)
  2224:         | A.BINARY(A.OR, aa1, aa2) ->
  2225:             ABinOp(LOr, ae aa1, ae aa2)
  2226:         | A.BINARY(abop, aa1, aa2) ->
  2227:             ABinOp (convBinOp abop, ae aa1, ae aa2)
  2228:         | A.UNARY(A.PLUS, aa) -> ae aa
  2229:         | A.UNARY(A.MINUS, aa) -> AUnOp (Neg, ae aa)
  2230:         | A.UNARY(A.BNOT, aa) -> AUnOp(BNot, ae aa)
  2231:         | A.UNARY(A.NOT, aa) -> AUnOp(LNot, ae aa)
  2232:         | A.MEMBEROF (e, s) -> ADot (ae e, s)
  2233:         | _ ->
  2234:             ignore (E.log "Invalid expression in attribute: ");
  2235:             withFlx_cil_cprint Flx_cil_cprint.print_expression a;
  2236:             E.s (error "cabs2cil: invalid expression")
  2237: 
  2238:       and ae (e: A.expression) = attrOfExp false e
  2239:       in
  2240:       (* Sometimes we need to convert attrarg into attr *)
  2241:       let arg2attr = function
  2242:         | ACons (s, args) -> Attr (s, args)
  2243:         | a ->
  2244:             E.s (error "Invalid form of attribute: %a"
  2245:                    d_attrparam a);
  2246:       in
  2247:       if s = "__attribute__" then (* Just a wrapper for many attributes*)
  2248:         List.map (fun e -> arg2attr (attrOfExp true e)) el
  2249:       else if s = "__blockattribute__" then (* Another wrapper *)
  2250:         List.map (fun e -> arg2attr (attrOfExp true e)) el
  2251:       else if s = "__declspec" then
  2252:         List.map (fun e -> arg2attr (attrOfExp false e)) el
  2253:       else
  2254:         [Attr(stripUnderscore s, List.map (attrOfExp false) el)]
  2255: 
  2256: and doAttributes (al: A.attribute list) : attribute list =
  2257:   List.fold_left (fun acc a -> cabsAddAttributes (doAttr a) acc) [] al
  2258: 
  2259: 
  2260: 
  2261: and doType (nameortype: attributeClass) (* This is AttrName if we are doing
  2262:                                          * the type for a name, or AttrType
  2263:                                          * if we are doing this type in a
  2264:                                          * typedef *)
  2265:            (bt: typ)                    (* The base type *)
  2266:            (dt: A.decl_type)
  2267:   (* Returns the new type and the accumulated name (or type attribute
  2268:     if nameoftype =  AttrType) attributes *)
  2269:   : typ * attribute list =
  2270: 
  2271:   (* Now do the declarator type. But remember that the structure of the
  2272:    * declarator type is as printed, meaning that it is the reverse of the
  2273:    * right one *)
  2274:   let rec doDeclType (bt: typ) (acc: attribute list) = function
  2275:       A.JUSTBASE -> bt, acc
  2276:     | A.PARENTYPE (a1, d, a2) ->
  2277:         let a1' = doAttributes a1 in
  2278:         let a1n, a1f, a1t = partitionAttributes AttrType a1' in
  2279:         let a2' = doAttributes a2 in
  2280:         let a2n, a2f, a2t = partitionAttributes nameortype a2' in
  2281:         let bt' = cabsTypeAddAttributes a1t bt in
  2282:         let bt'', a1fadded =
  2283:           match unrollType bt with
  2284:             TFun _ -> cabsTypeAddAttributes a1f bt', true
  2285:           | _ -> bt', false
  2286:         in
  2287:         (* Now recurse *)
  2288:         let restyp, nattr = doDeclType bt'' acc d in
  2289:         (* Add some more type attributes *)
  2290:         let restyp = cabsTypeAddAttributes a2t restyp in
  2291:         (* See if we can add some more type attributes *)
  2292:         let restyp' =
  2293:           match unrollType restyp with
  2294:             TFun _ ->
  2295:               if a1fadded then
  2296:                 cabsTypeAddAttributes a2f restyp
  2297:               else
  2298:                 cabsTypeAddAttributes a2f
  2299:                   (cabsTypeAddAttributes a1f restyp)
  2300:           | TPtr ((TFun _ as tf), ap) when not !msvcMode ->
  2301:               if a1fadded then
  2302:                 TPtr(cabsTypeAddAttributes a2f tf, ap)
  2303:               else
  2304:                 TPtr(cabsTypeAddAttributes a2f
  2305:                        (cabsTypeAddAttributes a1f tf), ap)
  2306:           | _ ->
  2307:               if a1f <> [] && not a1fadded then
  2308:                 E.s (error "Invalid position for (prefix) function type attributes:%a"
  2309:                        d_attrlist a1f);
  2310:               if a2f <> [] then
  2311:                 E.s (error "Invalid position for (post) function type attributes:%a"
  2312:                        d_attrlist a2f);
  2313:               restyp
  2314:         in
  2315:         (* Now add the name attributes and return *)
  2316:         restyp', cabsAddAttributes a1n (cabsAddAttributes a2n nattr)
  2317: 
  2318:     | A.PTR (al, d) ->
  2319:         let al' = doAttributes al in
  2320:         let an, af, at = partitionAttributes AttrType al' in
  2321:         (* Now recurse *)
  2322:         let restyp, nattr = doDeclType (TPtr(bt, at)) acc d in
  2323:         (* See if we can do anything with function type attributes *)
  2324:         let restyp' =
  2325:           match unrollType restyp with
  2326:             TFun _ -> cabsTypeAddAttributes af restyp
  2327:           | TPtr((TFun _ as tf), ap) ->
  2328:               TPtr(cabsTypeAddAttributes af tf, ap)
  2329:           | _ ->
  2330:               if af <> [] then
  2331:                 E.s (error "Invalid position for function type attributes:%a"
  2332:                        d_attrlist af);
  2333:               restyp
  2334:         in
  2335:         (* Now add the name attributes and return *)
  2336:         restyp', cabsAddAttributes an nattr
  2337: 
  2338: 
  2339:     | A.ARRAY (d, al, len) ->
  2340:         let lo =
  2341:           (* JMS:
  2342:           Cil fails on sizeof() in constants .. we don't
  2343:           actually care so just make all arrays unknown length
  2344:           None
  2345:           *)
  2346:           match len with
  2347:             A.NOTHING -> None
  2348:           | _ ->
  2349:               let len' = doPureExp len in
  2350:               let _, len'' = castTo (typeOf len') intType len' in
  2351:               Some len''
  2352:         in
  2353:         let al' = doAttributes al in
  2354:         doDeclType (TArray(bt, lo, al')) acc d
  2355: 
  2356:     | A.PROTO (d, args, isva) ->
  2357:         (* Start a scope for the parameter names *)
  2358:         enterScope ();
  2359:         (* Intercept the old-style use of varargs.h. On GCC this means that
  2360:          * we have ellipsis and a last argument "builtin_va_alist:
  2361:          * builtin_va_alist_t". On MSVC we do not have the ellipsis and we
  2362:          * have a last argument "va_alist: va_list" *)
  2363:         let args', isva' =
  2364:           if args != [] && !msvcMode = not isva then begin
  2365:             let newisva = ref isva in
  2366:             let rec doLast = function
  2367:                 [([A.SpecType (A.Tnamed atn)], (an, A.JUSTBASE, [], _))]
  2368:                   when isOldStyleVarArgTypeName atn &&
  2369:                        isOldStyleVarArgName an -> begin
  2370:                          (* Turn it into a vararg *)
  2371:                          newisva := true;
  2372:                          (* And forget about this argument *)
  2373:                          []
  2374:                        end
  2375: 
  2376:               | a :: rest -> a :: doLast rest
  2377:               | [] -> []
  2378:             in
  2379:             let args' = doLast args in
  2380:             (args', !newisva)
  2381:           end else (args, isva)
  2382:         in
  2383:         (* Make the argument as for a formal *)
  2384:         let doOneArg (s, (n, ndt, a, cloc)) : varinfo =
  2385:           let s' = doSpecList n s in
  2386:           makeVarInfoFlx_cil_cabs ~isformal:true ~isglobal:false (convLoc cloc) s' (n,ndt,a)
  2387:         in
  2388:         let targs : varinfo list option =
  2389:           match List.map doOneArg args'  with
  2390:           | [] -> None (* No argument list *)
  2391:           | [t] when (match t.vtype with TVoid _ -> true | _ -> false) ->
  2392:               Some []
  2393:           | l -> Some l
  2394:         in
  2395:         exitScope ();
  2396:         (* Turn [] types into pointers in the arguments and the result type.
  2397:          * Turn function types into pointers to respective. This simplifies
  2398:          * our life a lot, and is what the standard requires. *)
  2399:         let rec fixupArgumentTypes (argidx: int) (args: varinfo list) : unit =
  2400:           match args with
  2401:             [] -> ()
  2402:           | a :: args' ->
  2403:               (match unrollType a.vtype with
  2404:                 TArray(t,_,attr) -> a.vtype <- TPtr(t, attr)
  2405:               | TFun _ -> a.vtype <- TPtr(a.vtype, [])
  2406:               | TComp (comp, _) as t -> begin
  2407:                   match isTransparentUnion a.vtype with
  2408:                     None ->  ()
  2409:                   | Some fstfield ->
  2410:                       transparentUnionArgs :=
  2411:                          (argidx, a.vtype) :: !transparentUnionArgs;
  2412:                       a.vtype <- fstfield.ftype;
  2413:               end
  2414:               | _ -> ());
  2415:               fixupArgumentTypes (argidx + 1) args'
  2416:         in
  2417:         let args =
  2418:           match targs with
  2419:             None -> None
  2420:           | Some argl ->
  2421:               fixupArgumentTypes 0 argl;
  2422:               Some (List.map (fun a -> (a.vname, a.vtype, a.vattr)) argl)
  2423:         in
  2424:         let tres =
  2425:           match unrollType bt with
  2426:             TArray(t,_,attr) -> TPtr(t, attr)
  2427:           | _ -> bt
  2428:         in
  2429:         doDeclType (TFun (tres, args, isva', [])) acc d
  2430: 
  2431:   in
  2432:   doDeclType bt [] dt
  2433: 
  2434: (* If this is a declarator for a variable size array then turn it into a
  2435:    pointer type and a length *)
  2436: and isVariableSizedArray (dt: A.decl_type)
  2437:     : (A.decl_type * chunk * exp) option =
  2438:   let res = ref None in
  2439:   let rec findArray = function
  2440:     ARRAY (JUSTBASE, al, lo) when lo != A.NOTHING ->
  2441:       (* Allow non-constant expressions *)
  2442:       let (se, e', _) = doExp false lo (AExp (Some intType)) in
  2443:       if isNotEmpty se || not (isConstant e') then begin
  2444:         res := Some (se, e');
  2445:         PTR (al, JUSTBASE)
  2446:       end else
  2447:         ARRAY (JUSTBASE, al, lo)
  2448:     | ARRAY (dt, al, lo) -> ARRAY (findArray dt, al, lo)
  2449:     | PTR (al, dt) -> PTR (al, findArray dt)
  2450:     | JUSTBASE -> JUSTBASE
  2451:     | PARENTYPE (prea, dt, posta) -> PARENTYPE (prea, findArray dt, posta)
  2452:     | PROTO (dt, f, a) -> PROTO (findArray dt, f, a)
  2453:   in
  2454:   let dt' = findArray dt in
  2455:   match !res with
  2456:     None -> None
  2457:   | Some (se, e) -> Some (dt', se, e)
  2458: 
  2459: and doOnlyType (specs: A.spec_elem list) (dt: A.decl_type) : typ =
  2460:   let bt',sto,inl,attrs = doSpecList "" specs in
  2461:   if sto <> NoStorage || inl then
  2462:     E.s (error "Storage or inline specifier in type only");
  2463:   let tres, nattr = doType AttrType bt' (A.PARENTYPE(attrs, dt, [])) in
  2464:   if nattr <> [] then
  2465:     E.s (error "Name attributes in only_type: %a"
  2466:            d_attrlist nattr);
  2467:   tres
  2468: 
  2469: 
  2470: and makeCompType (isstruct: bool)
  2471:                  (n: string)
  2472:                  (nglist: A.field_group list)
  2473:                  (a: attribute list) =
  2474:   (* Make a new name for the structure *)
  2475:   let kind = if isstruct then "struct" else "union" in
  2476:   let n', _  = newAlphaName true kind n in
  2477:   (* Create the self cell for use in fields and forward references. Or maybe
  2478:    * one exists already from a forward reference  *)
  2479:   let comp, _ = createCompInfo isstruct n' in
  2480:   let doFieldGroup ((s: A.spec_elem list),
  2481:                     (nl: (A.name * A.expression option) list)) : 'a list =
  2482:     (* Do the specifiers exactly once *)
  2483:     let sugg = match nl with
  2484:       [] -> ""
  2485:     | ((n, _, _, _), _) :: _ -> n
  2486:     in
  2487:     let bt, sto, inl, attrs = doSpecList sugg s in
  2488:     (* Do the fields *)
  2489:     let makeFieldInfo
  2490:         (((n,ndt,a,cloc) : A.name), (widtho : A.expression option))
  2491:       : fieldinfo =
  2492:       if sto <> NoStorage && sto <> Static || inl then
  2493:         E.s (error "Non-static Storage or inline not allowed for fields");
  2494:       let ftype, nattr =
  2495:         doType (AttrName false) bt (A.PARENTYPE(attrs, ndt, a)) in
  2496:       let width =
  2497:         match widtho with
  2498:           None -> None
  2499:         | Some w -> begin
  2500:             (match unrollType ftype with
  2501:               TInt (ikind, a) -> ()
  2502:             | TEnum _ -> ()
  2503:             | _ -> E.s (error "Base type for bitfield is not an integer type"));
  2504:             match isIntegerConstant w with
  2505:                 Some n -> Some n
  2506:               | None -> E.s (error "bitfield width is not an integer constant")
  2507:           end
  2508:       in
  2509:       (* If the field is unnamed and its type is a structure of union type
  2510:        * then give it a distinguished name  *)
  2511:       let n' =
  2512:         if n = missingFieldName then begin
  2513:           match unrollType ftype with
  2514:             TComp _ -> begin
  2515:               incr annonCompFieldNameId;
  2516:               annonCompFieldName ^ (string_of_int !annonCompFieldNameId)
  2517:             end
  2518:           | _ -> n
  2519:         end else
  2520:           n
  2521:       in
  2522:       { fcomp     =  comp;
  2523:         fname     =  n';
  2524:         ftype     =  ftype;
  2525:         fbitfield =  width;
  2526:         fattr     =  nattr;
  2527:         floc      =  convLoc cloc;
  2528:         fstorage  = sto
  2529:       }
  2530:     in
  2531:     List.map makeFieldInfo nl
  2532:   in
  2533: 
  2534: 
  2535:   let flds = List.concat (List.map doFieldGroup nglist) in
  2536:   if comp.cfields <> [] then begin
  2537:     (* This appears to be a multiply defined structure. This can happen from
  2538:     * a construct like "typedef struct foo { ... } A, B;". This is dangerous
  2539:     * because at the time B is processed some forward references in { ... }
  2540:     * appear as backward references, which coild lead to circularity in
  2541:     * the type structure. We do a thourough check and then we reuse the type
  2542:     * for A *)
  2543:     let fieldsSig fs = List.map (fun f -> typeSig f.ftype) fs in
  2544:     if fieldsSig comp.cfields <> fieldsSig flds then
  2545:       ignore (error "%s seems to be multiply defined" (compFullName comp))
  2546:   end else
  2547:     comp.cfields <- flds;
  2548: 
  2549: (*  ignore (E.log "makeComp: %s: %a\n" comp.cname d_attrlist a); *)
  2550:   comp.cattr <- a;
  2551:   let toplevel_typedef = false in
  2552:   let res = TComp (comp, []) in
  2553:   (* This compinfo is defined, even if there are no fields *)
  2554:   comp.cdefined <- true;
  2555:   (* Create a typedef for this one *)
  2556:   cabsPushGlobal (GCompTag (comp, !currentLoc));
  2557: 
  2558:       (* There must be a self cell created for this already *)
  2559:   addLocalToEnv (kindPlusName kind n) (EnvTyp res);
  2560:   (* Now create a typedef with just this type *)
  2561:   res
  2562: 
  2563: and preprocessCast (specs: A.specifier)
  2564:                    (dt: A.decl_type)
  2565:                    (ie: A.init_expression)
  2566:   : A.specifier * A.decl_type * A.init_expression =
  2567:   let typ = doOnlyType specs dt in
  2568:   (* If we are casting to a union type then we have to treat this as a
  2569:    * constructor expression. This is to handle the gcc extension that allows
  2570:    * cast from a type of a field to the type of the union  *)
  2571:   let ie' =
  2572:     match unrollType typ, ie with
  2573:       TComp (c, _), A.SINGLE_INIT _ when not c.cstruct ->
  2574:         A.COMPOUND_INIT [(A.INFIELD_INIT ("___matching_field",
  2575:                                           A.NEXT_INIT),
  2576:                           ie)]
  2577:     | _, _ -> ie
  2578:   in
  2579:   (* Maybe specs contains an unnamed composite. Replace with the name so that
  2580:    * when we do again the specs we get the right name  *)
  2581:   let specs1 =
  2582:     match typ with
  2583:       TComp (ci, _) ->
  2584:         List.map
  2585:           (function
  2586:               A.SpecType (A.Tstruct ("", flds, [])) ->
  2587:                 A.SpecType (A.Tstruct (ci.cname, None, []))
  2588:             | A.SpecType (A.Tunion ("", flds, [])) ->
  2589:                 A.SpecType (A.Tunion (ci.cname, None, []))
  2590:             | s -> s) specs
  2591:     | _ -> specs
  2592:   in
  2593:   specs1, dt, ie'
  2594: 
  2595: and isIntConstExp (aexp) : exp option =
  2596:   match doExp true aexp (AExp None) with
  2597:     (* first, filter for those Const exps that are integers *)
  2598:     | (c, (Const (CInt64 (i,_,_)) as p),_) when isEmpty c ->
  2599:         Some p
  2600:     | (c, (Const (CChr i) as p),_) when isEmpty c ->
  2601:         Some p
  2602:     (* other Const expressions are not ok *)
  2603:     | (_, (Const _), _) ->
  2604:         None
  2605:     (* now, anything else that 'doExp true' returned is ok (provided
  2606:        that it didn't yield side effects); this includes, in particular,
  2607:        the various sizeof and alignof expression kinds *)
  2608:     | (c, e, _) when isEmpty c ->
  2609:         Some e
  2610:     (* we only get here when the expression had side effects *)
  2611:     | _ ->
  2612:         None
  2613: 
  2614: (* this is like 'isIntConstExp', but retrieves the actual integer
  2615:  * the expression denotes; I have not extended it to work with
  2616:  * sizeof/alignof since (for CCured) we can't const-eval those,
  2617:  * and it's not clear whether they can be bitfield width specifiers
  2618:  * anyway (since that's where this function is used) *)
  2619: and isIntegerConstant (aexp) : int option =
  2620:   match doExp true aexp (AExp None) with
  2621:       (c, (Const (CInt64 (i,_,_)) as p),_) when isEmpty c ->
  2622:         Some (Int64.to_int i)
  2623:     | (c, (Const (CChr i) as p),_) when isEmpty c ->
  2624:         Some (Char.code i)
  2625:     | _ -> None
  2626: 
  2627:      (* Process an expression and in the process do some type checking,
  2628:       * extract the effects as separate statements  *)
  2629: and doExp (isconst: bool)    (* In a constant *)
  2630:           (e: A.expression)
  2631:           (what: expAction) : (chunk * exp * typ) =
  2632:   (* A subexpression of array type is automatically turned into StartOf(e).
  2633:    * Similarly an expression of function type is turned into AddrOf. So
  2634:    * essentially doExp should never return things of type TFun or TArray *)
  2635:   let processArrayFun e t =
  2636:     match e, unrollType t with
  2637:       (Lval(lv) | CastE(_, Lval lv)), TArray(tbase, _, a) ->
  2638:         mkStartOfAndMark lv, TPtr(tbase, a)
  2639:     | (Lval(lv) | CastE(_, Lval lv)), TFun _  ->
  2640:         mkAddrOfAndMark lv, TPtr(t, [])
  2641:     | _, (TArray _ | TFun _) ->
  2642:         E.s (error "Array or function expression is not lval: %a@!"
  2643:                d_plainexp e)
  2644:     | _ -> e, t
  2645:   in
  2646:   (* Before we return we call finishExp *)
  2647:   let finishExp ?(newWhat=what)
  2648:                 (se: chunk) (e: exp) (t: typ) : chunk * exp * typ =
  2649:     match newWhat with
  2650:       ADrop -> (se, e, t)
  2651:     | AExpLeaveArrayFun ->
  2652:         (se, e, t) (* It is important that we do not do "processArrayFun" in
  2653:                     * this case. We exploit this when we process the typeOf
  2654:                     * construct *)
  2655:     | AExp _ ->
  2656:         let (e', t') = processArrayFun e t in
  2657:         (se, e', t')
  2658: 
  2659:     | ASet (lv, lvt) -> begin
  2660:         (* See if the set was done already *)
  2661:         match e with
  2662:           Lval(lv') when lv == lv' ->
  2663:             (se, e, t)
  2664:         | _ ->
  2665:             let (e', t') = processArrayFun e t in
  2666:             let (t'', e'') = castTo t' lvt e' in
  2667: (*
  2668:             ignore (E.log "finishExp: e = %a\n  e'' = %a\n" d_plainexp e d_plainexp e'');
  2669: *)
  2670:             (se +++ (Set(lv, e'', !currentLoc)), e'', t'')
  2671:     end
  2672:   in
  2673:   let rec findField (n: string) (fidlist: fieldinfo list) : offset * typ =
  2674:     (* Depth first search for the field. This appears to be what GCC does.
  2675:      * MSVC checks that there are no ambiguous field names, so it does not
  2676:      * matter how we search *)
  2677:     let rec search = function
  2678:         [] -> NoOffset, voidType (* Did not find *)
  2679:       | fid :: rest when fid.fname = n -> Field(fid, NoOffset), fid.ftype
  2680:       | fid :: rest when prefix annonCompFieldName fid.fname -> begin
  2681:           match unrollType fid.ftype with
  2682:             TComp (ci, _) ->
  2683:               let off, t = search ci.cfields in
  2684:               if off = NoOffset then
  2685:                 search rest  (* Continue searching *)
  2686:               else
  2687:                 Field (fid, off), t
  2688:           | _ -> E.s (bug "unnamed field type is not a struct/union")
  2689:       end
  2690:       | _ :: rest -> search rest
  2691:     in
  2692:     let off, t = search fidlist in
  2693:     if off = NoOffset then
  2694:       E.s (error "Cannot find field %s" n);
  2695:     off, t
  2696:   in
  2697:   try
  2698:     match e with
  2699:     | A.NOTHING when what = ADrop -> finishExp empty (integer 0) intType
  2700:     | A.NOTHING ->
  2701:         let res = Const(CStr "exp_nothing") in
  2702:         finishExp empty res (typeOf res)
  2703: 
  2704:     (* Do the potential lvalues first *)
  2705:     | A.VARIABLE n -> begin
  2706:         (* Look up in the environment *)
  2707:         try
  2708:           let envdata = H.find env n in
  2709:           match envdata with
  2710:             EnvVar vi, _ ->
  2711:               if isconst &&
  2712:                  not (isFunctionType vi.vtype) &&
  2713:                  not (isArrayType vi.vtype)then
  2714:                 E.s (error "variable appears in constant");
  2715:               finishExp empty (Lval(var vi)) vi.vtype
  2716:           | EnvEnum (tag, typ), _ ->
  2717:               finishExp empty tag typ
  2718:           | _ -> raise Not_found
  2719:         with Not_found -> begin
  2720:           if isOldStyleVarArgName n then
  2721:             E.s (error "Cannot resolve variable %s. This could be a CIL bug due to the handling of old-style variable argument functions.\n" n)
  2722:           else
  2723:             E.s (error "Cannot resolve variable %s.\n" n)
  2724:         end
  2725:     end
  2726:     | A.INDEX (e1, e2) -> begin
  2727:         (* Recall that doExp turns arrays into StartOf pointers *)
  2728:         let (se1, e1', t1) = doExp false e1 (AExp None) in
  2729:         let (se2, e2', t2) = doExp false e2 (AExp None) in
  2730:         let se = se1 @@ se2 in
  2731:         let (e1'', t1, e2'', tresult) =
  2732:           (* Either e1 or e2 can be the pointer *)
  2733:           match unrollType t1, unrollType t2 with
  2734:             TPtr(t1e,_), (TInt _|TEnum _) -> e1', t1, e2', t1e
  2735:           | (TInt _|TEnum _), TPtr(t2e,_) -> e2', t2, e1', t2e
  2736:           | _ ->
  2737:               E.s (error
  2738:                      "Expecting a pointer type in index:@! t1=%a@!t2=%a@!"
  2739:                      d_plaintype t1 d_plaintype t2)
  2740:         in
  2741:         (* We have to distinguish the construction based on the type of e1'' *)
  2742:         let res =
  2743:           match e1'' with
  2744:             StartOf array -> (* A real array indexing operation *)
  2745:               addOffsetLval (Index(e2'', NoOffset)) array
  2746:           | _ -> (* Turn into *(e1 + e2) *)
  2747:               mkMem (BinOp(IndexPI, e1'', e2'', t1)) NoOffset
  2748:         in
  2749:         (* Do some optimization of StartOf *)
  2750:         finishExp se (Lval res) tresult
  2751: 
  2752:     end
  2753:     | A.UNARY (A.MEMOF, e) ->
  2754:         if isconst then
  2755:           E.s (error "MEMOF in constant");
  2756:         let (se, e', t) = doExp false e (AExp None) in
  2757:         let tresult =
  2758:           match unrollType t with
  2759:           | TPtr(te, _) -> te
  2760:           | _ -> E.s (error "Expecting a pointer type in *. Got %a@!"
  2761:                         d_plaintype t)
  2762:         in
  2763:         finishExp se
  2764:                   (Lval (mkMem e' NoOffset))
  2765:                   tresult
  2766: 
  2767:            (* e.str = (& e + off(str)). If e = (be + beoff) then e.str = (be
  2768:             * + beoff + off(str))  *)
  2769:     | A.MEMBEROF (e, str) ->
  2770:         (* member of is actually allowed if we only take the address *)
  2771:         (* if isconst then
  2772:           E.s (error "MEMBEROF in constant");  *)
  2773:         let (se, e', t') = doExp false e (AExp None) in
  2774:         let lv =
  2775:           match e' with
  2776:             Lval x -> x
  2777:           | CastE(_, Lval x) -> x
  2778:           | _ -> E.s (error "Expected an lval in MEMBEROF (field %s)" str)
  2779:         in
  2780:         let field_offset, field_type =
  2781:           match unrollType t' with
  2782:             TComp (comp, _) -> findField str comp.cfields
  2783:           | _ -> E.s (error "expecting a struct with field %s" str)
  2784:         in
  2785:         let lv' = Lval(addOffsetLval field_offset lv) in
  2786:         finishExp se lv' field_type
  2787: 
  2788:        (* e->str = * (e + off(str)) *)
  2789:     | A.MEMBEROFPTR (e, str) ->
  2790:         if isconst then
  2791:           E.s (error "MEMBEROFPTR in constant");
  2792:         let (se, e', t') = doExp false e (AExp None) in
  2793:         let pointedt =
  2794:           match unrollType t' with
  2795:             TPtr(t1, _) -> t1
  2796:           | TArray(t1,_,_) -> t1
  2797:           | _ -> E.s (error "expecting a pointer to a struct")
  2798:         in
  2799:         let field_offset, field_type =
  2800:           match unrollType pointedt with
  2801:             TComp (comp, _) -> findField str comp.cfields
  2802:           | x ->
  2803:               E.s (error
  2804:                      "expecting a struct with field %s. Found %a. t1 is %a"
  2805:                      str d_type x d_type t')
  2806:         in
  2807:         finishExp se (Lval (mkMem e' field_offset)) field_type
  2808: 
  2809: 
  2810:     | A.CONSTANT ct -> begin
  2811:         let hasSuffix str =
  2812:           let l = String.length str in
  2813:           fun s ->
  2814:             let ls = String.length s in
  2815:             l >= ls && s = String.uppercase (String.sub str (l - ls) ls)
  2816:         in
  2817:         match ct with
  2818:           A.CONST_INT str -> begin
  2819:             let res = parseInt str in
  2820:             finishExp empty res (typeOf res)
  2821:           end
  2822: 
  2823: (*
  2824:         | A.CONST_WSTRING wstr ->
  2825:             let len = List.length wstr in
  2826:             let wchar_t = !wcharType in
  2827:             (* We will make an array big enough to contain the wide
  2828:              * characters and the wide-null terminator *)
  2829:             let ws_t = TArray(wchar_t, Some (integer len), []) in
  2830:             let ws =
  2831:               makeGlobalVar ("wide_string" ^ string_of_int !lastStructId)
  2832:                 ws_t
  2833:             in
  2834:             ws.vstorage <- Static;
  2835:             incr lastStructId;
  2836:             (* Make the initializer. Idx is a wide_char index.  *)
  2837:             let rec loop (idx: int) (s: int64 list) =
  2838:               match s with
  2839:                 [] -> []
  2840:               | wc::rest ->
  2841:                   let wc_cilexp = Const (CInt64(wc, IInt, None)) in
  2842:                   (Index(integer idx, NoOffset),
  2843:                    SingleInit (mkCast wc_cilexp wchar_t))
  2844:                   :: loop (idx + 1) rest
  2845:             in
  2846:             (* Add the definition for the array *)
  2847:             cabsPushGlobal (GVar(ws,
  2848:                                  {init = Some (CompoundInit(ws_t,
  2849:                                                             loop 0 wstr))},
  2850:                                  !currentLoc));
  2851:             finishExp empty (StartOf(Var ws, NoOffset))
  2852:               (TPtr(wchar_t, []))
  2853:               *)
  2854: 
  2855:         | A.CONST_WSTRING (ws: int64 list) ->
  2856:             (* takes a list of strings, and converts it to a WIDE string. *)
  2857:             let intlist_to_wstring (str: int64 list) : string =
  2858:               (* L"\xabcd" "e" must to go
  2859:                  L"\xabcd\x65" and NOT L"\xabcde" *)
  2860:               let rec loop lst must_escape = match lst with
  2861:                 [] -> "" (* "\000" GN: nul-termination is implicit *)
  2862:               | hd :: tl ->
  2863:                 let must_escape_now = must_escape ||
  2864:                    (compare hd (Int64.of_int 255) > 0) ||
  2865:                    (compare hd Int64.zero < 0) in
  2866:                 let this_piece =
  2867:                   if must_escape_now then
  2868:                     Printf.sprintf "\\x%Lx" hd
  2869:                   else
  2870:                     String.make 1 (Char.chr (Int64.to_int hd))
  2871:                 in
  2872:                 this_piece ^ (loop tl must_escape_now)
  2873:               in loop str false
  2874:             in
  2875:             let res = Const(CWStr ((* intlist_to_wstring *) ws)) in
  2876:             finishExp empty res (typeOf res)
  2877: 
  2878:         | A.CONST_STRING s ->
  2879:             (* Maybe we burried __FUNCTION__ in there *)
  2880:             let s' =
  2881:               try
  2882:                 let start = String.index s (Char.chr 0) in
  2883:                 let l = String.length s in
  2884:                 let tofind = (String.make 1 (Char.chr 0)) ^ "__FUNCTION__" in
  2885:                 let past = start + String.length tofind in
  2886:                 if past <= l &&
  2887:                    String.sub s start (String.length tofind) = tofind then
  2888:                   (if start > 0 then String.sub s 0 start else "") ^
  2889:                   !currentFunctionFDEC.svar.vname ^
  2890:                   (if past < l then String.sub s past (l - past) else "")
  2891:                 else
  2892:                   s
  2893:               with Not_found -> s
  2894:             in
  2895:             let res = Const(CStr s') in
  2896:             finishExp empty res (typeOf res)
  2897: 
  2898:         | A.CONST_CHAR char_list ->
  2899:             let a, b = (interpret_character_constant char_list) in
  2900:             finishExp empty (Const a) b
  2901: 
  2902:         | A.CONST_WCHAR char_list ->
  2903:             let value = reduce_multichar !wcharType char_list in
  2904:             let result = kinteger64 !wcharKind value in
  2905:             finishExp empty result (typeOf result)
  2906: 
  2907:         | A.CONST_FLOAT str -> begin
  2908:             (* Maybe it ends in U or UL. Strip those *)
  2909:             let l = String.length str in
  2910:             let hasSuffix = hasSuffix str in
  2911:             let baseint, kind =
  2912:               if  hasSuffix "L" then
  2913:                 String.sub str 0 (l - 1), FLongDouble
  2914:               else if hasSuffix "F" then
  2915:                 String.sub str 0 (l - 1), FFloat
  2916:               else if hasSuffix "D" then
  2917:                 String.sub str 0 (l - 1), FDouble
  2918:               else
  2919:                 str, FDouble
  2920:             in
  2921:             try
  2922:               finishExp empty
  2923:                 (Const(CReal(float_of_string baseint, kind,
  2924:                              Some str)))
  2925:                 (TFloat(kind,[]))
  2926:             with e -> begin
  2927:               ignore (E.log "float_of_string %s (%s)\n" str
  2928:                         (Printexc.to_string e));
  2929:               let res = Const(CStr "booo CONS_FLOAT") in
  2930:               finishExp empty res (typeOf res)
  2931:             end
  2932:         end
  2933:     end
  2934: 
  2935:     | A.TYPE_SIZEOF (bt, dt) ->
  2936:         let typ = doOnlyType bt dt in
  2937:         finishExp empty (SizeOf(typ)) !typeOfSizeOf
  2938: 
  2939:       (* Intercept the sizeof("string") *)
  2940:     | A.EXPR_SIZEOF (A.CONSTANT (A.CONST_STRING s)) -> begin
  2941:         (* Process the string first *)
  2942:         match doExp isconst (A.CONSTANT (A.CONST_STRING s)) (AExp None) with
  2943:           _, Const(CStr s), _ ->
  2944:             finishExp empty (SizeOfStr s) !typeOfSizeOf
  2945:         | _ -> E.s (bug "cabs2cil: sizeOfStr")
  2946:     end
  2947: 
  2948:     | A.EXPR_SIZEOF e ->
  2949:         (* Allow non-constants in sizeof *)
  2950:         (* Do not convert arrays and functions into pointers *)
  2951:         let (se, e', t) = doExp false e AExpLeaveArrayFun in
  2952:         (* !!!! The book says that the expression is not evaluated, so we
  2953:            * drop the potential side-effects
  2954:         if isNotEmpty se then
  2955:           ignore (warn "Warning: Dropping side-effect in EXPR_SIZEOF\n");
  2956: *)
  2957:         let size =
  2958:           match e' with                 (* If we are taking the sizeof an
  2959:                                          * array we must drop the StartOf  *)
  2960:             StartOf(lv) -> SizeOfE (Lval(lv))
  2961: 
  2962:                 (* Maybe we are taking the sizeof for a CStr. In that case we
  2963:                  * mean the pointer to the start of the string *)
  2964:           | Const(CStr _) -> SizeOf (charPtrType)
  2965: 
  2966:                 (* Maybe we are taking the sizeof a variable-sized array *)
  2967:           | Lval (Var vi, NoOffset) -> begin
  2968:               try
  2969:                 H.find varSizeArrays vi.vid
  2970:               with Not_found -> SizeOfE e'
  2971:           end
  2972:           | _ -> SizeOfE e'
  2973:         in
  2974:         finishExp empty size !typeOfSizeOf
  2975: 
  2976:     | A.TYPE_ALIGNOF (bt, dt) ->
  2977:         let typ = doOnlyType bt dt in
  2978:         finishExp empty (AlignOf(typ)) !typeOfSizeOf
  2979: 
  2980:     | A.EXPR_ALIGNOF e ->
  2981:         let (se, e', t) = doExp false e AExpLeaveArrayFun in
  2982:         (* !!!! The book says that the expression is not evaluated, so we
  2983:            * drop the potential side-effects
  2984:         if isNotEmpty se then
  2985:           ignore (warn "Warning: Dropping side-effect in EXPR_ALIGNOF\n");
  2986: *)
  2987:         let e'' =
  2988:           match e' with                 (* If we are taking the alignof an
  2989:                                          * array we must drop the StartOf  *)
  2990:             StartOf(lv) -> Lval(lv)
  2991: 
  2992:           | _ -> e'
  2993:         in
  2994:         finishExp empty (AlignOfE(e'')) !typeOfSizeOf
  2995: 
  2996:     | A.CAST ((specs, dt), ie) ->
  2997:         let s', dt', ie' = preprocessCast specs dt ie in
  2998:         (* We know now that we can do s' and dt' many times *)
  2999:         let typ = doOnlyType s' dt' in
  3000:         let what' =
  3001:           match what with
  3002:             AExp (Some _) -> AExp (Some typ)
  3003:           | AExp None -> what
  3004:           | ADrop | AExpLeaveArrayFun -> what
  3005:           | ASet (lv, lvt) ->
  3006:               (* If the cast from typ to lvt would be dropped, then we
  3007:                * continue with a Set *)
  3008:               if false && typeSig typ = typeSig lvt then
  3009:                 what
  3010:               else
  3011:                 AExp None (* We'll create a temporary *)
  3012:         in
  3013:         (* Remember here if we have done the Set *)
  3014:         let (se, e', t') =
  3015:           match ie' with
  3016:             A.SINGLE_INIT e -> doExp isconst e what'
  3017: 
  3018:           | A.NO_INIT -> E.s (error "missing expression in cast")
  3019:           | A.COMPOUND_INIT _ -> begin
  3020:               (* Pretend that we are declaring and initializing a brand new
  3021:                * variable  *)
  3022:               let newvar = "__constr_expr_" ^ string_of_int (!constrExprId) in
  3023:               incr constrExprId;
  3024:               let spec_res = doSpecList "" s' in
  3025:               let se1 =
  3026:                 if !scopes == [] then begin
  3027:                   ignore (createGlobal spec_res
  3028:                             ((newvar, dt', [], cabslu), ie'));
  3029:                   empty
  3030:                 end else
  3031:                   createLocal spec_res ((newvar, dt', [], cabslu), ie')
  3032:               in
  3033:               (* Now pretend that e is just a reference to the newly created
  3034:                * variable *)
  3035:               let se, e', t' = doExp isconst (A.VARIABLE newvar) what' in
  3036:               (* If typ is an array then the doExp above has already added a
  3037:                * StartOf. We must undo that now so that it is done once by
  3038:                * the finishExp at the end of this case *)
  3039:               let e2, t2 =
  3040:                 match unrollType typ, e' with
  3041:                   TArray _, StartOf lv -> Lval lv, typ
  3042:                 | _, _ -> e', t'
  3043:               in
  3044:               se1 @@ se, e2, t2
  3045:           end
  3046:         in
  3047:         let (t'', e'') =
  3048:           match typ with
  3049:             TVoid _ when what' = ADrop -> (t', e') (* strange GNU thing *)
  3050:           |  _ ->
  3051:               (* Do this to check the cast *)
  3052:               let newtyp, newexp = castTo ~fromsource:true t' typ e' in
  3053:               newtyp, newexp
  3054:         in
  3055:         finishExp se e'' t''
  3056: 
  3057:     | A.UNARY(A.MINUS, e) ->
  3058:         let (se, e', t) = doExp isconst e (AExp None) in
  3059:         if isIntegralType t then
  3060:           let tres = integralPromotion t in
  3061:           let e'' =
  3062:             match e' with
  3063:             | Const(CInt64(i, ik, _)) -> kinteger64 ik (Int64.neg i)
  3064:             | _ -> UnOp(Neg, mkCastT e' t tres, tres)
  3065:           in
  3066:           finishExp se e'' tres
  3067:         else
  3068:           if isArithmeticType t then
  3069:             finishExp se (UnOp(Neg,e',t)) t
  3070:           else
  3071:             E.s (error "Unary - on a non-arithmetic type")
  3072: 
  3073:     | A.UNARY(A.BNOT, e) ->
  3074:         let (se, e', t) = doExp isconst e (AExp None) in
  3075:         if isIntegralType t then
  3076:           let tres = integralPromotion t in
  3077:           let e'' = UnOp(BNot, mkCastT e' t tres, tres) in
  3078:           finishExp se e'' tres
  3079:         else
  3080:           E.s (error "Unary ~ on a non-integral type")
  3081: 
  3082:     | A.UNARY(A.PLUS, e) -> doExp isconst e what
  3083: 
  3084: 
  3085:     | A.UNARY(A.ADDROF, e) -> begin
  3086:         match e with
  3087:           A.COMMA el -> (* GCC extension *)
  3088:             doExp false
  3089:               (A.COMMA (replaceLastInList el (fun e -> A.UNARY(A.ADDROF, e))))
  3090:               what
  3091:         | A.QUESTION (e1, e2, e3) -> (* GCC extension *)
  3092:             doExp false
  3093:               (A.QUESTION (e1, A.UNARY(A.ADDROF, e2), A.UNARY(A.ADDROF, e3)))
  3094:               what
  3095:         | A.VARIABLE s when
  3096:             isOldStyleVarArgName s
  3097:             && (match !currentFunctionFDEC.svar.vtype with
  3098:                    TFun(_, _, true, _) -> true | _ -> false) ->
  3099:             (* We are in an old-style variable argument function and we are
  3100:              * taking the address of the argument that was removed while
  3101:              * processing the function type. We compute the address based on
  3102:              * the address of the last real argument *)
  3103:             if !msvcMode then begin
  3104:               let rec getLast = function
  3105:                   [] -> E.s (unimp "old-style variable argument function without real arguments")
  3106:                 | [a] -> a
  3107:                 | _ :: rest -> getLast rest
  3108:               in
  3109:               let last = getLast !currentFunctionFDEC.sformals in
  3110:               let res = mkAddrOfAndMark (var last) in
  3111:               let tres = typeOf res in
  3112:               let tres', res' = castTo tres (TInt(IULong, [])) res in
  3113:               (* Now we must add to this address to point to the next
  3114:               * argument. Round up to a multiple of 4  *)
  3115:               let sizeOfLast =
  3116:                 (((bitsSizeOf last.vtype) + 31) / 32) * 4
  3117:               in
  3118:               let res'' =
  3119:                 BinOp(PlusA, res', kinteger IULong sizeOfLast, tres')
  3120:               in
  3121:               finishExp empty res'' tres'
  3122:             end else begin (* On GCC the only reliable way to do this is to
  3123:                           * call builtin_next_arg. If we take the address of
  3124:                           * a local we are going to get the address of a copy
  3125:                           * of the local ! *)
  3126: 
  3127:               doExp isconst
  3128:                 (A.CALL (A.VARIABLE "__builtin_next_arg",
  3129:                          [A.CONSTANT (A.CONST_INT "0")]))
  3130:                 what
  3131:             end
  3132: 
  3133:         | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *)
  3134:            A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ |
  3135:            A.CAST (_, A.COMPOUND_INIT _)) -> begin
  3136:             let (se, e', t) = doExp false e (AExp None) in
  3137:             (* ignore (E.log "ADDROF on %a : %a\n" d_plainexp e'
  3138:                       d_plaintype t); *)
  3139:             match e' with
  3140:              ( Lval x | CastE(_, Lval x)) ->
  3141:                finishExp se (mkAddrOfAndMark x) (TPtr(t, []))
  3142: 
  3143:             | StartOf (lv) ->
  3144:                 let tres = TPtr(typeOfLval lv, []) in (* pointer to array *)
  3145:                 finishExp se (mkAddrOfAndMark lv) tres
  3146: 
  3147:               (* Function names are converted into pointers to the function.
  3148:                * Taking the address-of again does not change things *)
  3149:             | AddrOf (Var v, NoOffset) when isFunctionType v.vtype ->
  3150:                 finishExp se e' t
  3151: 
  3152:             | _ -> E.s (error "Expected lval for ADDROF. Got %a@!"
  3153:                           d_plainexp e')
  3154:         end
  3155:         | _ -> E.s (error "Unexpected operand for addrof")
  3156:     end
  3157:     | A.UNARY((A.PREINCR|A.PREDECR) as uop, e) -> begin
  3158:         match e with
  3159:           A.COMMA el -> (* GCC extension *)
  3160:             doExp isconst
  3161:               (A.COMMA (replaceLastInList el
  3162:                           (fun e -> A.UNARY(uop, e))))
  3163:               what
  3164:         | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *)
  3165:             doExp isconst
  3166:               (A.QUESTION (e1, A.UNARY(uop, e2q),
  3167:                            A.UNARY(uop, e3q)))
  3168:               what
  3169: 
  3170:         | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *)
  3171:            A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ |
  3172:            A.CAST _ (* A GCC extension *)) -> begin
  3173:              let uop' = if uop = A.PREINCR then PlusA else MinusA in
  3174:              if isconst then
  3175:                E.s (error "PREINCR or PREDECR in constant");
  3176:              let (se, e', t) = doExp false e (AExp None) in
  3177:              let lv =
  3178:                match e' with
  3179:                  Lval x -> x
  3180:                | CastE (_, Lval x) -> x (* A GCC extension. The operation is
  3181:                                          * done at the cast type. The result
  3182:                                          * is also of the cast type *)
  3183:                | _ -> E.s (error "Expected lval for ++ or --")
  3184:              in
  3185:              let tresult, result = doBinOp uop' e' t one intType in
  3186:              finishExp (se +++ (Set(lv, mkCastT result tresult t,
  3187:                                     !currentLoc)))
  3188:                e'
  3189:                tresult   (* Should this be t instead ??? *)
  3190:            end
  3191:         | _ -> E.s (error "Unexpected operand for prefix -- or ++")
  3192:     end
  3193: 
  3194:     | A.UNARY((A.POSINCR|A.POSDECR) as uop, e) -> begin
  3195:         match e with
  3196:           A.COMMA el -> (* GCC extension *)
  3197:             doExp isconst
  3198:               (A.COMMA (replaceLastInList el
  3199:                           (fun e -> A.UNARY(uop, e))))
  3200:               what
  3201:         | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *)
  3202:             doExp isconst
  3203:               (A.QUESTION (e1, A.UNARY(uop, e2q), A.UNARY(uop, e3q)))
  3204:               what
  3205: 
  3206:         | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *)
  3207:            A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ |
  3208:            A.CAST _ (* A GCC extension *) ) -> begin
  3209:              if isconst then
  3210:                E.s (error "POSTINCR or POSTDECR in constant");
  3211:              (* If we do not drop the result then we must save the value *)
  3212:              let uop' = if uop = A.POSINCR then PlusA else MinusA in
  3213:              let (se, e', t) = doExp false e (AExp None) in
  3214:              let lv =
  3215:                match e' with
  3216:                  Lval x -> x
  3217:                | CastE (_, Lval x) -> x (* GCC extension. The addition must
  3218:                                          * be be done at the cast type. The
  3219:                                          * result of this is also of the cast
  3220:                                          * type *)
  3221:                | _ -> E.s (error "Expected lval for ++ or --")
  3222:              in
  3223:              let tresult, opresult = doBinOp uop' e' t one intType in
  3224:              let se', result =
  3225:                if what <> ADrop then
  3226:                  let tmp = newTempVar t in
  3227:                  se +++ (Set(var tmp, e', !currentLoc)), Lval(var tmp)
  3228:                else
  3229:                  se, e'
  3230:              in
  3231:              finishExp
  3232:                (se' +++ (Set(lv, mkCastT opresult tresult t,
  3233:                              !currentLoc)))
  3234:                result
  3235:                tresult   (* Should this be t instead ??? *)
  3236:            end
  3237:         | _ -> E.s (error "Unexpected operand for suffix ++ or --")
  3238:     end
  3239: 
  3240:     | A.BINARY(A.ASSIGN, e1, e2) -> begin
  3241:         match e1 with
  3242:           A.COMMA el -> (* GCC extension *)
  3243:             doExp isconst
  3244:               (A.COMMA (replaceLastInList el
  3245:                           (fun e -> A.BINARY(A.ASSIGN, e, e2))))
  3246:               what
  3247:         | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *)
  3248:             doExp isconst
  3249:               (A.QUESTION (e1, A.BINARY(A.ASSIGN, e2q, e2),
  3250:                            A.BINARY(A.ASSIGN, e3q, e2)))
  3251:               what
  3252:         | A.CAST (t, A.SINGLE_INIT e) -> (* GCC extension *)
  3253:             doExp isconst
  3254:               (A.CAST (t,
  3255:                        A.SINGLE_INIT (A.BINARY(A.ASSIGN, e,
  3256:                                                A.CAST (t, A.SINGLE_INIT e2)))))
  3257:               what
  3258: 
  3259:         | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *)
  3260:            A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ ) -> begin
  3261:              if isconst then E.s (error "ASSIGN in constant");
  3262:              let (se1, e1', lvt) = doExp false e1 (AExp None) in
  3263:              let lv =
  3264:                match e1' with
  3265:                  Lval x -> x
  3266:                | _ -> E.s (error "Expected lval for assignment. Got %a\n"
  3267:                              d_plainexp e1')
  3268:              in
  3269:              let (se2, e'', t'') = doExp false e2 (ASet(lv, lvt)) in
  3270:              finishExp (se1 @@ se2) e1' lvt
  3271:            end
  3272:         | _ -> E.s (error "Invalid left operand for ASSIGN")
  3273:     end
  3274: 
  3275:     | A.BINARY((A.ADD|A.SUB|A.MUL|A.DIV|A.MOD|A.BAND|A.BOR|A.XOR|
  3276:       A.SHL|A.SHR|A.EQ|A.NE|A.LT|A.GT|A.GE|A.LE) as bop, e1, e2) ->
  3277:         let bop' = convBinOp bop in
  3278:         let (se1, e1', t1) = doExp isconst e1 (AExp None) in
  3279:         let (se2, e2', t2) = doExp isconst e2 (AExp None) in
  3280:         let tresult, result = doBinOp bop' e1' t1 e2' t2 in
  3281:         finishExp (se1 @@ se2) result tresult
  3282: 
  3283:           (* assignment operators *)
  3284:     | A.BINARY((A.ADD_ASSIGN|A.SUB_ASSIGN|A.MUL_ASSIGN|A.DIV_ASSIGN|
  3285:       A.MOD_ASSIGN|A.BAND_ASSIGN|A.BOR_ASSIGN|A.SHL_ASSIGN|
  3286:       A.SHR_ASSIGN|A.XOR_ASSIGN) as bop, e1, e2) -> begin
  3287:         match e1 with
  3288:           A.COMMA el -> (* GCC extension *)
  3289:             doExp isconst
  3290:               (A.COMMA (replaceLastInList el
  3291:                           (fun e -> A.BINARY(bop, e, e2))))
  3292:               what
  3293:         | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *)
  3294:             doExp isconst
  3295:               (A.QUESTION (e1, A.BINARY(bop, e2q, e2),
  3296:                            A.BINARY(bop, e3q, e2)))
  3297:               what
  3298: 
  3299:         | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *)
  3300:            A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ |
  3301:            A.CAST _ (* GCC extension *) ) -> begin
  3302:              if isconst then
  3303:                E.s (error "op_ASSIGN in constant");
  3304:              let bop' = match bop with
  3305:                A.ADD_ASSIGN -> PlusA
  3306:              | A.SUB_ASSIGN -> MinusA
  3307:              | A.MUL_ASSIGN -> Mult
  3308:              | A.DIV_ASSIGN -> Div
  3309:              | A.MOD_ASSIGN -> Mod
  3310:              | A.BAND_ASSIGN -> BAnd
  3311:              | A.BOR_ASSIGN -> BOr
  3312:              | A.XOR_ASSIGN -> BXor
  3313:              | A.SHL_ASSIGN -> Shiftlt
  3314:              | A.SHR_ASSIGN -> Shiftrt
  3315:              | _ -> E.s (error "binary +=")
  3316:              in
  3317:              let (se1, e1', t1) = doExp false e1 (AExp None) in
  3318:              let lv1 =
  3319:                match e1' with
  3320:                  Lval x -> x
  3321:                | CastE (_, Lval x) -> x (* GCC extension. The operation and
  3322:                                          * the result are at the cast type  *)
  3323:                | _ -> E.s (error "Expected lval for assignment with arith")
  3324:              in
  3325:              let (se2, e2', t2) = doExp false e2 (AExp None) in
  3326:              let tresult, result = doBinOp bop' e1' t1 e2' t2 in
  3327:              (* We must cast the result to the type of the lv1, which may be
  3328:               * different than t1 if lv1 was a Cast *)
  3329:              let _, result' = castTo tresult (typeOfLval lv1) result in
  3330:              (* The type of the result is the type of the left-hand side  *)
  3331:              finishExp (se1 @@ se2 +++
  3332:                         (Set(lv1, result', !currentLoc)))
  3333:                e1'
  3334:                t1
  3335:            end
  3336:         | _ -> E.s (error "Unexpected left operand for assignment with arith")
  3337:       end
  3338: 
  3339: 
  3340:     | A.BINARY((A.AND|A.OR), _, _) | A.UNARY(A.NOT, _) -> begin
  3341:         let ce = doCondExp isconst e in
  3342:         (* We must normalize the result to 0 or 1 *)
  3343:         match ce with
  3344:           CEExp (se, ((Const _) as c)) ->
  3345:             finishExp se (if isZero c then zero else one) intType
  3346:         | CEExp (se, e) ->
  3347:             let e' =
  3348:               let te = typeOf e in
  3349:               let _, zte = castTo intType te zero in
  3350:               BinOp(Ne, e, zte, te)
  3351:             in
  3352:             finishExp se e' intType
  3353:         | _ ->
  3354:             let tmp = var (newTempVar intType) in
  3355:             finishExp (compileCondExp ce
  3356:                          (empty +++ (Set(tmp, integer 1,
  3357:                                          !currentLoc)))
  3358:                          (empty +++ (Set(tmp, integer 0,
  3359:                                          !currentLoc))))
  3360:               (Lval tmp)
  3361:               intType
  3362:     end
  3363: 
  3364:     | A.CALL(f, args) ->
  3365:         if isconst then
  3366:           E.s (error "CALL in constant");
  3367:         let (sf, f', ft') =
  3368:           match f with                  (* Treat the VARIABLE case separate
  3369:                                          * becase we might be calling a
  3370:                                          * function that does not have a
  3371:                                          * prototype. In that case assume it
  3372:                                          * takes INTs as arguments  *)
  3373:             A.VARIABLE n -> begin
  3374:               try
  3375:                 let vi, _ = lookupVar n in
  3376:                 (empty, Lval(var vi), vi.vtype) (* Found. Do not use
  3377:                                                  * finishExp. Simulate what =
  3378:                                                  * AExp None  *)
  3379:               with Not_found -> begin
  3380:                 ignore (warnOpt "Calling function %s without prototype." n);
  3381:                 let ftype = TFun(intType, None, false,
  3382:                                  [Attr("missingproto",[])]) in
  3383:                 (* Add a prototype to the environment *)
  3384:                 let proto, _ =
  3385:                   makeGlobalVarinfo false (makeGlobalVar n ftype) in
  3386:                 (* Make it EXTERN *)
  3387:                 proto.vstorage <- Extern;
  3388:                 H.add noProtoFunctions proto.vid true;
  3389:                 (* Add it to the file as well *)
  3390:                 cabsPushGlobal (GVarDecl (proto, !currentLoc));
  3391:                 (empty, Lval(var proto), ftype)
  3392:               end
  3393:             end
  3394:           | _ -> doExp false f (AExp None)
  3395:         in
  3396:         (* Get the result type and the argument types *)
  3397:         let (resType, argTypes, isvar, f'') =
  3398:           match unrollType ft' with
  3399:             TFun(rt,at,isvar,a) -> (rt,at,isvar,f')
  3400:           | TPtr (t, _) -> begin
  3401:               match unrollType t with
  3402:                 TFun(rt,at,isvar,a) -> (* Make the function pointer
  3403:                                             * explicit  *)
  3404:                   let f'' =
  3405:                     match f' with
  3406:                       AddrOf lv -> Lval(lv)
  3407:                     | _ -> Lval(mkMem f' NoOffset)
  3408:                   in
  3409:                   (rt,at,isvar, f'')
  3410:               | x ->
  3411:                   E.s (error "Unexpected type of the called function %a: %a"
  3412:                          d_exp f' d_type x)
  3413:           end
  3414:           | x ->  E.s (error "Unexpected type of the called function %a: %a"
  3415:                          d_exp f' d_type x)
  3416:         in
  3417:         let argTypesList = argsToList argTypes in
  3418:         (* Drop certain qualifiers from the result type *)
  3419:         let resType' = resType in
  3420:         (* Before we do the arguments we try to intercept a few builtins. For
  3421:          * these we have defined then with a different type, so we do not
  3422:          * want to give warnings. *)
  3423:         let isVarArgBuiltin =
  3424:           match f'' with
  3425:             Lval (Var fv, NoOffset) ->
  3426:               fv.vname = "__builtin_stdarg_start" ||
  3427:               fv.vname = "__builtin_va_arg" ||
  3428:               fv.vname = "__builtin_next_arg"
  3429:             | _ -> false
  3430:         in
  3431: 
  3432:         (* Do the arguments. In REVERSE order !!! Both GCC and MSVC do this *)
  3433:         let rec loopArgs
  3434:             : (string * typ * attributes) list * A.expression list
  3435:           -> (chunk * exp list) = function
  3436:             | ([], []) -> (empty, [])
  3437: 
  3438:             | args, [] ->
  3439:                 if not isVarArgBuiltin then
  3440:                   ignore (warnOpt
  3441:                             "Too few arguments in call to %a."
  3442:                             d_exp f');
  3443:                 (empty, [])
  3444: 
  3445:             | ((_, at, _) :: atypes, a :: args) ->
  3446:                 let (ss, args') = loopArgs (atypes, args) in
  3447:                 let (sa, a', att) = doExp false a (AExp (Some at)) in
  3448:                 let (at'', a'') = castTo att at a' in
  3449:                 (ss @@ sa, a'' :: args')
  3450: 
  3451:             | ([], args) -> (* No more types *)
  3452:                 if not isvar && argTypes != None && not isVarArgBuiltin then
  3453:                   (* Do not give a warning for functions without a prototype*)
  3454:                   ignore (warnOpt "Too many arguments in call to %a" d_exp f');
  3455:                 let rec loop = function
  3456:                     [] -> (empty, [])
  3457:                   | a :: args ->
  3458:                       let (ss, args') = loop args in
  3459:                       let (sa, a', at) = doExp false a (AExp None) in
  3460:                       (ss @@ sa, a' :: args')
  3461:                 in
  3462:                 loop args
  3463:         in
  3464:         let (sargs, args') = loopArgs (argTypesList, args) in
  3465:         let f3, what3, args3, is__builtin_va_arg =
  3466:           let rec dropCasts = function CastE (_, e) -> dropCasts e | e -> e in
  3467:           (* Get the name of the last formal *)
  3468:           let getNameLastFormal () : string =
  3469:             match !currentFunctionFDEC.svar.vtype with
  3470:               TFun(_, Some args, true, _) -> begin
  3471:                 match List.rev args with
  3472:                   (last_par_name, _, _) :: _ -> last_par_name
  3473:                 | _ -> ""
  3474:               end
  3475:             | _ -> ""
  3476:           in
  3477:           match f'' with
  3478:             Lval(Var fv, NoOffset) -> begin
  3479:               if fv.vname = "__builtin_va_arg" then begin
  3480:                 match args' with
  3481:                   marker :: SizeOf resTyp :: _ -> begin
  3482:                     (* Make a variable of the desired type *)
  3483:                     let destlv, destlvtyp =
  3484:                       match what with
  3485:                         ASet (lv, lvt) -> lv, lvt
  3486:                       | _ -> var (newTempVar resTyp), resTyp
  3487:                     in
  3488:                     f'',
  3489:                     ASet (destlv, destlvtyp),
  3490:                     [marker; SizeOf resTyp; AddrOf destlv],
  3491:                     true
  3492:                   end
  3493:                 | _ ->
  3494:                     ignore (warn "Invalid call to %s\n" fv.vname);
  3495:                     f'',what, args', false
  3496:               end else if fv.vname = "__builtin_stdarg_start" then begin
  3497:                 match args' with
  3498:                   marker :: last :: [] -> begin
  3499:                     let isOk =
  3500:                       match dropCasts last with
  3501:                         Lval (Var lastv, NoOffset) ->
  3502:                           lastv.vname = getNameLastFormal ()
  3503:                       | _ -> false
  3504:                     in
  3505:                     if not isOk then
  3506:                       ignore (warn "The second argument in call to %s should be the last formal argument\n" fv.vname);
  3507: 
  3508:                     (* Flx_cil_check that "lastv" is indeed the last variable in the
  3509:                      * prototype and then drop it *)
  3510:                     f'', what, [marker], false
  3511:                   end
  3512:                 | _ ->
  3513:                     ignore (warn "Invalid call to %s\n" fv.vname);
  3514:                     f'',what, args', false
  3515: 
  3516:               (* We have to turn uses of __builtin_varargs_start into uses
  3517:                * of __builtin_stdarg_start (because we have dropped the
  3518:                * __builtin_va_alist argument from this function *)
  3519: 
  3520:               end else if fv.vname = "__builtin_varargs_start" then begin
  3521:                 (* Lookup the prototype for the replacement *)
  3522:                 let v, _  =
  3523:                   try lookupGlobalVar "__builtin_stdarg_start"
  3524:                   with Not_found -> E.s (bug "Cannot find __builtin_stdarg_start to replace %s\n" fv.vname)
  3525:                 in
  3526:                 Lval (var v),
  3527:                 what,
  3528:                 args',
  3529:                 false
  3530: 
  3531:               end else if fv.vname = "__builtin_next_arg" then begin
  3532:                 match args' with
  3533:                   last :: [] -> begin
  3534:                     let isOk =
  3535:                       match dropCasts last with
  3536:                         Lval (Var lastv, NoOffset) ->
  3537:                           lastv.vname = getNameLastFormal ()
  3538:                       | _ -> false
  3539:                     in
  3540:                     if not isOk then
  3541:                       ignore (warn "The argument in call to %s should be the last formal argument\n" fv.vname);
  3542: 
  3543:                     f'', what, [ ], false
  3544:                   end
  3545:                 | _ ->
  3546:                     ignore (warn "Invalid call to %s\n" fv.vname);
  3547:                     f'',what, args', false
  3548:               end else
  3549:                 f'', what, args', false
  3550:             end
  3551:           | _ -> f'',what, args', false
  3552:         in
  3553:         begin
  3554:           match what3 with
  3555:             ADrop ->
  3556:               finishExp
  3557:                 (sf @@ sargs +++ (Call(None,f3,args3, !currentLoc)))
  3558:                 (integer 0) intType
  3559:               (* Set to a variable of corresponding type *)
  3560:           | ASet(lv, vtype) ->
  3561:               (* Make an exception here for __builtin_va_arg *)
  3562:               if is__builtin_va_arg then
  3563:                 finishExp
  3564:                   (sf @@ sargs
  3565:                            +++ (Call(None,f3,args3, !currentLoc)))
  3566:                   (Lval(lv))
  3567:                   vtype
  3568:               else
  3569:                 finishExp
  3570:                   (sf @@ sargs
  3571:                            +++ (Call(Some lv,f3,args3, !currentLoc)))
  3572:                   (Lval(lv))
  3573:                   vtype
  3574: 
  3575:           | _ -> begin
  3576:               (* Must create a temporary *)
  3577:               match f3, args3 with     (* Some constant folding *)
  3578:                 Lval(Var fv, NoOffset), [Const _]
  3579:                   when fv.vname = "__builtin_constant_p" ->
  3580:                     finishExp (sf @@ sargs) (integer 1) intType
  3581:               | _ ->
  3582:                   let tmp, restyp' =
  3583:                     match what3 with
  3584:                       AExp (Some t) -> newTempVar t, t
  3585:                     | _ -> newTempVar resType', resType'
  3586:                   in
  3587:                   let i = Call(Some (var tmp),f3,args3, !currentLoc) in
  3588:                   finishExp (sf @@ sargs +++ i) (Lval(var tmp)) restyp'
  3589:           end
  3590:         end
  3591: 
  3592:     | A.COMMA el ->
  3593:         if isconst then
  3594:           E.s (error "COMMA in constant");
  3595:         let rec loop sofar = function
  3596:             [e] ->
  3597:               let (se, e', t') = doExp false e what in (* Pass on the action *)
  3598:               (sofar @@ se, e', t')
  3599: (*
  3600:               finishExp (sofar @@ se) e' t' (* does not hurt to do it twice.
  3601:                                              * GN: it seems it does *)
  3602: *)
  3603:           | e :: rest ->
  3604:               let (se, _, _) = doExp false e ADrop in
  3605:               loop (sofar @@ se) rest
  3606:           | [] -> E.s (error "empty COMMA expression")
  3607:         in
  3608:         loop empty el
  3609: 
  3610:     | A.QUESTION (e1,e2,e3) when what = ADrop ->
  3611:         if isconst then
  3612:           E.s (error "QUESTION with ADrop in constant");
  3613:         let (se3,_,_) = doExp false e3 ADrop in
  3614:         let se2 =
  3615:           match e2 with
  3616:             A.NOTHING -> skipChunk
  3617:           | _ -> let (se2,_,_) = doExp false e2 ADrop in se2
  3618:         in
  3619:         finishExp (doCondition isconst e1 se2 se3) zero intType
  3620: 
  3621:     | A.QUESTION (e1, e2, e3) -> begin (* what is not ADrop *)
  3622:         (* Compile the conditional expression *)
  3623:         let ce1 = doCondExp isconst e1 in
  3624:         (* Now we must find the type of both branches, in order to compute
  3625:          * the type of the result *)
  3626:         let se2, e2'o (* is an option. None means use e1 *), t2 =
  3627:           match e2 with
  3628:             A.NOTHING -> begin (* The same as the type of e1 *)
  3629:               match ce1 with
  3630:                 CEExp (_, e1') -> empty, None, typeOf e1' (* Do not promote
  3631:                                                              to bool *)
  3632:               | _ -> empty, None, intType
  3633:             end
  3634:           | _ ->
  3635:               let se2, e2', t2 = doExp isconst e2 (AExp None) in
  3636:               se2, Some e2', t2
  3637:         in
  3638:         (* Do e3 for real *)
  3639:         let se3, e3', t3 = doExp isconst e3 (AExp None) in
  3640:         (* Compute the type of the result *)
  3641:         let tresult = conditionalConversion t2 t3 in
  3642:         match ce1 with
  3643:           CEExp (se1, Const(CInt64(i, _, _)))
  3644:            when i = Int64.zero && canDrop se2 ->
  3645:              finishExp (se1 @@ se3) (snd (castTo t3 tresult e3')) tresult
  3646:         | CEExp (se1, (Const(CInt64(i, _, _)) as e1'))
  3647:            when i <> Int64.zero && canDrop se3 -> begin
  3648:              match e2'o with
  3649:                None -> (* use e1' *)
  3650:                  finishExp (se1 @@ se2) (snd (castTo t2 tresult e1')) tresult
  3651:              | Some e2' ->
  3652:                  finishExp (se1 @@ se2) (snd (castTo t2 tresult e2')) tresult
  3653:            end
  3654: 
  3655:         | _ -> (* Use a conditional *) begin
  3656:             match e2 with
  3657:               A.NOTHING ->
  3658:                 let tmp = var (newTempVar tresult) in
  3659:                 let (se1, _, _) = doExp isconst e1 (ASet(tmp, tresult)) in
  3660:                 let (se3, _, _) = doExp isconst e3 (ASet(tmp, tresult)) in
  3661:                 finishExp (se1 @@ ifChunk (Lval(tmp)) lu
  3662:                                     skipChunk se3)
  3663:                   (Lval(tmp))
  3664:                   tresult
  3665:             | _ ->
  3666:                 let lv, lvt =
  3667:                   match what with
  3668:                   | ASet (lv, lvt) -> lv, lvt
  3669:                   | _ ->
  3670:                       let tmp = newTempVar tresult in
  3671:                       var tmp, tresult
  3672:                 in
  3673:                 (* Now do e2 and e3 for real *)
  3674:                 let (se2, _, _) = doExp isconst e2 (ASet(lv, lvt)) in
  3675:                 let (se3, _, _) = doExp isconst e3 (ASet(lv, lvt)) in
  3676:                 finishExp (doCondition isconst e1 se2 se3) (Lval(lv)) tresult
  3677:         end
  3678: 
  3679: (*
  3680:         (* Do these only to collect the types  *)
  3681:         let se2, e2', t2' =
  3682:           match e2 with
  3683:             A.NOTHING -> (* A GNU thing. Use e1 as e2 *)
  3684:               doExp isconst e1 (AExp None)
  3685:           | _ -> doExp isconst e2 (AExp None) in
  3686:         (* Do e3 for real *)
  3687:         let se3, e3', t3' = doExp isconst e3 (AExp None) in
  3688:         (* Compute the type of the result *)
  3689:         let tresult = conditionalConversion e2' t2' e3' t3' in
  3690:         if     (isEmpty se2 || e2 = A.NOTHING)
  3691:             && isEmpty se3 && isconst then begin
  3692:           (* Use the Question. This allows Question in initializers without
  3693:           * having to do constant folding  *)
  3694:           let se1, e1', t1 = doExp isconst e1 (AExp None) in
  3695:           ignore (checkBool t1 e1');
  3696:           let e2'' =
  3697:             if e2 = A.NOTHING then
  3698:               mkCastT e1' t1 tresult
  3699:             else mkCastT e2' t2' tresult (* We know se2 is empty *)
  3700:           in
  3701:           let e3'' = mkCastT e3' t3' tresult in
  3702:           let resexp =
  3703:             match e1' with
  3704:               Const(CInt64(i, _, _)) when i <> Int64.zero -> e2''
  3705:             | Const(CInt64(z, _, _)) when z = Int64.zero -> e3''
  3706:             | _ -> Question(e1', e2'', e3'')
  3707:           in
  3708:           finishExp se1 resexp tresult
  3709:         end else begin (* Now use a conditional *)
  3710:           match e2 with
  3711:             A.NOTHING ->
  3712:               let tmp = var (newTempVar tresult) in
  3713:               let (se1, _, _) = doExp isconst e1 (ASet(tmp, tresult)) in
  3714:               let (se3, _, _) = doExp isconst e3 (ASet(tmp, tresult)) in
  3715:               finishExp (se1 @@ ifChunk (Lval(tmp)) lu
  3716:                                   skipChunk se3)
  3717:                 (Lval(tmp))
  3718:                 tresult
  3719:           | _ ->
  3720:               let lv, lvt =
  3721:                 match what with
  3722:                 | ASet (lv, lvt) -> lv, lvt
  3723:                 | _ ->
  3724:                     let tmp = newTempVar tresult in
  3725:                     var tmp, tresult
  3726:               in
  3727:               (* Now do e2 and e3 for real *)
  3728:               let (se2, _, _) = doExp isconst e2 (ASet(lv, lvt)) in
  3729:               let (se3, _, _) = doExp isconst e3 (ASet(lv, lvt)) in
  3730:               finishExp (doCondition isconst e1 se2 se3) (Lval(lv)) tresult
  3731:         end
  3732: *)
  3733:     end
  3734: 
  3735:     | A.GNU_BODY b -> begin
  3736:         (* Find the last A.COMPUTATION and remember it. This one is invoked
  3737:          * on the reversed list of statements. *)
  3738:         let rec findLastComputation = function
  3739:             s :: _  ->
  3740:               let rec findLast = function
  3741:                   A.SEQUENCE (_, s, loc) -> findLast s
  3742:                 | CASE (_, s, _) -> findLast s
  3743:                 | CASERANGE (_, _, s, _) -> findLast s
  3744:                 | LABEL (_, s, _) -> findLast s
  3745:                 | (A.COMPUTATION _) as s -> s
  3746:                 | _ -> raise Not_found
  3747:               in
  3748:               findLast s
  3749:           | [] -> raise Not_found
  3750:         in
  3751:         (* Save the previous data *)
  3752:         let old_gnu = ! gnu_body_result in
  3753:         let lastComp, isvoidbody =
  3754:           match what with
  3755:             ADrop -> (* We are dropping the result *)
  3756:               A.NOP cabslu, true
  3757:           | _ ->
  3758:               try findLastComputation (List.rev b.A.bstmts), false
  3759:               with Not_found ->
  3760:                 E.s (error "Cannot find COMPUTATION in GNU.body")
  3761:                   (*                A.NOP cabslu, true *)
  3762:         in
  3763:         (* Prepare some data to be filled by doExp *)
  3764:         let data : (exp * typ) option ref = ref None in
  3765:         gnu_body_result := (lastComp, data);
  3766: 
  3767:         let se = doBody b in
  3768: 
  3769:         gnu_body_result := old_gnu;
  3770:         match !data with
  3771:           None when isvoidbody -> finishExp se zero voidType
  3772:         | None -> E.s (bug "Cannot find COMPUTATION in GNU.body")
  3773:         | Some (e, t) -> finishExp se e t
  3774:     end
  3775: 
  3776:     | A.LABELADDR l -> begin (* GCC's taking the address of a label *)
  3777:         let l = lookupLabel l in (* To support locallly declared labels *)
  3778:         let addrval =
  3779:           try H.find gotoTargetHash l
  3780:           with Not_found -> begin
  3781:             let res = !gotoTargetNextAddr in
  3782:             incr gotoTargetNextAddr;
  3783:             H.add gotoTargetHash l res;
  3784:             res
  3785:           end
  3786:         in
  3787:         finishExp empty (mkCast (integer addrval) voidPtrType) voidPtrType
  3788:     end
  3789: 
  3790:     | A.EXPR_PATTERN _ -> E.s (E.bug "EXPR_PATTERN in cabs2cil input")
  3791: 
  3792:   with e -> begin
  3793:     ignore (E.log "error in doExp (%s)@!" (Printexc.to_string e));
  3794:     (i2c (dInstr (dprintf "booo_exp(%t)" d_thisloc) !currentLoc),
  3795:      integer 0, intType)
  3796:   end
  3797: 
  3798: (* bop is always the arithmetic version. Change it to the appropriate pointer
  3799:  * version if necessary *)
  3800: and doBinOp (bop: binop) (e1: exp) (t1: typ) (e2: exp) (t2: typ) : typ * exp =
  3801:   let doArithmetic () =
  3802:     let tres = arithmeticConversion t1 t2 in
  3803:     (* Keep the operator since it is arithmetic *)
  3804:     tres,
  3805:     constFoldBinOp false bop (mkCastT e1 t1 tres) (mkCastT e2 t2 tres) tres
  3806:   in
  3807:   let doArithmeticComp () =
  3808:     let tres = arithmeticConversion t1 t2 in
  3809:     (* Keep the operator since it is arithemtic *)
  3810:     intType,
  3811:     constFoldBinOp false bop (mkCastT e1 t1 tres) (mkCastT e2 t2 tres) intType
  3812:   in
  3813:   let doIntegralArithmetic () =
  3814:     let tres = unrollType (arithmeticConversion t1 t2) in
  3815:     match tres with
  3816:       TInt _ ->
  3817:         tres,
  3818:         constFoldBinOp false bop (mkCastT e1 t1 tres) (mkCastT e2 t2 tres) tres
  3819:     | _ -> E.s (error "%a operator on a non-integer type" d_binop bop)
  3820:   in
  3821:   let pointerComparison e1 t1 e2 t2 =
  3822:     (* Cast both sides to an integer *)
  3823:     let commontype = !upointType in
  3824:     intType,
  3825:     constFoldBinOp false bop (mkCastT e1 t1 commontype)
  3826:       (mkCastT e2 t2 commontype) intType
  3827:   in
  3828: 
  3829:   match bop with
  3830:     (Mult|Div) -> doArithmetic ()
  3831:   | (Mod|BAnd|BOr|BXor) -> doIntegralArithmetic ()
  3832:   | (Shiftlt|Shiftrt) -> (* ISO 6.5.7. Only integral promotions. The result
  3833:                           * has the same type as the left hand side *)
  3834:       if !msvcMode then
  3835:         (* MSVC has a bug. We duplicate it here *)
  3836:         doIntegralArithmetic ()
  3837:       else
  3838:         let t1' = integralPromotion t1 in
  3839:         let t2' = integralPromotion t2 in
  3840:         t1',
  3841:         constFoldBinOp false bop (mkCastT e1 t1 t1') (mkCastT e2 t2 t2') t1'
  3842: 
  3843:   | (PlusA|MinusA)
  3844:       when isArithmeticType t1 && isArithmeticType t2 -> doArithmetic ()
  3845:   | (Eq|Ne|Lt|Le|Ge|Gt)
  3846:       when isArithmeticType t1 && isArithmeticType t2 ->
  3847:         doArithmeticComp ()
  3848:   | PlusA when isPointerType t1 && isIntegralType t2 ->
  3849:       t1,
  3850:       constFoldBinOp false PlusPI e1 (mkCastT e2 t2 (integralPromotion t2)) t1
  3851:   | PlusA when isIntegralType t1 && isPointerType t2 ->
  3852:       t2,
  3853:       constFoldBinOp false PlusPI e2 (mkCastT e1 t1 (integralPromotion t1)) t2
  3854:   | MinusA when isPointerType t1 && isIntegralType t2 ->
  3855:       t1,
  3856:       constFoldBinOp false MinusPI e1 (mkCastT e2 t2 (integralPromotion t2)) t1
  3857:   | MinusA when isPointerType t1 && isPointerType t2 ->
  3858:       let commontype = t1 in
  3859:       intType,
  3860:       constFoldBinOp false MinusPP (mkCastT e1 t1 commontype)
  3861:                                    (mkCastT e2 t2 commontype) intType
  3862:   | (Le|Lt|Ge|Gt|Eq|Ne) when isPointerType t1 && isPointerType t2 ->
  3863:       pointerComparison e1 t1 e2 t2
  3864:   | (Eq|Ne) when isPointerType t1 && isZero e2 ->
  3865:       pointerComparison e1 t1 (mkCastT zero intType t1) t1
  3866:   | (Eq|Ne) when isPointerType t2 && isZero e1 ->
  3867:       pointerComparison (mkCastT zero intType t2) t2 e2 t2
  3868: 
  3869: 
  3870:   | (Eq|Ne|Le|Lt|Ge|Gt) when isPointerType t1 && isArithmeticType t2 ->
  3871:       ignore (warnOpt "Comparison of pointer and non-pointer");
  3872:       (* Cast both values to upointType *)
  3873:       doBinOp bop (mkCastT e1 t1 !upointType) !upointType
  3874:                   (mkCastT e2 t2 !upointType) !upointType
  3875:   | (Eq|Ne|Le|Lt|Ge|Gt) when isArithmeticType t1 && isPointerType t2 ->
  3876:       ignore (warnOpt "Comparison of pointer and non-pointer");
  3877:       (* Cast both values to upointType *)
  3878:       doBinOp bop (mkCastT e1 t1 !upointType) !upointType
  3879:                   (mkCastT e2 t2 !upointType) !upointType
  3880: 
  3881:   | _ -> E.s (error "doBinOp: %a\n" d_plainexp (BinOp(bop,e1,e2,intType)))
  3882: 
  3883: (* Constant fold a conditional. This is because we want to avoid having
  3884:  * conditionals in the initializers. So, we try very hard to avoid creating
  3885:  * new statements. *)
  3886: and doCondExp (isconst: bool)
  3887:               (e: A.expression) : condExpRes =
  3888:   let rec addChunkBeforeCE (c0: chunk) = function
  3889:       CEExp (c, e) -> CEExp (c0 @@ c, e)
  3890:     | CEAnd (ce1, ce2) -> CEAnd (addChunkBeforeCE c0 ce1, ce2)
  3891:     | CEOr (ce1, ce2) -> CEOr (addChunkBeforeCE c0 ce1, ce2)
  3892:     | CENot ce1 -> CENot (addChunkBeforeCE c0 ce1)
  3893:   in
  3894:   let rec canDropCE = function
  3895:       CEExp (c, e) -> canDrop c
  3896:     | CEAnd (ce1, ce2) | CEOr (ce1, ce2) -> canDropCE ce1 && canDropCE ce2
  3897:     | CENot (ce1) -> canDropCE ce1
  3898:   in
  3899:   match e with
  3900:     A.BINARY (A.AND, e1, e2) -> begin
  3901:       let ce1 = doCondExp isconst e1 in
  3902:       let ce2 = doCondExp isconst e2 in
  3903:       match ce1, ce2 with
  3904:         CEExp (se1, (Const(CInt64 _) as ci1)), _ ->
  3905:           if not (isZero ci1) then
  3906:             addChunkBeforeCE se1 ce2
  3907:           else
  3908:             (* se2 might contain labels so we cannot drop it *)
  3909:             if canDropCE ce2 then
  3910:               ce1
  3911:             else
  3912:               CEAnd (ce1, ce2)
  3913:       | CEExp(se1, e1'), CEExp (se2, e2') when
  3914:               !useLogicalOperators && isEmpty se1 && isEmpty se2 ->
  3915:           CEExp (empty, BinOp(LAnd,
  3916:                               mkCast e1' intType,
  3917:                               mkCast e2' intType, intType))
  3918:       | _ -> CEAnd (ce1, ce2)
  3919:     end
  3920: 
  3921:   | A.BINARY (A.OR, e1, e2) -> begin
  3922:       let ce1 = doCondExp isconst e1 in
  3923:       let ce2 = doCondExp isconst e2 in
  3924:       match ce1, ce2 with
  3925:         CEExp (se1, (Const(CInt64 _) as ci1)), _ ->
  3926:           if isZero ci1 then
  3927:             addChunkBeforeCE se1 ce2
  3928:           else
  3929:             (* se2 might contain labels so we cannot drop it *)
  3930:             if canDropCE ce2 then
  3931:               ce1
  3932:             else
  3933:               CEOr (ce1, ce2)
  3934: 
  3935:       | CEExp (se1, e1'), CEExp (se2, e2') when
  3936:               !useLogicalOperators && isEmpty se1 && isEmpty se2 ->
  3937:           CEExp (empty, BinOp(LOr, mkCast e1' intType,
  3938:                               mkCast e2' intType, intType))
  3939:       | _ -> CEOr (ce1, ce2)
  3940:     end
  3941: 
  3942:   | A.UNARY(A.NOT, e1) -> begin
  3943:       match doCondExp isconst e1 with
  3944:         CEExp (se1, (Const(CInt64 _) as ci1)) ->
  3945:           if isZero ci1 then
  3946:             CEExp (se1, one)
  3947:           else
  3948:             CEExp (se1, zero)
  3949:       | CEExp (se1, e) when isEmpty se1 ->
  3950:           CEExp (empty, UnOp(LNot, mkCast e intType, intType))
  3951: 
  3952:       | ce1 -> CENot ce1
  3953:   end
  3954: 
  3955:   | _ ->
  3956:       let (se, e, t) as rese = doExp isconst e (AExp None) in
  3957:       ignore (checkBool t e);
  3958:       CEExp (se, constFold isconst e)
  3959: 
  3960: and compileCondExp (ce: condExpRes) (st: chunk) (sf: chunk) : chunk =
  3961:   match ce with
  3962:   | CEAnd (ce1, ce2) ->
  3963:       let (sf1, sf2) =
  3964:         (* If sf is small then will copy it *)
  3965:         try (sf, duplicateChunk sf)
  3966:         with Failure _ ->
  3967:           let lab = newLabelName "_L" in
  3968:           (gotoChunk lab lu, consLabel lab sf !currentLoc false)
  3969:       in
  3970:       let st' = compileCondExp ce2 st sf1 in
  3971:       let sf' = sf2 in
  3972:       compileCondExp ce1 st' sf'
  3973: 
  3974:   | CEOr (ce1, ce2) ->
  3975:       let (st1, st2) =
  3976:         (* If st is small then will copy it *)
  3977:         try (st, duplicateChunk st)
  3978:         with Failure _ ->
  3979:           let lab = newLabelName "_L" in
  3980:           (gotoChunk lab lu, consLabel lab st !currentLoc false)
  3981:       in
  3982:       let st' = st1 in
  3983:       let sf' = compileCondExp ce2 st2 sf in
  3984:       compileCondExp ce1 st' sf'
  3985: 
  3986:   | CENot ce1 -> compileCondExp ce1 sf st
  3987: 
  3988:   | CEExp (se, e) -> begin
  3989:       match e with
  3990:         Const(CInt64(i,_,_)) when i <> Int64.zero && canDrop sf -> se @@ st
  3991:       | Const(CInt64(z,_,_)) when z = Int64.zero && canDrop st -> se @@ sf
  3992:       | _ -> se @@ ifChunk e !currentLoc st sf
  3993:   end
  3994: 
  3995: 
  3996: (* A special case for conditionals *)
  3997: and doCondition (isconst: bool) (* If we are in constants, we do our best to
  3998:                                  * eliminate the conditional *)
  3999:                 (e: A.expression)
  4000:                 (st: chunk)
  4001:                 (sf: chunk) : chunk =
  4002:   compileCondExp (doCondExp isconst e) st sf
  4003: 
  4004: 
  4005: and doPureExp (e : A.expression) : exp =
  4006:   let (se, e', _) = doExp true e (AExp None) in
  4007:   if isNotEmpty se then
  4008:    E.s (error "doPureExp: not pure");
  4009:   e'
  4010: 
  4011: and doInitializer
  4012:     (vi: varinfo)
  4013:     (inite: A.init_expression)
  4014:    (* Return the accumulated chunk, the initializer and the new type (might be
  4015:     * different for arrays) *)
  4016:   : chunk * init * typ =
  4017: 
  4018:   (* Setup the pre-initializer *)
  4019:   let topPreInit = ref NoInitPre in
  4020:   if debugInit then
  4021:     ignore (E.log "\nStarting a new initializer for %s : %a\n"
  4022:               vi.vname d_type vi.vtype);
  4023:   let topSetupInit (o: offset) (e: exp) =
  4024:     if debugInit then
  4025:       ignore (E.log " set %a := %a\n"  d_lval (Var vi, o) d_exp e);
  4026:     let newinit = setOneInit !topPreInit o e in
  4027:     if newinit != !topPreInit then topPreInit := newinit
  4028:   in
  4029:   let acc, restl =
  4030:     let so = makeSubobj vi vi.vtype NoOffset in
  4031:     doInit vi.vglob topSetupInit so empty [ (A.NEXT_INIT, inite) ]
  4032:   in
  4033:   if restl <> [] then
  4034:     ignore (warn "Ignoring some initializers");
  4035:   (* sm: we used to do array-size fixups here, but they only worked
  4036:    * for toplevel array types; now, collectInitializer does the job,
  4037:    * including for nested array types *)
  4038:   let typ' = unrollType vi.vtype
  4039:   in
  4040:   if debugInit then
  4041:     ignore (E.log "Collecting the initializer for %s\n" vi.vname);
  4042:   let (init, typ'') = collectInitializer !topPreInit typ' in
  4043:   if debugInit then
  4044:     ignore (E.log "Finished the initializer for %s\n" vi.vname);
  4045:   acc, init, typ''
  4046: 
  4047: 
  4048: 
  4049: (* Consume some initializers. Watch out here. Make sure we use only
  4050:  * tail-recursion because these things can be big.  *)
  4051: and doInit
  4052:     (isconst: bool)
  4053:     (setone: offset -> exp -> unit) (* Use to announce an intializer *)
  4054:     (so: subobj)
  4055:     (acc: chunk)
  4056:     (initl: (A.initwhat * A.init_expression) list)
  4057: 
  4058:     (* Return the resulting chunk along with some unused initializers *)
  4059:   : chunk * (A.initwhat * A.init_expression) list =
  4060: 
  4061:   let whoami () = d_lval () (Var so.host, so.soOff) in
  4062: 
  4063:   let initl1 =
  4064:     match initl with
  4065:     | (A.NEXT_INIT,
  4066:        A.SINGLE_INIT (A.CAST ((s, dt), ie))) :: rest ->
  4067:          let s', dt', ie' = preprocessCast s dt ie in
  4068:          (A.NEXT_INIT, A.SINGLE_INIT (A.CAST ((s', dt'), ie'))) :: rest
  4069:     | _ -> initl
  4070:   in
  4071:       (* Sometimes we have a cast in front of a compound (in GCC). This
  4072:        * appears as a single initializer. Ignore the cast  *)
  4073:   let initl2 =
  4074:     match initl1 with
  4075:       (what,
  4076:        A.SINGLE_INIT (A.CAST (_, A.COMPOUND_INIT ci))) :: rest ->
  4077:          (what, A.COMPOUND_INIT ci) :: rest
  4078:     | _ -> initl1
  4079:   in
  4080:   let allinitl = initl2 in
  4081: 
  4082:   if debugInit then begin
  4083:     ignore (E.log "doInit for %t %s (current %a). Looking at: " whoami
  4084:               (if so.eof then "(eof)" else "")
  4085:               d_lval (Var so.host, so.curOff));
  4086:     (match allinitl with
  4087:       [] -> ignore (E.log "[]")
  4088:     | (what, ie) :: _ ->
  4089:         withFlx_cil_cprint
  4090:           Flx_cil_cprint.print_init_expression (A.COMPOUND_INIT [(what, ie)]));
  4091:     ignore (E.log "\n");
  4092:   end;
  4093:   match unrollType so.soTyp, allinitl with
  4094:     _, [] -> acc, [] (* No more initializers return *)
  4095: 
  4096:         (* No more subobjects *)
  4097:   | _, (A.NEXT_INIT, _) :: _ when so.eof -> acc, allinitl
  4098: 
  4099: 
  4100:         (* If we are at an array of characters and the initializer is a
  4101:          * string literal (optionally enclosed in braces) then explode the
  4102:          * string into characters *)
  4103:   | TArray(bt, leno, _),
  4104:       (A.NEXT_INIT,
  4105:        (A.SINGLE_INIT(A.CONSTANT (A.CONST_STRING s))|
  4106:        A.COMPOUND_INIT
  4107:          [(A.NEXT_INIT,
  4108:            A.SINGLE_INIT(A.CONSTANT
  4109:                            (A.CONST_STRING s)))])) :: restil
  4110:     when (match unrollType bt with
  4111:             TInt((IChar|IUChar|ISChar), _) -> true
  4112:           | TInt _ ->
  4113:               (*Base type is a scalar other than char. Maybe a wchar_t?*)
  4114:               E.s (error "Using a string literal to initialize something other than a character array.\n")
  4115:           | _ ->  false (* OK, this is probably an array of strings. Handle *)
  4116:          )              (* it with the other arrays below.*)
  4117:     ->
  4118:       let charinits =
  4119:         let init c = A.NEXT_INIT, A.SINGLE_INIT(A.CONSTANT (A.CONST_CHAR [c]))
  4120:         in
  4121:         let collector =
  4122:           (* ISO 6.7.8 para 14: final NUL added only if no size specified, or
  4123:            * if there is room for it; btw, we can't rely on zero-init of
  4124:            * globals, since this array might be a local variable *)
  4125:           if ((isNone leno) or ((String.length s) < (integerArrayLength leno)))
  4126:             then ref [init Int64.zero]
  4127:             else ref []
  4128:         in
  4129:         for pos = String.length s - 1 downto 0 do
  4130:           collector := init (Int64.of_int (Char.code (s.[pos]))) :: !collector
  4131:         done;
  4132:         !collector
  4133:       in
  4134:       (* Create a separate object for the array *)
  4135:       let so' = makeSubobj so.host so.soTyp so.soOff in
  4136:       (* Go inside the array *)
  4137:       let leno = integerArrayLength leno in
  4138:       so'.stack <- [InArray(so'.curOff, bt, leno, ref 0)];
  4139:       normalSubobj so';
  4140:       let acc', initl' = doInit isconst setone so' acc charinits in
  4141:       if initl' <> [] then
  4142:         ignore (warn "Too many initializers for character array %t" whoami);
  4143:       (* Advance past the array *)
  4144:       advanceSubobj so;
  4145:       (* Continue *)
  4146:       let res = doInit isconst setone so acc' restil in
  4147:       res
  4148: 
  4149:         (* If we are at an array of WIDE characters and the initializer is a
  4150:          * WIDE string literal (optionally enclosed in braces) then explore
  4151:          * the WIDE string into characters *)
  4152:   (* [weimer] Wed Jan 30 15:38:05 PST 2002
  4153:    * Despite what the compiler says, this match case is used and it is
  4154:    * important. *)
  4155:   | TArray(bt, leno, _),
  4156:       (A.NEXT_INIT,
  4157:        (A.SINGLE_INIT(A.CONSTANT (A.CONST_WSTRING s)) |
  4158:        A.COMPOUND_INIT
  4159:          [(A.NEXT_INIT,
  4160:            A.SINGLE_INIT(A.CONSTANT
  4161:                            (A.CONST_WSTRING s)))])) :: restil
  4162:     when(let bt' = unrollType bt in
  4163:          match bt' with
  4164:            (* compare bt to wchar_t, ignoring signed vs. unsigned *)
  4165:            TInt _ when (bitsSizeOf bt') = (bitsSizeOf !wcharType) -> true
  4166:          | TInt _ ->
  4167:               (*Base type is a scalar other than wchar_t.  Maybe a char?*)
  4168:               E.s (error "Using a wide string literal to initialize something other than a wchar_t array.\n")
  4169:          | _ -> false (* OK, this is probably an array of strings. Handle *)
  4170:         )             (* it with the other arrays below.*)
  4171:     ->
  4172:       let maxWChar =  (*  (2**(bitsSizeOf !wcharType)) - 1  *)
  4173:         Int64.sub (Int64.shift_left Int64.one (bitsSizeOf !wcharType))
  4174:           Int64.one in
  4175:       let charinits =
  4176:         let init c =
  4177:           if (compare c maxWChar > 0) then (* if c > maxWChar *)
  4178:             E.s (error "cab2cil:doInit:character 0x%Lx too big." c);
  4179:           A.NEXT_INIT,
  4180:           A.SINGLE_INIT(A.CONSTANT (A.CONST_INT (Int64.to_string c)))
  4181:         in
  4182:         (List.map init s) @
  4183:         (
  4184:           (* ISO 6.7.8 para 14: final NUL added only if no size specified, or
  4185:            * if there is room for it; btw, we can't rely on zero-init of
  4186:            * globals, since this array might be a local variable *)
  4187:           if ((isNone leno) or ((List.length s) < (integerArrayLength leno)))
  4188:             then [init Int64.zero]
  4189:             else [])
  4190: (*
  4191:         List.map
  4192:           (fun c ->
  4193:             if (compare c maxWChar > 0) then (* if c > maxWChar *)
  4194:               E.s (error "cab2cil:doInit:character 0x%Lx too big." c)
  4195:             else
  4196:               (A.NEXT_INIT,
  4197:                A.SINGLE_INIT(A.CONSTANT (A.CONST_INT (Int64.to_string c)))))
  4198:       s
  4199: *)
  4200:       in
  4201:       (* Create a separate object for the array *)
  4202:       let so' = makeSubobj so.host so.soTyp so.soOff in
  4203:       (* Go inside the array *)
  4204:       let leno = integerArrayLength leno in
  4205:       so'.stack <- [InArray(so'.curOff, bt, leno, ref 0)];
  4206:       normalSubobj so';
  4207:       let acc', initl' = doInit isconst setone so' acc charinits in
  4208:       if initl' <> [] then
  4209:         (* sm: see above regarding ISO 6.7.8 para 14, which is not implemented
  4210:          * for wchar_t because, as far as I can tell, we don't even put in
  4211:          * the automatic NUL (!) *)
  4212:         ignore (warn "Too many initializers for wchar_t array %t" whoami);
  4213:       (* Advance past the array *)
  4214:       advanceSubobj so;
  4215:       (* Continue *)
  4216:       doInit isconst setone so acc' restil
  4217: 
  4218:       (* If we are at an array and we see a single initializer then it must
  4219:        * be one for the first element *)
  4220:   | TArray(bt, leno, al), (A.NEXT_INIT, A.SINGLE_INIT oneinit) :: restil  ->
  4221:       (* Grab the length if there is one *)
  4222:       let leno = integerArrayLength leno in
  4223:       so.stack <- InArray(so.soOff, bt, leno, ref 0) :: so.stack;
  4224:       normalSubobj so;
  4225:       (* Start over with the fields *)
  4226:       doInit isconst setone so acc allinitl
  4227: 
  4228:     (* If we are at a composite and we see a single initializer of the same
  4229:      * type as the composite then grab it all. If the type is not the same
  4230:      * then we must go on and try to initialize the fields *)
  4231:   | TComp (comp, _), (A.NEXT_INIT, A.SINGLE_INIT oneinit) :: restil ->
  4232:       let se, oneinit', t' = doExp isconst oneinit (AExp None) in
  4233:       if (match unrollType t' with
  4234:              TComp (comp', _) when comp'.ckey = comp.ckey -> true
  4235:             | _ -> false)
  4236:       then begin
  4237:         (* Initialize the whole struct *)
  4238:         setone so.soOff oneinit';
  4239:         (* Advance to the next subobject *)
  4240:         advanceSubobj so;
  4241:         doInit isconst setone so (acc @@ se) restil
  4242:       end else begin (* Try to initialize fields *)
  4243:         let toinit = fieldsToInit comp None in
  4244:         so.stack <- InComp(so.soOff, comp, toinit) :: so.stack;
  4245:         normalSubobj so;
  4246:         doInit isconst setone so acc allinitl
  4247:       end
  4248: 
  4249:      (* A scalar with a single initializer *)
  4250:   | _, (A.NEXT_INIT, A.SINGLE_INIT oneinit) :: restil ->
  4251:       let se, oneinit', t' = doExp isconst oneinit (AExp(Some so.soTyp)) in
  4252:       setone so.soOff (mkCastT oneinit' t' so.soTyp);
  4253:       (* Move on *)
  4254:       advanceSubobj so;
  4255:       doInit isconst setone so (acc @@ se) restil
  4256: 
  4257: 
  4258:      (* An array with a compound initializer. The initializer is for the
  4259:       * array elements *)
  4260:   | TArray (bt, leno, _), (A.NEXT_INIT, A.COMPOUND_INIT initl) :: restil ->
  4261:       (* Create a separate object for the array *)
  4262:       let so' = makeSubobj so.host so.soTyp so.soOff in
  4263:       (* Go inside the array *)
  4264:       let leno = integerArrayLength leno in
  4265:       so'.stack <- [InArray(so'.curOff, bt, leno, ref 0)];
  4266:       normalSubobj so';
  4267:       let acc', initl' = doInit isconst setone so' acc initl in
  4268:       if initl' <> [] then
  4269:         ignore (warn "Too many initializers for array %t" whoami);
  4270:       (* Advance past the array *)
  4271:       advanceSubobj so;
  4272:       (* Continue *)
  4273:       let res = doInit isconst setone so acc' restil in
  4274:       res
  4275: 
  4276:    (* We have a designator that tells us to select the matching union field.
  4277:     * This is to support a GCC extension *)
  4278:   | TComp(ci, _), [(A.NEXT_INIT,
  4279:                     A.COMPOUND_INIT [(A.INFIELD_INIT ("___matching_field",
  4280:                                                      A.NEXT_INIT),
  4281:                                       A.SINGLE_INIT oneinit)])]
  4282:                       when not ci.cstruct ->
  4283:       (* Do the expression to find its type *)
  4284:       let _, _, t' = doExp isconst oneinit (AExp None) in
  4285:       let tsig = typeSigWithAttrs (fun _ -> []) t' in
  4286:       let rec findField = function
  4287:           [] -> E.s (error "Cannot find matching union field in cast")
  4288:         | fi :: rest when typeSigWithAttrs (fun _ -> []) fi.ftype = tsig -> fi
  4289:         | _ :: rest -> findField rest
  4290:       in
  4291:       let fi = findField ci.cfields in
  4292:       (* Change the designator and redo *)
  4293:       doInit isconst setone so acc [(A.INFIELD_INIT (fi.fname, A.NEXT_INIT),
  4294:                                      A.SINGLE_INIT oneinit)]
  4295: 
  4296: 
  4297:         (* A structure with a composite initializer. We initialize the fields*)
  4298:   | TComp (comp, _), (A.NEXT_INIT, A.COMPOUND_INIT initl) :: restil ->
  4299:       (* Create a separate subobject iterator *)
  4300:       let so' = makeSubobj so.host so.soTyp so.soOff in
  4301:       (* Go inside the comp *)
  4302:       so'.stack <- [InComp(so'.curOff, comp, fieldsToInit comp None)];
  4303:       normalSubobj so';
  4304:       let acc', initl' = doInit isconst setone so' acc initl in
  4305:       if initl' <> [] then
  4306:         ignore (warn "Too many initializers for structure");
  4307:       (* Advance past the structure *)
  4308:       advanceSubobj so;
  4309:       (* Continue *)
  4310:       doInit isconst setone so acc' restil
  4311: 
  4312:         (* A scalar with a initializer surrounded by braces *)
  4313:   | _, (A.NEXT_INIT, A.COMPOUND_INIT [(A.NEXT_INIT,
  4314:                                        A.SINGLE_INIT oneinit)]) :: restil ->
  4315:       let se, oneinit', t' = doExp isconst oneinit (AExp(Some so.soTyp)) in
  4316:       setone so.soOff (mkCastT oneinit' t' so.soTyp);
  4317:       (* Move on *)
  4318:       advanceSubobj so;
  4319:       doInit isconst setone so (acc @@ se) restil
  4320: 
  4321:   | t, (A.NEXT_INIT, _) :: _ ->
  4322:       E.s (unimp "doInit: unexpected NEXT_INIT for %a\n" d_type t);
  4323: 
  4324:    (* We have a designator *)
  4325:   | _, (what, ie) :: restil when what != A.NEXT_INIT ->
  4326:       (* Process a designator and position to the designated subobject *)
  4327:       let rec addressSubobj
  4328:           (so: subobj)
  4329:           (what: A.initwhat)
  4330:           (acc: chunk) : chunk =
  4331:         (* Always start from the current element *)
  4332:         so.stack <- []; so.eof <- false;
  4333:         normalSubobj so;
  4334:         let rec address (what: A.initwhat) (acc: chunk)  : chunk =
  4335:           match what with
  4336:             A.NEXT_INIT -> acc
  4337:           | A.INFIELD_INIT (fn, whatnext) -> begin
  4338:               match unrollType so.soTyp with
  4339:                 TComp (comp, _) ->
  4340:                   let toinit = fieldsToInit comp (Some fn) in
  4341:                   so.stack <- InComp(so.soOff, comp, toinit) :: so.stack;
  4342:                   normalSubobj so;
  4343:                   address whatnext acc
  4344: 
  4345:               | _ -> E.s (error "Field designator %s not in a struct " fn)
  4346:           end
  4347: 
  4348:           | A.ATINDEX_INIT(idx, whatnext) -> begin
  4349:               match unrollType so.soTyp with
  4350:                 TArray (bt, leno, _) ->
  4351:                   let ilen = integerArrayLength leno in
  4352:                   let nextidx', doidx =
  4353:                     let (doidx, idxe', _) =
  4354:                       doExp true idx (AExp(Some intType)) in
  4355:                     match constFold true idxe', isNotEmpty doidx with
  4356:                       Const(CInt64(x, _, _)), false -> Int64.to_int x, doidx
  4357:                     | _ -> E.s (error
  4358:                       "INDEX initialization designator is not a constant")
  4359:                   in
  4360:                   if nextidx' < 0 || nextidx' >= ilen then
  4361:                     E.s (error "INDEX designator is outside bounds");
  4362:                   so.stack <-
  4363:                      InArray(so.soOff, bt, ilen, ref nextidx') :: so.stack;
  4364:                   normalSubobj so;
  4365:                   address whatnext (acc @@ doidx)
  4366: 
  4367:               | _ -> E.s (error "INDEX designator for a non-array")
  4368:           end
  4369: 
  4370:           | A.ATINDEXRANGE_INIT _ ->
  4371:               E.s (bug "addressSubobj: INDEXRANGE")
  4372:         in
  4373:         address what acc
  4374:       in
  4375:       (* First expand the INDEXRANGE by making copies *)
  4376:       let rec expandRange (top: A.initwhat -> A.initwhat) = function
  4377:         | A.INFIELD_INIT (fn, whatnext) ->
  4378:             expandRange (fun what -> top (A.INFIELD_INIT(fn, what))) whatnext
  4379:         | A.ATINDEX_INIT (idx, whatnext) ->
  4380:             expandRange (fun what -> top (A.ATINDEX_INIT(idx, what))) whatnext
  4381: 
  4382:         | A.ATINDEXRANGE_INIT (idxs, idxe) ->
  4383:             let (doidxs, idxs', _) =
  4384:               doExp true idxs (AExp(Some intType)) in
  4385:             let (doidxe, idxe', _) =
  4386:               doExp true idxe (AExp(Some intType)) in
  4387:             if isNotEmpty doidxs || isNotEmpty doidxe then
  4388:               E.s (error "Range designators are not constants\n");
  4389:             let first, last =
  4390:               match constFold true idxs', constFold true idxe' with
  4391:                 Const(CInt64(s, _, _)),
  4392:                 Const(CInt64(e, _, _)) ->
  4393:                   Int64.to_int s, Int64.to_int e
  4394:               | _ -> E.s (error
  4395:                  "INDEX_RANGE initialization designator is not a constant")
  4396:             in
  4397:             if first < 0 || first > last then
  4398:               E.s (error
  4399:                      "start index larger than end index in range initializer");
  4400:             let rec loop (i: int) =
  4401:               if i > last then restil
  4402:               else
  4403:                 (top (A.ATINDEX_INIT(A.CONSTANT(A.CONST_INT(string_of_int i)),
  4404:                                      A.NEXT_INIT)), ie)
  4405:                 :: loop (i + 1)
  4406:             in
  4407:             doInit isconst setone so acc (loop first)
  4408: 
  4409:         | A.NEXT_INIT -> (* We have not found any RANGE *)
  4410:             let acc' = addressSubobj so what acc in
  4411:             doInit isconst setone so (acc @@ acc')
  4412:               ((A.NEXT_INIT, ie) :: restil)
  4413:       in
  4414:       expandRange (fun x -> x) what
  4415: 
  4416:   | t, (what, ie) :: _ ->
  4417:       E.s (bug "doInit: cases for t=%a" d_type t)
  4418: 
  4419: 
  4420: (* Create and add to the file (if not already added) a global. Return the
  4421:  * varinfo *)
  4422: and createGlobal (specs : (typ * storage * bool * A.attribute list))
  4423:                  (((n,ndt,a,cloc) as nm, inite) : A.init_name) : varinfo =
  4424:   try
  4425:     if debugGlobal then
  4426:       ignore (E.log "createGlobal: %s\n" n);
  4427:             (* Make a first version of the varinfo *)
  4428:     let vi = makeVarInfoFlx_cil_cabs ~isformal:false
  4429:                              ~isglobal:true (convLoc cloc) specs (n,ndt,a) in
  4430:     (* Add the variable to the environment before doing the initializer
  4431:      * because it might refer to the variable itself *)
  4432:     if isFunctionType vi.vtype then begin
  4433:       if inite != A.NO_INIT  then
  4434:         E.s (error "Function declaration with initializer (%s)\n"
  4435:                vi.vname);
  4436:       (* sm: if it's a function prototype, and the storage class *)
  4437:       (* isn't specified, make it 'extern'; this fixes a problem *)
  4438:       (* with no-storage prototype and static definition *)
  4439:       if vi.vstorage = NoStorage then
  4440:         (*(trace "sm" (dprintf "adding extern to prototype of %s\n" n));*)
  4441:         vi.vstorage <- Extern;
  4442:     end;
  4443:     let vi, alreadyInEnv = makeGlobalVarinfo (inite != A.NO_INIT) vi in
  4444: (*
  4445:     ignore (E.log "createGlobal %a: %s type=%a\n"
  4446:        d_loc (convLoc cloc) vi.vname d_plaintype vi.vtype);
  4447: *)
  4448:             (* Do the initializer and complete the array type if necessary *)
  4449:     let init : init option =
  4450:       if inite = A.NO_INIT then
  4451:         None
  4452:       else
  4453:         let se, ie', et = doInitializer vi inite in
  4454:         (* Maybe we now have a better type *)
  4455:         vi.vtype <- et;
  4456:         if isNotEmpty se then
  4457:           E.s (error "global initializer");
  4458:         Some ie'
  4459:     in
  4460: 
  4461:     try
  4462:       let oldloc = H.find alreadyDefined vi.vname in
  4463:       if init != None then begin
  4464:         E.s (error "Global %s was already defined at %a\n"
  4465:                vi.vname d_loc oldloc);
  4466:       end;
  4467:       if debugGlobal then
  4468:         ignore (E.log " global %s was already defined\n" vi.vname);
  4469:       (* Do not declare it again *)
  4470:       vi
  4471:     with Not_found -> begin
  4472:       (* Not already defined *)
  4473:       if debugGlobal then
  4474:         ignore (E.log " first definition for %s\n" vi.vname);
  4475:       if init != None then begin
  4476:         (* weimer: Sat Dec  8 17:43:34  2001
  4477:          * MSVC NT Kernel headers include this lovely line:
  4478:          * extern const GUID __declspec(selectany) \
  4479:          *  MOUNTDEV_MOUNTED_DEVICE_GUID = { 0x53f5630d, 0xb6bf, 0x11d0, { \
  4480:          *  0x94, 0xf2, 0x00, 0xa0, 0xc9, 0x1e, 0xfb, 0x8b } };
  4481:          * So we allow "extern" + "initializer" if "const" is
  4482:          * around. *)
  4483:         (* sm: As I read the ISO spec, in particular 6.9.2 and 6.7.8,
  4484:          * "extern int foo = 3" is exactly equivalent to "int foo = 3";
  4485:          * that is, if you put an initializer, then it is a definition,
  4486:          * and "extern" is redundantly giving the name external linkage.
  4487:          * gcc emits a warning, I guess because it is contrary to
  4488:          * usual practice, but I think CIL warnings should be about
  4489:          * semantic rather than stylistic issues, so I see no reason to
  4490:          * even emit a warning. *)
  4491:         if vi.vstorage = Extern then
  4492:           vi.vstorage <- NoStorage;     (* equivalent and canonical *)
  4493: 
  4494:         H.add alreadyDefined vi.vname !currentLoc;
  4495:         H.remove mustTurnIntoDef vi.vid;
  4496:         cabsPushGlobal (GVar(vi, {init = init}, !currentLoc));
  4497:         vi
  4498:       end else begin
  4499:         if not (isFunctionType vi.vtype)
  4500:            && not (H.mem mustTurnIntoDef vi.vid) then
  4501:           begin
  4502:             H.add mustTurnIntoDef vi.vid true
  4503:           end;
  4504:         if not alreadyInEnv then begin (* Only one declaration *)
  4505:           (* If it has function type it is a prototype *)
  4506:           cabsPushGlobal (GVarDecl (vi, !currentLoc));
  4507:           vi
  4508:         end else begin
  4509:           if debugGlobal then
  4510:             ignore (E.log " already in env %s\n" vi.vname);
  4511:           vi
  4512:         end
  4513:       end
  4514:     end
  4515:   with e -> begin
  4516:     ignore (E.log "error in createGlobal(%s: %a): %s\n" n
  4517:               d_loc !currentLoc
  4518:               (Printexc.to_string e));
  4519:     cabsPushGlobal (dGlobal (dprintf "booo - error in global %s (%t)"
  4520:                            n d_thisloc) !currentLoc);
  4521:     dummyFunDec.svar
  4522:   end
  4523: (*
  4524:           ignore (E.log "Env after processing global %s is:@!%t@!"
  4525:                     n docEnv);
  4526:           ignore (E.log "Alpha after processing global %s is:@!%t@!"
  4527:                     n docAlphaTable)
  4528: *)
  4529: 
  4530: (* Must catch the Static local variables. Make them global *)
  4531: and createLocal ((_, sto, _, _) as specs)
  4532:                 ((((n, ndt, a, cloc) : A.name),
  4533:                   (e: A.init_expression)) as init_name)
  4534:   : chunk =
  4535:   let loc = convLoc cloc in
  4536:   (* Flx_cil_check if we are declaring a function *)
  4537:   let rec isProto (dt: decl_type) : bool =
  4538:     match dt with
  4539:     | PROTO (JUSTBASE, _, _) -> true
  4540:     | PROTO (x, _, _) -> isProto x
  4541:     | PARENTYPE (_, x, _) -> isProto x
  4542:     | ARRAY (x, _, _) -> isProto x
  4543:     | PTR (_, x) -> isProto x
  4544:     | _ -> false
  4545:   in
  4546:   match ndt with
  4547:     (* Maybe we have a function prototype in local scope. Make it global. We
  4548:      * do this even if the storage is Static *)
  4549:   | _ when isProto ndt ->
  4550:       let vi = createGlobal specs init_name in
  4551:       (* Add it to the environment to shadow previous decls *)
  4552:       addLocalToEnv n (EnvVar vi);
  4553:       empty
  4554: 
  4555:   | _ when sto = Static ->
  4556:       if debugGlobal then
  4557:         ignore (E.log "createGlobal (local static): %s\n" n);
  4558: 
  4559:       (* Now alpha convert it to make sure that it does not conflict with
  4560:        * existing globals or locals from this function. *)
  4561:       let newname, _  = newAlphaName true "" n in
  4562:       (* Make it global  *)
  4563:       let vi = makeVarInfoFlx_cil_cabs ~isformal:false
  4564:                                ~isglobal:true
  4565:                                loc specs (newname, ndt, a) in
  4566:       (* However, we have a problem if a real global appears later with the
  4567:        * name that we have happened to choose for this one. Remember these names
  4568:        * for later. *)
  4569:       H.add staticLocals vi.vname vi;
  4570:       (* Add it to the environment as a local so that the name goes out of
  4571:        * scope properly *)
  4572:       addLocalToEnv n (EnvVar vi);
  4573:       let init : init option =
  4574:         if e = A.NO_INIT then
  4575:           None
  4576:         else begin
  4577:           let se, ie', et = doInitializer vi e in
  4578:           (* Maybe we now have a better type *)
  4579:           vi.vtype <- et;
  4580:           if isNotEmpty se then
  4581:             E.s (error "global static initializer");
  4582:           (* Maybe the initializer refers to the function itself.
  4583:              Push a prototype for the function, just in case. Hopefully,
  4584:              if does not refer to the locals *)
  4585:           cabsPushGlobal (GVarDecl (!currentFunctionFDEC.svar, !currentLoc));
  4586:           Some ie'
  4587:         end
  4588:       in
  4589:       cabsPushGlobal (GVar(vi, {init = init}, !currentLoc));
  4590:       empty
  4591: 
  4592:   (* Maybe we have an extern declaration. Make it a global *)
  4593:   | _ when sto = Extern ->
  4594:       let vi = createGlobal specs init_name in
  4595:       (* Add it to the local environment to ensure that it shadows previous
  4596:        * local variables *)
  4597:       addLocalToEnv n (EnvVar vi);
  4598:       empty
  4599: 
  4600:   | _ ->
  4601:       (* Make a variable of potentially variable size. If se0 <> empty then
  4602:        * it is a variable size variable *)
  4603:       let vi,se0,len,isvarsize =
  4604:         makeVarSizeVarInfo loc specs (n, ndt, a) in
  4605: 
  4606:       let vi = alphaConvertVarAndAddToEnv true vi in        (* Replace vi *)
  4607:       let se1 =
  4608:         if isvarsize then begin (* Variable-sized array *)
  4609:           ignore (warn "Variable-sized local variable %s" vi.vname);
  4610:           (* Make a local variable to keep the length *)
  4611:           let savelen =
  4612:             makeVarInfoFlx_cil_cabs
  4613:                         ~isformal:false
  4614:                         ~isglobal:false
  4615:                         loc
  4616:                         (TInt(IUInt, []), NoStorage, false, [])
  4617:                         ("__lengthof" ^ vi.vname,JUSTBASE, [])
  4618:           in
  4619:           (* Register it *)
  4620:           let savelen = alphaConvertVarAndAddToEnv true savelen in
  4621:           (* Compute the sizeof *)
  4622:           let sizeof =
  4623:             BinOp(Mult,
  4624:                   SizeOfE (Lval(Mem(Lval(var vi)), NoOffset)),
  4625:                   Lval (var savelen), !typeOfSizeOf) in
  4626:           (* Register the length *)
  4627:           H.add varSizeArrays vi.vid sizeof;
  4628:           (* There can be no initializer for this *)
  4629:           if e != A.NO_INIT then
  4630:             E.s (error "Variable-sized array cannot have initializer");
  4631:           se0 +++ (Set(var savelen, len, !currentLoc))
  4632:             (* Initialize the variable *)
  4633:             +++ (Call(Some(var vi), Lval(var allocaFun.svar),
  4634:                       [ sizeof  ], !currentLoc))
  4635:         end else empty
  4636:       in
  4637:       if e = A.NO_INIT then
  4638:         se1 (* skipChunk *)
  4639:       else begin
  4640:         let se4, ie', et = doInitializer vi e in
  4641:         (* Fix the length *)
  4642:         (match vi.vtype, ie', et with
  4643:             (* We have a length now *)
  4644:           TArray(_,None, _), _, TArray(_, Some _, _) -> vi.vtype <- et
  4645:             (* Initializing a local array *)
  4646:         | TArray(TInt((IChar|IUChar|ISChar), _) as bt, None, a),
  4647:              SingleInit(Const(CStr s)), _ ->
  4648:                vi.vtype <- TArray(bt,
  4649:                                   Some (integer (String.length s + 1)),
  4650:                                   a)
  4651:         | _, _, _ -> ());
  4652:         (* Now create assignments instead of the initialization *)
  4653:         se1 @@ se4 @@ (assignInit (Var vi, NoOffset) ie' et empty)
  4654:       end
  4655: 
  4656: 
  4657: (* Do one declaration *)
  4658: and doDecl (isglobal: bool) : A.definition -> chunk = function
  4659:   | A.DECDEF ((s, nl), loc) ->
  4660:       currentLoc := convLoc(loc);
  4661:       (* Do the specifiers exactly once *)
  4662:       let sugg =
  4663:         match nl with
  4664:           [] -> ""
  4665:         | ((n, _, _, _), _) :: _ -> n
  4666:       in
  4667:       let spec_res = doSpecList sugg s in
  4668:       (* Do all the variables and concatenate the resulting statements *)
  4669:       let doOneDeclarator (acc: chunk) (n: init_name) =
  4670:         if isglobal then begin
  4671:           (* For a global we ignore the varinfo that is created  *)
  4672:           ignore (createGlobal spec_res n);
  4673:           acc
  4674:         end else
  4675:           acc @@ createLocal spec_res n
  4676:       in
  4677:       List.fold_left doOneDeclarator empty nl
  4678: 
  4679:   | A.TYPEDEF (ng, loc) ->
  4680:      currentLoc := convLoc(loc);
  4681:      doTypedef ng; empty
  4682: 
  4683:   | A.ONLYTYPEDEF (s, loc) ->
  4684:       currentLoc := convLoc(loc);
  4685:       doOnlyTypedef s; empty
  4686: 
  4687:   | A.GLOBASM (s,loc) when isglobal ->
  4688:       currentLoc := convLoc(loc);
  4689:       cabsPushGlobal (GAsm (s, !currentLoc));
  4690:       empty
  4691: 
  4692:   | A.PRAGMA (a, loc) when isglobal -> begin
  4693:       currentLoc := convLoc(loc);
  4694:       match doAttr ("dummy", [a]) with
  4695:         [Attr("dummy", [a'])] ->
  4696:           let a'' =
  4697:             match a' with
  4698:             | ACons (s, args) -> Attr (s, args)
  4699:             | _ -> E.s (error "Unexpected attribute in #pragma")
  4700:           in
  4701:           cabsPushGlobal (GPragma (a'', !currentLoc));
  4702:           empty
  4703: 
  4704:       | _ -> E.s (error "Too many attributes in pragma")
  4705:   end
  4706:   | A.TRANSFORMER (_, _, _) -> E.s (E.bug "TRANSFORMER in cabs2cil input")
  4707:   | A.EXPRTRANSFORMER (_, _, _) ->
  4708:       E.s (E.bug "EXPRTRANSFORMER in cabs2cil input")
  4709: 
  4710:   (* If there are multiple definitions of extern inline, turn all but the
  4711:    * first into a prototype *)
  4712:   | A.FUNDEF (((specs,(n,dt,a,loc')) : A.single_name),
  4713:               (body : A.block), loc, _)
  4714:       when isglobal && isExtern specs && isInline specs
  4715:            && (H.mem genv (n ^ "__extinline")) ->
  4716:        currentLoc := convLoc(loc);
  4717:        ignore (warn "Duplicate extern inline definition for %s ignored"
  4718:                  n);
  4719:        (* Treat it as a prototype *)
  4720:        doDecl isglobal (A.DECDEF ((specs, [((n,dt,a,loc'), A.NO_INIT)]), loc))
  4721: 
  4722:   | A.FUNDEF (((specs,(n,dt,a, _)) : A.single_name),
  4723:               (body : A.block), loc1, loc2) when isglobal ->
  4724:     begin
  4725:       let funloc = convLoc loc1 in
  4726:       let endloc = convLoc loc2 in
  4727: (*      ignore (E.log "Definition of %s at %a\n" n d_loc funloc); *)
  4728:       currentLoc := funloc;
  4729:       E.withContext
  4730:         (fun _ -> dprintf "2cil: %s" n)
  4731:         (fun _ ->
  4732:           try
  4733:             (* Make the fundec right away, and we'll populate it later. We
  4734:              * need this throughout the code to create temporaries. *)
  4735:             currentFunctionFDEC :=
  4736:                { svar     = makeGlobalVar "@tempname@" voidType;
  4737:                  slocals  = []; (* For now we'll put here both the locals and
  4738:                                  * the formals. Then "endFunction" will
  4739:                                  * separate them *)
  4740:                  sformals = []; (* Not final yet *)
  4741:                  smaxid   = 0;
  4742:                  sbody    = dummyFunDec.sbody; (* Not final yet *)
  4743:                  smaxstmtid = None;
  4744:                };
  4745:             !currentFunctionFDEC.svar.vdecl <- funloc;
  4746: 
  4747:             constrExprId := 0;
  4748:             (* Setup the environment. Add the formals to the locals. Maybe
  4749:             * they need alpha-conv  *)
  4750:             enterScope ();  (* Start the scope *)
  4751: 
  4752:             H.clear varSizeArrays;
  4753: 
  4754:             (* Do not process transparent unions in function definitions.
  4755:             * We'll do it later *)
  4756:             transparentUnionArgs := [];
  4757: 
  4758:             (* Fix the NAME and the STORAGE *)
  4759:             let _ =
  4760:               let bt,sto,inl,attrs = doSpecList n specs in
  4761:               !currentFunctionFDEC.svar.vinline <- inl;
  4762: 
  4763:               let ftyp, funattr =
  4764:                 doType (AttrName false) bt (A.PARENTYPE(attrs, dt, a)) in
  4765:               !currentFunctionFDEC.svar.vtype <- ftyp;
  4766:               !currentFunctionFDEC.svar.vattr <- funattr;
  4767: 
  4768:               (* If this is the definition of an extern inline then we change
  4769:                * its name, by adding the suffix __extinline. We also make it
  4770:                * static *)
  4771:               let n', sto' =
  4772:                 let n' = n ^ "__extinline" in
  4773:                 if inl && sto = Extern then
  4774:                   n', Static
  4775:                 else begin
  4776:                   (* Maybe this is the body of a previous extern inline. Then
  4777:                   * we must take that one out of the environment because it
  4778:                   * is not used from here on. This will also ensure that
  4779:                   * then we make this functions' varinfo we will not think
  4780:                   * it is a duplicate definition *)
  4781:                   (try
  4782:                     ignore (lookupVar n'); (* n' is defined *)
  4783:                     let oldvi, _ = lookupVar n in
  4784:                     if oldvi.vname <> n' then
  4785:                       E.s (bug "extern inline redefinition: %s (expected %s)"
  4786:                              oldvi.vname n');
  4787:                     H.remove env n; H.remove genv n;
  4788:                     H.remove env n'; H.remove genv n'
  4789:                   with Not_found -> ());
  4790:                   n, sto
  4791:                 end
  4792:               in
  4793:               (* Now we have the name and the storage *)
  4794:               !currentFunctionFDEC.svar.vname <- n';
  4795:               !currentFunctionFDEC.svar.vstorage <- sto'
  4796:             in
  4797: 
  4798:             (* Add the function itself to the environment. Add it before
  4799:             * you do the body because the function might be recursive. Add
  4800:             * it also before you add the formals to the environment
  4801:             * because there might be a formal with the same name as the
  4802:             * function and we want it to take precedence. *)
  4803:             (* Make a variable out of it and put it in the environment *)
  4804:             !currentFunctionFDEC.svar <-
  4805:                fst (makeGlobalVarinfo true !currentFunctionFDEC.svar);
  4806: 
  4807:             (* If it is extern inline then we add it to the global
  4808:              * environment for the original name as well. This will ensure
  4809:              * that all uses of this function will refer to the renamed
  4810:              * function *)
  4811:             addGlobalToEnv n (EnvVar !currentFunctionFDEC.svar);
  4812: 
  4813:             if H.mem alreadyDefined !currentFunctionFDEC.svar.vname then
  4814:               E.s (error "There is a definition already for %s" n);
  4815: 
  4816: (*
  4817:             ignore (E.log "makefunvar:%s@! type=%a@! vattr=%a@!"
  4818:                         n d_type thisFunctionVI.vtype
  4819:                         d_attrlist thisFunctionVI.vattr);
  4820: *)
  4821: 
  4822:             (* makeGlobalVarinfo might have changed the type of the function
  4823:              * (when combining it with the type of the prototype). So get the
  4824:              * type only now. *)
  4825: 
  4826:             (**** Process the TYPE and the FORMALS ***)
  4827:             let _ =
  4828:               let (returnType, formals_t, isvararg, funta) =
  4829:                 splitFunctionTypeVI !currentFunctionFDEC.svar
  4830:               in
  4831:               (* Record the returnType for doStatement *)
  4832:               currentReturnType   := returnType;
  4833: 
  4834: 
  4835:               (* Create the formals and add them to the environment. *)
  4836:               (* sfg: extract locations for the formals from dt *)
  4837:               let doFormal (loc : location) (fn, ft, fa) =
  4838:                 let f = makeVarinfo false fn ft in
  4839:                   (f.vdecl <- loc;
  4840:                    f.vattr <- fa;
  4841:                    alphaConvertVarAndAddToEnv true f)
  4842:               in
  4843:               let rec doFormals fl' ll' =
  4844:                 begin
  4845:                   match (fl', ll') with
  4846:                     | [], _ -> []
  4847: 
  4848:                     | fl, [] -> (* no more locs available *)
  4849:                           List.map (doFormal !currentLoc) fl
  4850: 
  4851:                     | f::fl, (_,(_,_,_,l))::ll ->
  4852:                         (* sfg: these lets seem to be necessary to
  4853:                          *  force the right order of evaluation *)
  4854:                         let f' = doFormal (convLoc l) f in
  4855:                         let fl' = doFormals fl ll in
  4856:                           f' :: fl'
  4857:                 end
  4858:               in
  4859:               let fmlocs = (match dt with PROTO(_, fml, _) -> fml | _ -> []) in
  4860:               let formals = doFormals (argsToList formals_t) fmlocs in
  4861: 
  4862:               (* Recreate the type based on the formals. *)
  4863:               let ftype = TFun(returnType,
  4864:                                Some (List.map (fun f -> (f.vname,
  4865:                                                          f.vtype,
  4866:                                                          f.vattr)) formals),
  4867:                                isvararg, funta) in
  4868:               (*
  4869:               ignore (E.log "Funtype of %s: %a\n" n' d_type ftype);
  4870:               *)
  4871:               (* Now fix the names of the formals in the type of the function
  4872:               * as well *)
  4873:               !currentFunctionFDEC.svar.vtype <- ftype;
  4874:               !currentFunctionFDEC.sformals <- formals;
  4875:             in
  4876:             (* Now change the type of transparent union args back to what it
  4877:              * was so that the body type checks. We must do it this late
  4878:              * because makeGlobalVarinfo from above might choke if we give
  4879:              * the function a type containing transparent unions  *)
  4880:             let _ =
  4881:               let rec fixbackFormals (idx: int) (args: varinfo list) : unit=
  4882:                 match args with
  4883:                   [] -> ()
  4884:                 | a :: args' ->
  4885:                     (* Fix the type back to a transparent union type *)
  4886:                     (try
  4887:                       let origtype = List.assq idx !transparentUnionArgs in
  4888:                       a.vtype <- origtype;
  4889:                     with Not_found -> ());
  4890:                     fixbackFormals (idx + 1) args'
  4891:               in
  4892:               fixbackFormals 0 !currentFunctionFDEC.sformals;
  4893:               transparentUnionArgs := [];
  4894:             in
  4895: 
  4896:             (********** Now do the BODY *************)
  4897:             let _ =
  4898:               let stmts = doBody body in
  4899:               (* Finish everything *)
  4900:               exitScope ();
  4901: 
  4902:               (* Now fill in the computed goto statement with cases. Do this
  4903:                * before mkFunctionbody which resolves the gotos *)
  4904:               (match !gotoTargetData with
  4905:                 Some (switchv, switch) ->
  4906:                   let switche, l =
  4907:                     match switch.skind with
  4908:                       Switch (switche, _, _, l) -> switche, l
  4909:                     | _ -> E.s(bug "the computed goto statement not a switch")
  4910:                   in
  4911:                   (* Build a default chunk that segfaults *)
  4912:                   let default =
  4913:                     defaultChunk
  4914:                       l
  4915:                       (i2c (Set ((Mem (mkCast (integer 0) intPtrType),
  4916:                                   NoOffset),
  4917:                                  integer 0, l)))
  4918:                   in
  4919:                   let bodychunk = ref default in
  4920:                   H.iter (fun lname laddr ->
  4921:                     bodychunk :=
  4922:                        caseRangeChunk
  4923:                          [integer laddr] l
  4924:                          (gotoChunk lname l @@ !bodychunk))
  4925:                     gotoTargetHash;
  4926:                   (* Now recreate the switch *)
  4927:                   let newswitch = switchChunk switche !bodychunk l in
  4928:                   (* We must still share the old switch statement since we
  4929:                   * have already inserted the goto's *)
  4930:                   let newswitchkind =
  4931:                     match newswitch.stmts with
  4932:                       [ s]
  4933:                         when newswitch.postins = [] && newswitch.cases = []->
  4934:                           s.skind
  4935:                     | _ -> E.s (bug "Unexpected result from switchChunk")
  4936:                   in
  4937:                   switch.skind <- newswitchkind
  4938: 
  4939:               | None -> ());
  4940:               (* Now finish the body and store it *)
  4941:               !currentFunctionFDEC.sbody <- mkFunctionBody stmts;
  4942:               (* Reset the global parameters *)
  4943:               gotoTargetData := None;
  4944:               H.clear gotoTargetHash;
  4945:               gotoTargetNextAddr := 0;
  4946:             in
  4947: 
  4948: 
  4949: 
  4950: (*
  4951:               ignore (E.log "endFunction %s at %t:@! sformals=%a@!  slocals=%a@!"
  4952:               !currentFunctionFDEC.svar.vname d_thisloc
  4953:               (docList (chr ',') (fun v -> text v.vname))
  4954:               !currentFunctionFDEC.sformals
  4955:               (docList (chr ',') (fun v -> text v.vname))
  4956:               !currentFunctionFDEC.slocals);
  4957: *)
  4958: 
  4959:             let rec dropFormals formals locals =
  4960:               match formals, locals with
  4961:                 [], l -> l
  4962:               | f :: formals, l :: locals ->
  4963:                   if f != l then
  4964:                     E.s (bug "formal %s is not in locals (found instead %s)"
  4965:                            f.vname l.vname);
  4966:                   dropFormals formals locals
  4967:               | _ -> E.s (bug "Too few locals")
  4968:             in
  4969:             !currentFunctionFDEC.slocals
  4970:               <- dropFormals !currentFunctionFDEC.sformals
  4971:                    (List.rev !currentFunctionFDEC.slocals);
  4972:             setMaxId !currentFunctionFDEC;
  4973: 
  4974:             (* Now go over the types of the formals and pull out the formals
  4975:              * with transparent union type. Replace them with some shadow
  4976:              * parameters and then add assignments  *)
  4977:             let _ =
  4978:               let newformals, newbody =
  4979:                 List.fold_right (* So that the formals come out in order *)
  4980:                   (fun f (accform, accbody) ->
  4981:                     match isTransparentUnion f.vtype with
  4982:                       None -> (f :: accform, accbody)
  4983:                     | Some fstfield ->
  4984:                         (* A new shadow to be placed in the formals. Use
  4985:                          * makeTempVar to update smaxid and all others. *)
  4986:                         let shadow =
  4987:                           makeTempVar !currentFunctionFDEC fstfield.ftype in
  4988:                         (* Now take it out of the locals and replace it with
  4989:                         * the current formal. It is not worth optimizing this
  4990:                         * one  *)
  4991:                         !currentFunctionFDEC.slocals <-
  4992:                            f ::
  4993:                            (List.filter (fun x -> x.vid <> shadow.vid)
  4994:                               !currentFunctionFDEC.slocals);
  4995:                         (shadow :: accform,
  4996:                          mkStmt (Instr [Set ((Var f, Field(fstfield,
  4997:                                                            NoOffset)),
  4998:                                              Lval (var shadow),
  4999:                                              !currentLoc)]) :: accbody))
  5000:                   !currentFunctionFDEC.sformals
  5001:                   ([], !currentFunctionFDEC.sbody.bstmts)
  5002:               in
  5003:               !currentFunctionFDEC.sbody.bstmts <- newbody;
  5004:               (* To make sure sharing with the type is proper *)
  5005:               setFormals !currentFunctionFDEC newformals;
  5006:             in
  5007: 
  5008:             (* Now see whether we can fall through to the end of the function
  5009:              * *)
  5010:             (* weimer: Sat Dec 8 17:30:47 2001 MSVC NT kernel headers include
  5011:              * functions like long convert(x) { __asm { mov eax, x \n cdq } }
  5012:              * That set a return value via an ASM statement. As a result, I
  5013:              * am changing this so a final ASM statement does not count as
  5014:              * "fall through" for the purposes of this warning.  *)
  5015:             let instrFallsThrough (i : instr) = match i with
  5016:               Set _ -> true
  5017:             | Call (None, Lval (Var e, NoOffset), _, _) ->
  5018:                 (* See if this is exit, or if it has the noreturn attribute *)
  5019:                 if e.vname = "exit" then false
  5020:                 else if hasAttribute "noreturn" e.vattr then false
  5021:                 else true
  5022:             | Call _ -> true
  5023:             | Asm _ -> false
  5024:             in
  5025:             let rec stmtFallsThrough (s: stmt) : bool =
  5026:               match s.skind with
  5027:                 Instr(il) ->
  5028:                   List.fold_left (fun acc elt ->
  5029:                                       acc && instrFallsThrough elt) true il
  5030:               | Return _ | Break _ | Continue _ -> false
  5031:               | Goto _ -> false
  5032:               | If (_, b1, b2, _) ->
  5033:                   blockFallsThrough b1 || blockFallsThrough b2
  5034:               | Switch (e, b, targets, _) ->
  5035:                    (* See if there is a "default" case *)
  5036:                    if not
  5037:                       (List.exists (fun s ->
  5038:                          List.exists (function Default _ -> true | _ -> false)
  5039:                                       s.labels)
  5040:                                    targets) then begin
  5041: (*
  5042:                       ignore (E.log "Switch falls through because no default");
  5043: 
  5044: *)                      true (* We fall through because there is no default *)
  5045:                    end else begin
  5046:                       (* We must examine all cases. If any falls through,
  5047:                        * then the switch falls through. *)
  5048:                       blockFallsThrough b
  5049:                    end
  5050:               | Loop _ -> true (* Conservative *)
  5051:               | Block b -> blockFallsThrough b
  5052:               | TryFinally (b, h, _) -> blockFallsThrough h
  5053:               | TryExcept (b, _, h, _) -> true (* Conservative *)
  5054:             and blockFallsThrough b =
  5055:               let rec fall = function
  5056:                   [] -> true
  5057:                 | s :: rest ->
  5058:                     if stmtFallsThrough s then begin
  5059: (*
  5060:                         ignore (E.log "Stmt %a falls through\n" d_stmt s);
  5061: *)
  5062:                         fall rest
  5063:                     end else begin
  5064: (*
  5065:                         ignore (E.log "Stmt %a DOES NOT fall through\n"
  5066:                                       d_stmt s);
  5067: *)
  5068:                       (* If we are not falling thorough then maybe there
  5069:                       * are labels who are *)
  5070:                         labels rest
  5071:                     end
  5072:               and labels = function
  5073:                   [] -> false
  5074:                     (* We have a label, perhaps we can jump here *)
  5075:                   | s :: rest when s.labels <> [] ->
  5076: (*
  5077:                      ignore (E.log "invoking fall %a: %a\n"
  5078:                                       d_loc !currentLoc d_stmt s);
  5079: *)
  5080:                      fall (s :: rest)
  5081:                   | _ :: rest -> labels rest
  5082:               in
  5083:               let res = fall b.bstmts in
  5084: (*
  5085:               ignore (E.log "blockFallsThrough=%b %a\n" res d_block b);
  5086: *)
  5087:               res
  5088:             in
  5089:             if blockFallsThrough !currentFunctionFDEC.sbody then begin
  5090:               let retval =
  5091:                 match unrollType !currentReturnType with
  5092:                   TVoid _ -> None
  5093:                 | (TInt _ | TEnum _ | TFloat _ | TPtr _) as rt ->
  5094:                     ignore (warn "Body of function %s falls-through. Adding a return statement\n"  !currentFunctionFDEC.svar.vname);
  5095:                     Some (mkCastT zero intType rt)
  5096:                 | _ ->
  5097:                     ignore (warn "Body of function %s falls-through and cannot find an appropriate return value\n" !currentFunctionFDEC.svar.vname);
  5098:                     None
  5099:               in
  5100:               !currentFunctionFDEC.sbody.bstmts <-
  5101:                  !currentFunctionFDEC.sbody.bstmts
  5102:                  @ [mkStmt (Return(retval, endloc))]
  5103:             end;
  5104: 
  5105:             (* ignore (E.log "The env after finishing the body of %s:\n%t\n"
  5106:                         n docEnv); *)
  5107:             cabsPushGlobal (GFun (!currentFunctionFDEC, funloc));
  5108:             empty
  5109:           with e -> begin
  5110:             ignore (E.log "error in collectFunction %s: %s\n"
  5111:                       n (Printexc.to_string e));
  5112:             cabsPushGlobal (GAsm("error in function " ^ n, !currentLoc));
  5113:             empty
  5114:           end)
  5115:         () (* argument of E.withContext *)
  5116:     end (* FUNDEF *)
  5117: 
  5118:   | LINKAGE (n, loc, dl) ->
  5119:       currentLoc := convLoc loc;
  5120:       if n <> "C" then
  5121:         ignore (warn "Encountered linkage specification \"%s\"" n);
  5122:       if not isglobal then
  5123:         E.s (error "Encountered linkage specification in local scope");
  5124:       (* For now drop the linkage on the floor !!! *)
  5125:       List.iter
  5126:         (fun d ->
  5127:           let s = doDecl isglobal d in
  5128:           if isNotEmpty s then
  5129:             E.s (bug "doDecl returns non-empty statement for global"))
  5130:         dl;
  5131:       empty
  5132: 
  5133:   | NAMESPACE (n, loc, dl) ->
  5134:       currentLoc := convLoc loc;
  5135:       List.iter
  5136:         (fun d ->
  5137:           let s = doDecl isglobal d in
  5138:           if isNotEmpty s then
  5139:             E.s (bug "doDecl returns non-empty statement for global"))
  5140:         dl;
  5141:       empty
  5142: 
  5143:   | _ -> E.s (error "unexpected form of declaration")
  5144: 
  5145: and doTypedef ((specs, nl): A.name_group) =
  5146:   try
  5147:     (* Do the specifiers exactly once *)
  5148:     let bt, sto, inl, attrs = doSpecList (suggestAnonName nl) specs in
  5149:     if sto <> NoStorage || inl then
  5150:       E.s (error "Storage or inline specifier not allowed in typedef");
  5151:     let createTypedef ((n,ndt,a,loc) : A.name) =
  5152:       (*    E.s (error "doTypeDef") *)
  5153:       try
  5154:         let newTyp, tattr =
  5155:           doType AttrType bt (A.PARENTYPE(attrs, ndt, a))  in
  5156:         let newTyp' = cabsTypeAddAttributes tattr newTyp in
  5157:         (* Create a new name for the type. Use the same name space as that of
  5158:         * variables to avoid confusion between variable names and types. This
  5159:         * is actually necessary in some cases.  *)
  5160:         let n', _  = newAlphaName true "" n in
  5161:         let ti = { tname = n'; ttype = newTyp'; treferenced = false } in
  5162:         (* Since we use the same name space, we might later hit a global with
  5163:          * the same name and we would want to change the name of the global.
  5164:          * It is better to change the name of the type instead. So, remember
  5165:          * all types whose names have changed *)
  5166:         H.add typedefs n' ti;
  5167:         let namedTyp = TNamed(ti, []) in
  5168:         (* Register the type. register it as local because we might be in a
  5169:         * local context  *)
  5170:         addLocalToEnv (kindPlusName "type" n) (EnvTyp (TNamed(ti, [])));
  5171:         cabsPushGlobal (GType (ti, !currentLoc))
  5172:       with e -> begin
  5173:         ignore (E.log "Error on A.TYPEDEF (%s)\n"
  5174:                   (Printexc.to_string e));
  5175:         cabsPushGlobal (GAsm ("booo_typedef:" ^ n, !currentLoc))
  5176:       end
  5177:     in
  5178:     List.iter createTypedef nl
  5179:   with e -> begin
  5180:     ignore (E.log "Error on A.TYPEDEF (%s)\n"
  5181:               (Printexc.to_string e));
  5182:     let fstname =
  5183:       match nl with
  5184:         [] -> "<missing name>"
  5185:       | (n, _, _, _) :: _ -> n
  5186:     in
  5187:     cabsPushGlobal (GAsm ("booo_typedef: " ^ fstname, !currentLoc))
  5188:   end
  5189: 
  5190: and doOnlyTypedef (specs: A.spec_elem list) : unit =
  5191:   try
  5192:     let bt, sto, inl, attrs = doSpecList "" specs in
  5193:     if sto <> NoStorage || inl then
  5194:       E.s (error "Storage or inline specifier not allowed in typedef");
  5195:     let restyp, nattr = doType AttrType bt (A.PARENTYPE(attrs,
  5196:                                                         A.JUSTBASE, [])) in
  5197:     if nattr <> [] then
  5198:       ignore (warn "Ignoring identifier attribute");
  5199:            (* doSpec will register the type. *)
  5200:     (* See if we are defining a composite or enumeration type, and in that
  5201:      * case move the attributes from the defined type into the composite type
  5202:      * *)
  5203:     let isadef =
  5204:       List.exists
  5205:         (function
  5206:             A.SpecType(A.Tstruct(_, Some _, _)) -> true
  5207:           | A.SpecType(A.Tunion(_, Some _, _)) -> true
  5208:           | A.SpecType(A.Tenum(_, Some _, _)) -> true
  5209:           | _ -> false) specs
  5210:     in
  5211:     match restyp with
  5212:       TComp(ci, al) ->
  5213:         if isadef then begin
  5214:           ci.cattr <- cabsAddAttributes ci.cattr al;
  5215:           (* The GCompTag was already added *)
  5216:         end else (* Add a GCompTagDecl *)
  5217:           cabsPushGlobal (GCompTagDecl(ci, !currentLoc))
  5218:     | TEnum(ei, al) ->
  5219:         if isadef then begin
  5220:           ei.eattr <- cabsAddAttributes ei.eattr al;
  5221:         end else
  5222:           cabsPushGlobal (GEnumTagDecl(ei, !currentLoc))
  5223:     | _ ->
  5224:         ignore (warn "Ignoring un-named typedef that does not introduce a struct or enumeration type\n")
  5225: 
  5226:   with e -> begin
  5227:     ignore (E.log "Error on A.ONLYTYPEDEF (%s)\n"
  5228:               (Printexc.to_string e));
  5229:     cabsPushGlobal (GAsm ("booo_typedef", !currentLoc))
  5230:   end
  5231: 
  5232: and assignInit (lv: lval)
  5233:                (ie: init)
  5234:                (iet: typ)
  5235:                (acc: chunk) : chunk =
  5236:   match ie with
  5237:     SingleInit e ->
  5238:       let (_, e'') = castTo iet (typeOfLval lv) e in
  5239:       acc +++ (Set(lv, e'', !currentLoc))
  5240:   | CompoundInit (t, initl) ->
  5241:       foldLeftCompound
  5242:         ~doinit:(fun off i it acc ->
  5243:           assignInit (addOffsetLval off lv) i it acc)
  5244:         ~ct:t
  5245:         ~initl:initl
  5246:         ~acc:acc
  5247: (*
  5248:   | ArrayInit (bt, len, initl) ->
  5249:       let idx = ref ( -1 ) in
  5250:       List.fold_left
  5251:         (fun acc i ->
  5252:           assignInit (addOffsetLval (Index(integer !idx, NoOffset)) lv) i bt acc)
  5253:         acc
  5254:         initl
  5255: *)
  5256:   (* Now define the processors for body and statement *)
  5257: and doBody (blk: A.block) : chunk =
  5258:   enterScope ();
  5259:   (* Rename the labels and add them to the environment *)
  5260:   List.iter (fun l -> ignore (genNewLocalLabel l)) blk.blabels;
  5261:   (* See if we have some attributes *)
  5262:   let battrs = doAttributes blk.A.battrs in
  5263: 
  5264:   let bodychunk =
  5265:     afterConversion
  5266:       (List.fold_left   (* !!! @ evaluates its arguments backwards *)
  5267:          (fun prev s -> let res = doStatement s in prev @@ res)
  5268:          empty
  5269:          blk.A.bstmts)
  5270:   in
  5271:   exitScope ();
  5272:   if battrs = [] then
  5273:     bodychunk
  5274:   else begin
  5275:     let b = c2block bodychunk in
  5276:     b.battrs <- battrs;
  5277:     s2c (mkStmt (Block b))
  5278:   end
  5279: 
  5280: and doStatement (s : A.statement) : chunk =
  5281:   try
  5282:     match s with
  5283:       A.NOP _ -> skipChunk
  5284:     | A.COMPUTATION (e, loc) ->
  5285:         currentLoc := convLoc loc;
  5286:         let (lasts, data) = !gnu_body_result in
  5287:         if lasts == s then begin      (* This is the last in a GNU_BODY *)
  5288:           let (s', e', t') = doExp false e (AExp None) in
  5289:           data := Some (e', t');      (* Record the result *)
  5290:           s'
  5291:         end else
  5292:           let (s', _, _) = doExp false e ADrop in
  5293:             (* drop the side-effect free expression *)
  5294:             (* And now do some peep-hole optimizations *)
  5295:           s'
  5296: 
  5297:     | A.BLOCK (b, loc) ->
  5298:         currentLoc := convLoc loc;
  5299:         doBody b
  5300: 
  5301:     | A.SEQUENCE (s1, s2, loc) ->
  5302:         (doStatement s1) @@ (doStatement s2)
  5303: 
  5304:     | A.IF(e,st,sf,loc) ->
  5305:         let st' = doStatement st in
  5306:         let sf' = doStatement sf in
  5307:         currentLoc := convLoc loc;
  5308:         doCondition false e st' sf'
  5309: 
  5310:     | A.WHILE(e,s,loc) ->
  5311:         startLoop true;
  5312:         let s' = doStatement s in
  5313:         exitLoop ();
  5314:         let loc' = convLoc loc in
  5315:         currentLoc := loc';
  5316:         loopChunk ((doCondition false e skipChunk
  5317:                       (breakChunk loc'))
  5318:                    @@ s')
  5319: 
  5320:     | A.DOWHILE(e,s,loc) ->
  5321:         startLoop false;
  5322:         let s' = doStatement s in
  5323:         let loc' = convLoc loc in
  5324:         currentLoc := loc';
  5325:         let s'' =
  5326:           consLabContinue (doCondition false e skipChunk (breakChunk loc'))
  5327:         in
  5328:         exitLoop ();
  5329:         loopChunk (s' @@ s'')
  5330: 
  5331:     | A.FOR(fc1,e2,e3,s,loc) -> begin
  5332:         let loc' = convLoc loc in
  5333:         currentLoc := loc';
  5334:         enterScope (); (* Just in case we have a declaration *)
  5335:         let (se1, _, _) =
  5336:           match fc1 with
  5337:             FC_EXP e1 -> doExp false e1 ADrop
  5338:           | FC_DECL d1 -> (doDecl false d1, zero, voidType)
  5339:         in
  5340:         let (se3, _, _) = doExp false e3 ADrop in
  5341:         startLoop false;
  5342:         let s' = doStatement s in
  5343:         currentLoc := loc';
  5344:         let s'' = consLabContinue se3 in
  5345:         exitLoop ();
  5346:         let res =
  5347:           match e2 with
  5348:             A.NOTHING -> (* This means true *)
  5349:               se1 @@ loopChunk (s' @@ s'')
  5350:           | _ ->
  5351:               se1 @@ loopChunk ((doCondition false e2 skipChunk (breakChunk loc'))
  5352:                                 @@ s' @@ s'')
  5353:         in
  5354:         exitScope ();
  5355:         res
  5356:     end
  5357:     | A.BREAK loc ->
  5358:         let loc' = convLoc loc in
  5359:         currentLoc := loc';
  5360:         breakChunk loc'
  5361: 
  5362:     | A.CONTINUE loc ->
  5363:         let loc' = convLoc loc in
  5364:         currentLoc := loc';
  5365:         continueOrLabelChunk loc'
  5366: 
  5367:     | A.RETURN (A.NOTHING, loc) ->
  5368:         let loc' = convLoc loc in
  5369:         currentLoc := loc';
  5370:         (match !currentReturnType with
  5371:            TVoid _ -> ()
  5372:           | _ ->
  5373:             ignore (warn "Return statement without a value in function returning %a\n" d_type !currentReturnType));
  5374:         returnChunk None loc'
  5375: 
  5376:     | A.RETURN (e, loc) -> begin
  5377:         let loc' = convLoc loc in
  5378:         currentLoc := loc';
  5379:         (* Sometimes we return the result of a void function call *)
  5380:         match !currentReturnType with
  5381:           TVoid _ ->
  5382:             ignore (warn "Return statement with a value in function returning void");
  5383:             let (se, _, _) = doExp false e ADrop in
  5384:             se @@ returnChunk None loc'
  5385:         | _ ->
  5386:             let (se, e', et) =
  5387:               doExp false e (AExp (Some !currentReturnType)) in
  5388:             let (et'', e'') = castTo et (!currentReturnType) e' in
  5389:             se @@ (returnChunk (Some e'') loc')
  5390:     end
  5391: 
  5392:     | A.SWITCH (e, s, loc) ->
  5393:         let loc' = convLoc loc in
  5394:         currentLoc := loc';
  5395:         let (se, e', et) = doExp false e (AExp (Some intType)) in
  5396:         let (et'', e'') = castTo et intType e' in
  5397:         let s' = doStatement s in
  5398:         se @@ (switchChunk e'' s' loc')
  5399: 
  5400:     | A.CASE (e, s, loc) ->
  5401:         let loc' = convLoc loc in
  5402:         currentLoc := loc';
  5403:         let (se, e', et) = doExp false e (AExp None) in
  5404:         if isNotEmpty se then
  5405:           E.s (error "Case statement with a non-constant");
  5406:         caseRangeChunk [constFold false e'] loc' (doStatement s)
  5407: 
  5408:     | A.CASERANGE (el, eh, s, loc) ->
  5409:         let loc' = convLoc loc in
  5410:         currentLoc := loc';
  5411:         let (sel, el', etl) = doExp false el (AExp None) in
  5412:         let (seh, eh', etl) = doExp false eh (AExp None) in
  5413:         if isNotEmpty sel || isNotEmpty seh then
  5414:           E.s (error "Case statement with a non-constant");
  5415:         let il, ih =
  5416:           match constFold true el', constFold true eh' with
  5417:             Const(CInt64(il, _, _)), Const(CInt64(ih, _, _)) ->
  5418:               Int64.to_int il, Int64.to_int ih
  5419:           | _ -> E.s (unimp "Cannot understand the constants in case range")
  5420:         in
  5421:         if il > ih then
  5422:           E.s (error "Empty case range");
  5423:         let rec mkAll (i: int) =
  5424:           if i > ih then [] else integer i :: mkAll (i + 1)
  5425:         in
  5426:         caseRangeChunk (mkAll il) loc' (doStatement s)
  5427: 
  5428: 
  5429:     | A.DEFAULT (s, loc) ->
  5430:         let loc' = convLoc loc in
  5431:         currentLoc := loc';
  5432:         defaultChunk loc' (doStatement s)
  5433: 
  5434:     | A.LABEL (l, s, loc) ->
  5435:         let loc' = convLoc loc in
  5436:         currentLoc := loc';
  5437:         (* Lookup the label because it might have been locally defined *)
  5438:         consLabel (lookupLabel l) (doStatement s) loc' true
  5439: 
  5440:     | A.GOTO (l, loc) ->
  5441:         let loc' = convLoc loc in
  5442:         currentLoc := loc';
  5443:         (* Maybe we need to rename this label *)
  5444:         gotoChunk (lookupLabel l) loc'
  5445: 
  5446:     | A.COMPGOTO (e, loc) -> begin
  5447:         let loc' = convLoc loc in
  5448:         currentLoc := loc';
  5449:         (* Do the expression *)
  5450:         let se, e', t' = doExp false e (AExp (Some voidPtrType)) in
  5451:         match !gotoTargetData with
  5452:           Some (switchv, switch) -> (* We have already generated this one  *)
  5453:             se
  5454:             @@ i2c(Set (var switchv, mkCast e' uintType, loc'))
  5455:             @@ s2c(mkStmt(Goto (ref switch, loc')))
  5456: 
  5457:         | None -> begin
  5458:             (* Make a temporary variable *)
  5459:             let vchunk = createLocal
  5460:                 (TInt(IUInt, []), NoStorage, false, [])
  5461:                 (("__compgoto", A.JUSTBASE, [], loc), A.NO_INIT)
  5462:             in
  5463:             if not (isEmpty vchunk) then
  5464:               E.s (unimp "Non-empty chunk in creating temporary for goto *");
  5465:             let switchv, _ =
  5466:               try lookupVar "__compgoto"
  5467:               with Not_found -> E.s (bug "Cannot find temporary for goto *");
  5468:             in
  5469:             (* Make a switch statement. We'll fill in the statements at the
  5470:             * end of the function *)
  5471:             let switch = mkStmt (Switch (Lval(var switchv),
  5472:                                          mkBlock [], [], loc')) in
  5473:             (* And make a label for it since we'll goto it *)
  5474:             switch.labels <- [Label ("__docompgoto", loc', false)];
  5475:             gotoTargetData := Some (switchv, switch);
  5476:             se @@ i2c (Set(var switchv, mkCast e' uintType, loc')) @@
  5477:             s2c switch
  5478:         end
  5479:       end
  5480: 
  5481:     | A.DEFINITION d ->
  5482:         doDecl false d
  5483: 
  5484:     | A.ASM (asmattr, tmpls, outs, ins, clobs, loc) ->
  5485:         (* Make sure all the outs are variables *)
  5486:         let loc' = convLoc loc in
  5487:         let attr' = doAttributes asmattr in
  5488:         currentLoc := loc';
  5489:         let temps : (lval * varinfo) list ref = ref [] in
  5490:         let stmts : chunk ref = ref empty in
  5491:         let outs' =
  5492:           List.map
  5493:             (fun (c, e) ->
  5494:               let (se, e', t) = doExp false e (AExp None) in
  5495:               let lv =
  5496:                 match e' with
  5497:                 | Lval lval
  5498:                 | StartOf lval -> lval
  5499:                 | _ -> E.s (error "Expected lval for ASM outputs")
  5500:               in
  5501:               stmts := !stmts @@ se;
  5502:               (c, lv)) outs
  5503:         in
  5504:       (* Get the side-effects out of expressions *)
  5505:         let ins' =
  5506:           List.map
  5507:             (fun (c, e) ->
  5508:               let (se, e', et) = doExp false e (AExp None) in
  5509:               stmts := !stmts @@ se;
  5510:               (c, e'))
  5511:             ins
  5512:         in
  5513:         !stmts @@
  5514:         (i2c (Asm(attr', tmpls, outs', ins', clobs, loc')))
  5515: 
  5516:     | TRY_FINALLY (b, h, loc) ->
  5517:         let loc' = convLoc loc in
  5518:         currentLoc := loc';
  5519:         let b': chunk = doBody b in
  5520:         let h': chunk = doBody h in
  5521:         if b'.cases <> [] || h'.cases <> [] then
  5522:           E.s (error "Try statements cannot contain switch cases");
  5523: 
  5524:         s2c (mkStmt (TryFinally (c2block b', c2block h', loc')))
  5525: 
  5526:     | TRY_EXCEPT (b, e, h, loc) ->
  5527:         let loc' = convLoc loc in
  5528:         currentLoc := loc';
  5529:         let b': chunk = doBody b in
  5530:         (* Now do e *)
  5531:         let ((se: chunk), e', t') = doExp false e (AExp None) in
  5532:         let h': chunk = doBody h in
  5533:         if b'.cases <> [] || h'.cases <> [] || se.cases <> [] then
  5534:           E.s (error "Try statements cannot contain switch cases");
  5535:         (* Now take se and try to convert it to a list of instructions. This
  5536:          * might not be always possible *)
  5537:         let il' =
  5538:           match compactStmts se.stmts with
  5539:             [] -> se.postins
  5540:           | [ s ] -> begin
  5541:               match s.skind with
  5542:                 Instr il -> il @ se.postins
  5543:               | _ -> E.s (error "Except expression contains unexpected statement")
  5544:             end
  5545:           | _ -> E.s (error "Except expression contains too many statements")
  5546:         in
  5547:         s2c (mkStmt (TryExcept (c2block b', (il', e'), c2block h', loc')))
  5548: 
  5549:   with e -> begin
  5550:     (ignore (E.log "Error in doStatement (%s)\n" (Printexc.to_string e)));
  5551:     consLabel "booo_statement" empty (convLoc (get_statementloc s)) false
  5552:   end
  5553: 
  5554: 
  5555: (* Translate a file *)
  5556: let convFile ((fname : string), (dl : Flx_cil_cabs.definition list)) : Flx_cil_cil.file =
  5557:   (* Clean up the global types *)
  5558:   E.hadErrors := false;
  5559:   initGlobals();
  5560:   startFile ();
  5561:   H.clear compInfoNameEnv;
  5562:   H.clear enumInfoNameEnv;
  5563:   H.clear mustTurnIntoDef;
  5564:   H.clear alreadyDefined;
  5565:   H.clear staticLocals;
  5566:   H.clear typedefs;
  5567:   H.clear isomorphicStructs;
  5568:   annonCompFieldNameId := 0;
  5569:   if !E.verboseFlag || !Flx_cil_cilutil.printStages then
  5570:     ignore (E.log "Converting CABS->CIL\n");
  5571:   (* Setup the built-ins, but do not add their prototypes to the file *)
  5572:   let setupBuiltin name (resTyp, argTypes, isva) =
  5573:     let v =
  5574:       makeGlobalVar name (TFun(resTyp,
  5575:                                Some (List.map (fun at -> ("", at, []))
  5576:                                        argTypes),
  5577:                                isva, [])) in
  5578:     ignore (alphaConvertVarAndAddToEnv true v)
  5579:   in
  5580:   H.iter setupBuiltin (if !msvcMode then msvcBuiltins else gccBuiltins);
  5581: 
  5582:   let globalidx = ref 0 in
  5583:   let doOneGlobal (d: A.definition) =
  5584:     let s = doDecl true d in
  5585:     if isNotEmpty s then
  5586:       E.s (bug "doDecl returns non-empty statement for global");
  5587:     (* See if this is one of the globals which we can leave alone. Increment
  5588:      * globalidx and see if we must leave this alone. *)
  5589:     if
  5590:       (match d with
  5591:         A.DECDEF _ -> true
  5592:       | A.FUNDEF _ -> true
  5593:       | _ -> false) && (incr globalidx; !globalidx = !nocil) then begin
  5594:           (* Create a file where we put the CABS output *)
  5595:           let temp_cabs_name = "__temp_cabs" in
  5596:           let temp_cabs = open_out temp_cabs_name in
  5597:           (* Now print the CABS in there *)
  5598:           Flx_cil_cprint.commit (); Flx_cil_cprint.flush ();
  5599:           let old = !Flx_cil_cprint.out in (* Save the old output channel *)
  5600:           Flx_cil_cprint.out := temp_cabs;
  5601:           Flx_cil_cprint.print_def d;
  5602:           Flx_cil_cprint.commit (); Flx_cil_cprint.flush ();
  5603:           flush !Flx_cil_cprint.out;
  5604:           Flx_cil_cprint.out := old;
  5605:           close_out temp_cabs;
  5606:           (* Now read everythign in *and create a GText from it *)
  5607:           let temp_cabs = open_in temp_cabs_name in
  5608:           let buff = Buffer.create 1024 in
  5609:           Buffer.add_string buff "// Start of CABS form\n";
  5610:           Buffer.add_channel buff temp_cabs (in_channel_length temp_cabs);
  5611:           Buffer.add_string buff "// End of CABS form\n";
  5612:           close_in temp_cabs;
  5613:           (* Try to pop the last thing in the file *)
  5614:           (match !theFile with
  5615:             _ :: rest -> theFile := rest
  5616:           | _ -> ());
  5617:           (* Insert in the file a GText *)
  5618:           cabsPushGlobal (GText(Buffer.contents buff))
  5619:     end
  5620:   in
  5621:   List.iter doOneGlobal dl;
  5622:   let globals = ref (popGlobals ()) in
  5623: 
  5624:   H.clear noProtoFunctions;
  5625:   H.clear mustTurnIntoDef;
  5626:   H.clear alreadyDefined;
  5627:   H.clear compInfoNameEnv;
  5628:   H.clear enumInfoNameEnv;
  5629:   H.clear isomorphicStructs;
  5630:   H.clear staticLocals;
  5631:   H.clear typedefs;
  5632:   H.clear env;
  5633:   H.clear genv;
  5634:   if false then ignore (E.log "Flx_cil_cabs2cil converted %d globals\n" !globalidx);
  5635:   (* We are done *)
  5636:   { fileName = fname;
  5637:     globals  = !globals;
  5638:     globinit = None;
  5639:     globinitcalled = false;
  5640:   }
  5641: 
End ocaml section to src/flx_cil_cabs2cil.ml[1]
Start ocaml section to src/flx_cil_cabs2cil.mli[1 /1 ]
     1: # 19813 "./lpsrc/flx_cil.ipk"
     2: val convFile: Flx_cil_cabs.file -> Flx_cil_cil.file
     3: 
     4: (* Set this integer to the index of the global to be left in CABS form. Use
     5:  * -1 to disable *)
     6: val nocil: int ref
     7: 
     8: (* Indicates whether we're allowed to duplicate small chunks of code. *)
     9: val allowDuplication: bool ref
    10: 
End ocaml section to src/flx_cil_cabs2cil.mli[1]
Start ocaml section to src/flx_cil_patch.ml[1 /1 ]
     1: # 19824 "./lpsrc/flx_cil.ipk"
     2: 
     3: 
     4: (* patch.ml *)
     5: (* CABS file patching *)
     6: 
     7: open Flx_cil_cabs
     8: open Flx_cil_cabs_helper
     9: open Flx_cil_trace
    10: open Flx_cil_pretty
    11: open Flx_cil_cabsvisit
    12: 
    13: (* binding of a unification variable to a syntactic construct *)
    14: type binding =
    15:   | BSpecifier of string * spec_elem list
    16:   | BName of string * string
    17:   | BExpr of string * expression
    18: 
    19: (* thrown when unification fails *)
    20: exception NoMatch
    21: 
    22: (* thrown when an attempt to find the associated binding fails *)
    23: exception BadBind of string
    24: 
    25: (* trying to isolate performance problems; will hide all the *)
    26: (* potentially expensive debugging output behind "if verbose .." *)
    27: let verbose : bool = true
    28: 
    29: 
    30: (* raise NoMatch if x and y are not equal *)
    31: let mustEq (x : 'a) (y : 'a) : unit =
    32: begin
    33:   if (x <> y) then (
    34:     if verbose then
    35:       (trace "patchDebug" (dprintf "mismatch by structural disequality\n"));
    36:     raise NoMatch
    37:   )
    38: end
    39: 
    40: (* why isn't this in the core Ocaml library? *)
    41: let identity x = x
    42: 
    43: 
    44: let isPatternVar (s : string) : bool =
    45: begin
    46:   ((String.length s) >= 1) && ((String.get s 0) = '@')
    47: end
    48: 
    49: (* 's' is actually "@name(blah)"; extract the 'blah' *)
    50: let extractPatternVar (s : string) : string =
    51:   (*(trace "patch" (dprintf "extractPatternVar %s\n" s));*)
    52:   (String.sub s 6 ((String.length s) - 7))
    53: 
    54: 
    55: (* a few debugging printers.. *)
    56: let printExpr (e : expression) =
    57: begin
    58:   if (verbose && traceActive "patchDebug") then (
    59:     Flx_cil_cprint.print_expression e; Flx_cil_cprint.force_new_line ();
    60:     Flx_cil_cprint.flush ()
    61:   )
    62: end
    63: 
    64: let printSpec (spec: spec_elem list) =
    65: begin
    66:   if (verbose && traceActive "patchDebug") then (
    67:     Flx_cil_cprint.print_specifiers spec;  Flx_cil_cprint.force_new_line ();
    68:     Flx_cil_cprint.flush ()
    69:   )
    70: end
    71: 
    72: let printSpecs (pat : spec_elem list) (tgt : spec_elem list) =
    73: begin
    74:   (printSpec pat);
    75:   (printSpec tgt)
    76: end
    77: 
    78: let printDecl (pat : name) (tgt : name) =
    79: begin
    80:   if (verbose && traceActive "patchDebug") then (
    81:     Flx_cil_cprint.print_name pat;  Flx_cil_cprint.force_new_line ();
    82:     Flx_cil_cprint.print_name tgt;  Flx_cil_cprint.force_new_line ();
    83:     Flx_cil_cprint.flush ()
    84:   )
    85: end
    86: 
    87: let printDeclType (pat : decl_type) (tgt : decl_type) =
    88: begin
    89:   if (verbose && traceActive "patchDebug") then (
    90:     Flx_cil_cprint.print_decl "__missing_field_name" pat;  Flx_cil_cprint.force_new_line ();
    91:     Flx_cil_cprint.print_decl "__missing_field_name" tgt;  Flx_cil_cprint.force_new_line ();
    92:     Flx_cil_cprint.flush ()
    93:   )
    94: end
    95: 
    96: let printDefn (d : definition) =
    97: begin
    98:   if (verbose && traceActive "patchDebug") then (
    99:     Flx_cil_cprint.print_def d;
   100:     Flx_cil_cprint.flush ()
   101:   )
   102: end
   103: 
   104: 
   105: (* class to describe how to modify the tree for subtitution *)
   106: class substitutor (bindings : binding list) = object(self)
   107:   inherit nopFlx_cil_cabsVisitor as super
   108: 
   109:   (* look in the binding list for a given name *)
   110:   method findBinding (name : string) : binding =
   111:   begin
   112:     try
   113:       (List.find
   114:         (fun b ->
   115:           match b with
   116:           | BSpecifier(n, _) -> n=name
   117:           | BName(n, _) -> n=name
   118:           | BExpr(n, _) -> n=name)
   119:         bindings)
   120:     with
   121:       Not_found -> raise (BadBind ("name not found: " ^ name))
   122:   end
   123: 
   124:   method vexpr (e:expression) : expression visitAction =
   125:   begin
   126:     match e with
   127:     | EXPR_PATTERN(name) -> (
   128:         match (self#findBinding name) with
   129:         | BExpr(_, expr) -> ChangeTo(expr)    (* substitute bound expression *)
   130:         | _ -> raise (BadBind ("wrong type: " ^ name))
   131:       )
   132:     | _ -> DoChildren
   133:   end
   134: 
   135:   (* use of a name *)
   136:   method vvar (s:string) : string =
   137:   begin
   138:     if (isPatternVar s) then (
   139:       let nameString = (extractPatternVar s) in
   140:       match (self#findBinding nameString) with
   141:       | BName(_, str) -> str        (* substitute *)
   142:       | _ -> raise (BadBind ("wrong type: " ^ nameString))
   143:     )
   144:     else
   145:       s
   146:   end
   147: 
   148:   (* binding introduction of a name *)
   149:   method vname (k: nameKind) (spec: specifier) (n: name) : name visitAction =
   150:   begin
   151:     match n with (s (*variable name*), dtype, attrs, loc) -> (
   152:       let replacement = (self#vvar s) in    (* use replacer from above *)
   153:       if (s <> replacement) then
   154:         ChangeTo(replacement, dtype, attrs, loc)
   155:       else
   156:         DoChildren                          (* no replacement *)
   157:     )
   158:   end
   159: 
   160:   method vspec (specList: specifier) : specifier visitAction =
   161:   begin
   162:     if verbose then (trace "patchDebug" (dprintf "substitutor: vspec\n"));
   163:     (printSpec specList);
   164: 
   165:     (* are any of the specifiers SpecPatterns?  we have to check the entire *)
   166:     (* list, not just the head, because e.g. "typedef @specifier(foo)" has *)
   167:     (* "typedef" as the head of the specifier list *)
   168:     if (List.exists (fun elt -> match elt with
   169:                                 | SpecPattern(_) -> true
   170:                                 | _ -> false)
   171:                     specList) then begin
   172:       (* yes, replace the existing list with one got by *)
   173:       (* replacing all occurrences of SpecPatterns *)
   174:       (trace "patchDebug" (dprintf "at least one spec pattern\n"));
   175:       ChangeTo
   176:         (List.flatten
   177:           (List.map
   178:             (* for each specifier element, yield the specifier list *)
   179:             (* to which it maps; then we'll flatten the final result *)
   180:             (fun elt ->
   181:               match elt with
   182:               | SpecPattern(name) -> (
   183:                   match (self#findBinding name) with
   184:                   | BSpecifier(_, replacement) -> (
   185:                       (trace "patchDebug" (dprintf "replacing pattern %s\n" name));
   186:                       replacement
   187:                     )
   188:                   | _ -> raise (BadBind ("wrong type: " ^ name))
   189:                 )
   190:               | _ -> [elt]    (* leave this one alone *)
   191:             )
   192:             specList
   193:           )
   194:         )
   195:     end
   196:     else
   197:       (* none of the specifiers in specList are patterns *)
   198:       DoChildren
   199:   end
   200: 
   201:   method vtypespec (tspec: typeSpecifier) : typeSpecifier visitAction =
   202:   begin
   203:     match tspec with
   204:     | Tnamed(str) when (isPatternVar str) ->
   205:         ChangeTo(Tnamed(self#vvar str))
   206:     | Tstruct(str, fields, extraAttrs) when (isPatternVar str) -> (
   207:         (trace "patchDebug" (dprintf "substituting %s\n" str));
   208:         ChangeDoChildrenPost(Tstruct((self#vvar str), fields, extraAttrs), identity)
   209:       )
   210:     | Tunion(str, fields, extraAttrs) when (isPatternVar str) ->
   211:         (trace "patchDebug" (dprintf "substituting %s\n" str));
   212:         ChangeDoChildrenPost(Tunion((self#vvar str), fields, extraAttrs), identity)
   213:     | _ -> DoChildren
   214:   end
   215: 
   216: end
   217: 
   218: 
   219: (* why can't I have forward declarations in the language?!! *)
   220: let unifyExprFwd : (expression -> expression -> binding list) ref
   221:   = ref (fun e e -> [])
   222: 
   223: 
   224: (* substitution for expressions *)
   225: let substExpr (bindings : binding list) (expr : expression) : expression =
   226: begin
   227:   if verbose then
   228:     (trace "patchDebug" (dprintf "substExpr with %d bindings\n" (List.length bindings)));
   229:   (printExpr expr);
   230: 
   231:   (* apply the transformation *)
   232:   let result = (visit_cabsExpression (new substitutor bindings :> cabsVisitor) expr) in
   233:   (printExpr result);
   234: 
   235:   result
   236: end
   237: 
   238: let d_loc (_:unit) (loc: cabsloc) : doc =
   239:   text loc.filename ++ chr ':' ++ num loc.lineno
   240: 
   241: 
   242: (* class to describe how to modify the tree when looking for places *)
   243: (* to apply expression transformers *)
   244: class exprTransformer (srcpattern : expression) (destpattern : expression)
   245:                       (patchline : int) (srcloc : cabsloc) = object(self)
   246:   inherit nopFlx_cil_cabsVisitor as super
   247: 
   248:   method vexpr (e:expression) : expression visitAction =
   249:   begin
   250:     (* see if the source pattern matches this subexpression *)
   251:     try (
   252:       let bindings = (!unifyExprFwd srcpattern e) in
   253: 
   254:       (* match! *)
   255:       (trace "patch" (dprintf "expr match: patch line %d, src %a\n"
   256:                               patchline d_loc srcloc));
   257:       ChangeTo(substExpr bindings destpattern)
   258:     )
   259: 
   260:     with NoMatch -> (
   261:       (* doesn't apply *)
   262:       DoChildren
   263:     )
   264:   end
   265: 
   266:   (* other constructs left unchanged *)
   267: end
   268: 
   269: 
   270: let unifyList (pat : 'a list) (tgt : 'a list)
   271:               (unifyElement : 'a -> 'a -> binding list) : binding list =
   272: begin
   273:   if verbose then
   274:     (trace "patchDebug" (dprintf "unifyList (pat len %d, tgt len %d)\n"
   275:                                  (List.length pat) (List.length tgt)));
   276: 
   277:   (* walk down the lists *)
   278:   let rec loop pat tgt : binding list =
   279:     match pat, tgt with
   280:     | [], [] -> []
   281:     | (pelt :: prest), (telt :: trest) ->
   282:          (unifyElement pelt telt) @
   283:          (loop prest trest)
   284:     | _,_ -> (
   285:         (* no match *)
   286:         if verbose then (
   287:           (trace "patchDebug" (dprintf "mismatching list length\n"));
   288:         );
   289:         raise NoMatch
   290:      )
   291:   in
   292:   (loop pat tgt)
   293: end
   294: 
   295: 
   296: let gettime () : float =
   297:   (Unix.times ()).Unix.tms_utime
   298: 
   299: let rec applyFlx_cil_patch (patchFile : file) (srcFile : file) : file =
   300: begin
   301:   let patch : definition list = (snd patchFile) in
   302:   let srcFname : string = (fst srcFile) in
   303:   let src : definition list = (snd srcFile) in
   304: 
   305:   (trace "patchTime" (dprintf "applyFlx_cil_patch start: %f\n" (gettime ())));
   306:   if (traceActive "patchDebug") then
   307:     Flx_cil_cprint.out := stdout      (* hack *)
   308:   else ();
   309: 
   310:   (* more hackery *)
   311:   unifyExprFwd := unifyExpr;
   312: 
   313:   (* patch a single source definition, yield transformed *)
   314:   let rec patchDefn (patch : definition list) (d : definition) : definition list =
   315:   begin
   316:     match patch with
   317:     | TRANSFORMER(srcpattern, destpattern, loc) :: rest -> (
   318:         if verbose then
   319:           (trace "patchDebug"
   320:             (dprintf "considering applying defn pattern at line %d to src at %a\n"
   321:                      loc.lineno d_loc (get_definitionloc d)));
   322: 
   323:         (* see if the source pattern matches the definition 'd' we have *)
   324:         try (
   325:           let bindings = (unifyDefn srcpattern d) in
   326: 
   327:           (* we have a match!  apply the substitutions *)
   328:           (trace "patch" (dprintf "defn match: patch line %d, src %a\n"
   329:                                   loc.lineno d_loc (get_definitionloc d)));
   330: 
   331:           (List.map (fun destElt -> (substDefn bindings destElt)) destpattern)
   332:         )
   333: 
   334:         with NoMatch -> (
   335:           (* no match, continue down list *)
   336:           (*(trace "patch" (dprintf "no match\n"));*)
   337:           (patchDefn rest d)
   338:         )
   339:       )
   340: 
   341:     | EXPRTRANSFORMER(srcpattern, destpattern, loc) :: rest -> (
   342:         if verbose then
   343:           (trace "patchDebug"
   344:             (dprintf "considering applying expr pattern at line %d to src at %a\n"
   345:                      loc.lineno d_loc (get_definitionloc d)));
   346: 
   347:         (* walk around in 'd' looking for expressions to modify *)
   348:         let dList = (visit_cabsDefinition
   349:                       ((new exprTransformer srcpattern destpattern
   350:                                             loc.lineno (get_definitionloc d))
   351:                        :> cabsVisitor)
   352:                       d
   353:                     ) in
   354: 
   355:         (* recursively invoke myself to try additional patches *)
   356:         (* since visit_cabsDefinition might return a list, I'll try my *)
   357:         (* addtional patches on every yielded definition, then collapse *)
   358:         (* all of them into a single list *)
   359:         (List.flatten (List.map (fun d -> (patchDefn rest d)) dList))
   360:       )
   361: 
   362:     | _ :: rest -> (
   363:         (* not a transformer; just keep going *)
   364:         (patchDefn rest d)
   365:       )
   366:     | [] -> (
   367:         (* reached the end of the patch file with no match *)
   368:         [d]     (* have to wrap it in a list ... *)
   369:       )
   370:   end in
   371: 
   372:   (* transform all the definitions *)
   373:   let result : definition list =
   374:     (List.flatten (List.map (fun d -> (patchDefn patch d)) src)) in
   375: 
   376:   (*Flx_cil_cprint.print_defs result;*)
   377: 
   378:   if (traceActive "patchDebug") then (
   379:     (* avoid flush bug? yes *)
   380:     Flx_cil_cprint.force_new_line ();
   381:     Flx_cil_cprint.flush ()
   382:   );
   383: 
   384:   (trace "patchTime" (dprintf "applyFlx_cil_patch finish: %f\n" (gettime ())));
   385:   (srcFname, result)
   386: end
   387: 
   388: 
   389: (* given a definition pattern 'pat', and a target concrete defintion 'tgt', *)
   390: (* determine if they can be unified; if so, return the list of bindings of *)
   391: (* unification variables in pat; otherwise raise NoMatch *)
   392: and unifyDefn (pat : definition) (tgt : definition) : binding list =
   393: begin
   394:   match pat, tgt with
   395:   | DECDEF((pspecifiers, pdeclarators), _),
   396:     DECDEF((tspecifiers, tdeclarators), _) -> (
   397:       if verbose then
   398:         (trace "patchDebug" (dprintf "unifyDefn of DECDEFs\n"));
   399:       (unifySpecifiers pspecifiers tspecifiers) @
   400:       (unifyInitDeclarators pdeclarators tdeclarators)
   401:     )
   402: 
   403:   | TYPEDEF((pspec, pdecl), _),
   404:     TYPEDEF((tspec, tdecl), _) -> (
   405:       if verbose then
   406:         (trace "patchDebug" (dprintf "unifyDefn of TYPEDEFs\n"));
   407:       (unifySpecifiers pspec tspec) @
   408:       (unifyDeclarators pdecl tdecl)
   409:     )
   410: 
   411:   | ONLYTYPEDEF(pspec, _),
   412:     ONLYTYPEDEF(tspec, _) -> (
   413:       if verbose then
   414:         (trace "patchDebug" (dprintf "unifyDefn of ONLYTYPEDEFs\n"));
   415:       (unifySpecifiers pspec tspec)
   416:     )
   417: 
   418:   | _, _ -> (
   419:       if verbose then
   420:         (trace "patchDebug" (dprintf "mismatching definitions\n"));
   421:       raise NoMatch
   422:     )
   423: end
   424: 
   425: and unifySpecifier (pat : spec_elem) (tgt : spec_elem) : binding list =
   426: begin
   427:   if verbose then
   428:     (trace "patchDebug" (dprintf "unifySpecifier\n"));
   429:   (printSpecs [pat] [tgt]);
   430: 
   431:   if (pat = tgt) then [] else
   432: 
   433:   match pat, tgt with
   434:   | SpecType(tspec1), SpecType(tspec2) ->
   435:       (unifyTypeSpecifier tspec1 tspec2)
   436:   | SpecPattern(name), _ ->
   437:       (* record that future occurrances of @specifier(name) will yield this specifier *)
   438:       if verbose then
   439:         (trace "patchDebug" (dprintf "found specifier match for %s\n" name));
   440:       [BSpecifier(name, [tgt])]
   441:   | _,_ -> (
   442:       (* no match *)
   443:       if verbose then (
   444:         (trace "patchDebug" (dprintf "mismatching specifiers\n"));
   445:       );
   446:       raise NoMatch
   447:    )
   448: end
   449: 
   450: and unifySpecifiers (pat : spec_elem list) (tgt : spec_elem list) : binding list =
   451: begin
   452:   if verbose then
   453:     (trace "patchDebug" (dprintf "unifySpecifiers\n"));
   454:   (printSpecs pat tgt);
   455: 
   456:   (* canonicalize the specifiers by sorting them *)
   457:   let pat' = (List.stable_sort compare pat) in
   458:   let tgt' = (List.stable_sort compare tgt) in
   459: 
   460:   (* if they are equal, they match with no further checking *)
   461:   if (pat' = tgt') then [] else
   462: 
   463:   (* walk down the lists; don't walk the sorted lists because the *)
   464:   (* pattern must always be last, if it occurs *)
   465:   let rec loop pat tgt : binding list =
   466:     match pat, tgt with
   467:     | [], [] -> []
   468:     | [SpecPattern(name)], _ ->
   469:         (* final SpecPattern matches anything which comes after *)
   470:         (* record that future occurrences of @specifier(name) will yield this specifier *)
   471:         if verbose then
   472:           (trace "patchDebug" (dprintf "found specifier match for %s\n" name));
   473:         [BSpecifier(name, tgt)]
   474:     | (pspec :: prest), (tspec :: trest) ->
   475:          (unifySpecifier pspec tspec) @
   476:          (loop prest trest)
   477:     | _,_ -> (
   478:         (* no match *)
   479:         if verbose then (
   480:           (trace "patchDebug" (dprintf "mismatching specifier list length\n"));
   481:         );
   482:         raise NoMatch
   483:      )
   484:   in
   485:   (loop pat tgt)
   486: end
   487: 
   488: and unifyTypeSpecifier (pat: typeSpecifier) (tgt: typeSpecifier) : binding list =
   489: begin
   490:   if verbose then
   491:     (trace "patchDebug" (dprintf "unifyTypeSpecifier\n"));
   492: 
   493:   if (pat = tgt) then [] else
   494: 
   495:   match pat, tgt with
   496:   | Tnamed(s1), Tnamed(s2) -> (unifyString s1 s2)
   497:   | Tstruct(name1, None, _), Tstruct(name2, None, _) ->
   498:       (unifyString name1 name2)
   499:   | Tstruct(name1, Some(fields1), _), Tstruct(name2, Some(fields2), _) ->
   500:       (* ignoring extraAttrs b/c we're just trying to come up with a list
   501:        * of substitutions, and there's no unify_attributes function, and
   502:        * I don't care at this time about checking that they are equal .. *)
   503:       (unifyString name1 name2) @
   504:       (unifyList fields1 fields2 unifyField)
   505:   | Tunion(name1, None, _), Tstruct(name2, None, _) ->
   506:       (unifyString name1 name2)
   507:   | Tunion(name1, Some(fields1), _), Tunion(name2, Some(fields2), _) ->
   508:       (unifyString name1 name2) @
   509:       (unifyList fields1 fields2 unifyField)
   510:   | Tenum(name1, None, _), Tenum(name2, None, _) ->
   511:       (unifyString name1 name2)
   512:   | Tenum(name1, Some(items1), _), Tenum(name2, Some(items2), _) ->
   513:       (mustEq items1 items2);    (* enum items *)
   514:       (unifyString name1 name2)
   515:   | TtypeofE(exp1), TtypeofE(exp2) ->
   516:       (unifyExpr exp1 exp2)
   517:   | TtypeofT(spec1, dtype1), TtypeofT(spec2, dtype2) ->
   518:       (unifySpecifiers spec1 spec2) @
   519:       (unifyDeclType dtype1 dtype2)
   520:   | _ -> (
   521:       if verbose then (trace "patchDebug" (dprintf "mismatching typeSpecifiers\n"));
   522:       raise NoMatch
   523:     )
   524: end
   525: 
   526: and unifyField (pat : field_group) (tgt : field_group) : binding list =
   527: begin
   528:   match pat,tgt with (spec1, list1), (spec2, list2) -> (
   529:     (unifySpecifiers spec1 spec2) @
   530:     (unifyList list1 list2 unifyNameExprOpt)
   531:   )
   532: end
   533: 
   534: and unifyNameExprOpt (pat : name * expression option)
   535:                      (tgt : name * expression option) : binding list =
   536: begin
   537:   match pat,tgt with
   538:   | (name1, None), (name2, None) -> (unifyName name1 name2)
   539:   | (name1, Some(exp1)), (name2, Some(exp2)) ->
   540:       (unifyName name1 name2) @
   541:       (unifyExpr exp1 exp2)
   542:   | _,_ -> []
   543: end
   544: 
   545: and unifyName (pat : name) (tgt : name) : binding list =
   546: begin
   547:   match pat,tgt with (pstr, pdtype, pattrs, ploc), (tstr, tdtype, tattrs, tloc) ->
   548:     (mustEq pattrs tattrs);
   549:     (unifyString pstr tstr) @
   550:     (unifyDeclType pdtype tdtype)
   551: end
   552: 
   553: and unifyInitDeclarators (pat : init_name list) (tgt : init_name list) : binding list =
   554: begin
   555:   (*
   556:     if verbose then
   557:       (trace "patchDebug" (dprintf "unifyInitDeclarators, pat %d, tgt %d\n"
   558:                                    (List.length pat) (List.length tgt)));
   559:   *)
   560: 
   561:   match pat, tgt with
   562:   | ((pdecl, piexpr) :: prest),
   563:     ((tdecl, tiexpr) :: trest) ->
   564:       (unifyDeclarator pdecl tdecl) @
   565:       (unifyInitExpr piexpr tiexpr) @
   566:       (unifyInitDeclarators prest trest)
   567:   | [], [] -> []
   568:   | _, _ -> (
   569:       if verbose then
   570:         (trace "patchDebug" (dprintf "mismatching init declarators\n"));
   571:       raise NoMatch
   572:     )
   573: end
   574: 
   575: and unifyDeclarators (pat : name list) (tgt : name list) : binding list =
   576:   (unifyList pat tgt unifyDeclarator)
   577: 
   578: and unifyDeclarator (pat : name) (tgt : name) : binding list =
   579: begin
   580:   if verbose then
   581:     (trace "patchDebug" (dprintf "unifyDeclarator\n"));
   582:   (printDecl pat tgt);
   583: 
   584:   match pat, tgt with
   585:   | (pname, pdtype, pattr, ploc),
   586:     (tname, tdtype, tattr, tloc) ->
   587:       (mustEq pattr tattr);
   588:       (unifyDeclType pdtype tdtype) @
   589:       (unifyString pname tname)
   590: end
   591: 
   592: and unifyDeclType (pat : decl_type) (tgt : decl_type) : binding list =
   593: begin
   594:   if verbose then
   595:     (trace "patchDebug" (dprintf "unifyDeclType\n"));
   596:   (printDeclType pat tgt);
   597: 
   598:   match pat, tgt with
   599:   | JUSTBASE, JUSTBASE -> []
   600:   | PARENTYPE(pattr1, ptype, pattr2),
   601:     PARENTYPE(tattr1, ttype, tattr2) ->
   602:       (mustEq pattr1 tattr1);
   603:       (mustEq pattr2 tattr2);
   604:       (unifyDeclType ptype ttype)
   605:   | ARRAY(ptype, pattr, psz),
   606:     ARRAY(ttype, tattr, tsz) ->
   607:       (mustEq pattr tattr);
   608:       (unifyDeclType ptype ttype) @
   609:       (unifyExpr psz tsz)
   610:   | PTR(pattr, ptype),
   611:     PTR(tattr, ttype) ->
   612:       (mustEq pattr tattr);
   613:       (unifyDeclType ptype ttype)
   614:   | PROTO(ptype, pformals, pva),
   615:     PROTO(ttype, tformals, tva) ->
   616:       (mustEq pva tva);
   617:       (unifyDeclType ptype ttype) @
   618:       (unifySingleNames pformals tformals)
   619:   | _ -> (
   620:       if verbose then
   621:         (trace "patchDebug" (dprintf "mismatching decl_types\n"));
   622:       raise NoMatch
   623:     )
   624: end
   625: 
   626: and unifySingleNames (pat : single_name list) (tgt : single_name list) : binding list =
   627: begin
   628:   if verbose then
   629:     (trace "patchDebug" (dprintf "unifySingleNames, pat %d, tgt %d\n"
   630:                                  (List.length pat) (List.length tgt)));
   631: 
   632:   match pat, tgt with
   633:   | [], [] -> []
   634:   | (pspec, pdecl) :: prest,
   635:     (tspec, tdecl) :: trest ->
   636:       (unifySpecifiers pspec tspec) @
   637:       (unifyDeclarator pdecl tdecl) @
   638:       (unifySingleNames prest trest)
   639:   | _, _ -> (
   640:       if verbose then
   641:         (trace "patchDebug" (dprintf "mismatching single_name lists\n"));
   642:       raise NoMatch
   643:     )
   644: end
   645: 
   646: and unifyString (pat : string) (tgt : string) : binding list =
   647: begin
   648:   (* equal? match with no further ado *)
   649:   if (pat = tgt) then [] else
   650: 
   651:   (* is the pattern a variable? *)
   652:   if (isPatternVar pat) then
   653:     (* pat is actually "@name(blah)"; extract the 'blah' *)
   654:     let varname = (extractPatternVar pat) in
   655: 
   656:     (* when substituted, this name becomes 'tgt' *)
   657:     if verbose then
   658:       (trace "patchDebug" (dprintf "found name match for %s\n" varname));
   659:     [BName(varname, tgt)]
   660: 
   661:   else (
   662:     if verbose then
   663:       (trace "patchDebug" (dprintf "mismatching names: %s and %s\n" pat tgt));
   664:     raise NoMatch
   665:   )
   666: end
   667: 
   668: and unifyExpr (pat : expression) (tgt : expression) : binding list =
   669: begin
   670:   (* if they're equal, that's good enough *)
   671:   if (pat = tgt) then [] else
   672: 
   673:   (* shorter name *)
   674:   let ue = unifyExpr in
   675: 
   676:   (* because of the equality check above, I can omit some cases *)
   677:   match pat, tgt with
   678:   | UNARY(pop, pexpr),
   679:     UNARY(top, texpr) ->
   680:       (mustEq pop top);
   681:       (ue pexpr texpr)
   682:   | BINARY(pop, pexp1, pexp2),
   683:     BINARY(top, texp1, texp2) ->
   684:       (mustEq pop top);
   685:       (ue pexp1 texp1) @
   686:       (ue pexp2 texp2)
   687:   | QUESTION(p1, p2, p3),
   688:     QUESTION(t1, t2, t3) ->
   689:       (ue p1 t1) @
   690:       (ue p2 t2) @
   691:       (ue p3 t3)
   692:   | CAST((pspec, ptype), piexpr),
   693:     CAST((tspec, ttype), tiexpr) ->
   694:       (mustEq ptype ttype);
   695:       (unifySpecifiers pspec tspec) @
   696:       (unifyInitExpr piexpr tiexpr)
   697:   | CALL(pfunc, pargs),
   698:     CALL(tfunc, targs) ->
   699:       (ue pfunc tfunc) @
   700:       (unifyExprs pargs targs)
   701:   | COMMA(pexprs),
   702:     COMMA(texprs) ->
   703:       (unifyExprs pexprs texprs)
   704:   | EXPR_SIZEOF(pexpr),
   705:     EXPR_SIZEOF(texpr) ->
   706:       (ue pexpr texpr)
   707:   | TYPE_SIZEOF(pspec, ptype),
   708:     TYPE_SIZEOF(tspec, ttype) ->
   709:       (mustEq ptype ttype);
   710:       (unifySpecifiers pspec tspec)
   711:   | EXPR_ALIGNOF(pexpr),
   712:     EXPR_ALIGNOF(texpr) ->
   713:       (ue pexpr texpr)
   714:   | TYPE_ALIGNOF(pspec, ptype),
   715:     TYPE_ALIGNOF(tspec, ttype) ->
   716:       (mustEq ptype ttype);
   717:       (unifySpecifiers pspec tspec)
   718:   | INDEX(parr, pindex),
   719:     INDEX(tarr, tindex) ->
   720:       (ue parr tarr) @
   721:       (ue pindex tindex)
   722:   | MEMBEROF(pexpr, pfield),
   723:     MEMBEROF(texpr, tfield) ->
   724:       (mustEq pfield tfield);
   725:       (ue pexpr texpr)
   726:   | MEMBEROFPTR(pexpr, pfield),
   727:     MEMBEROFPTR(texpr, tfield) ->
   728:       (mustEq pfield tfield);
   729:       (ue pexpr texpr)
   730:   | GNU_BODY(pblock),
   731:     GNU_BODY(tblock) ->
   732:       (mustEq pblock tblock);
   733:       []
   734:   | EXPR_PATTERN(name), _ ->
   735:       (* match, and contribute binding *)
   736:       if verbose then
   737:         (trace "patchDebug" (dprintf "found expr match for %s\n" name));
   738:       [BExpr(name, tgt)]
   739:   | a, b ->
   740:       if (verbose && traceActive "patchDebug") then (
   741:         (trace "patchDebug" (dprintf "mismatching expression\n"));
   742:         (printExpr a);
   743:         (printExpr b)
   744:       );
   745:       raise NoMatch
   746: end
   747: 
   748: and unifyInitExpr (pat : init_expression) (tgt : init_expression) : binding list =
   749: begin
   750:   (*
   751:     Flx_cil_cprint.print_init_expression pat;  Flx_cil_cprint.force_new_line ();
   752:     Flx_cil_cprint.print_init_expression tgt;  Flx_cil_cprint.force_new_line ();
   753:     Flx_cil_cprint.flush ();
   754:   *)
   755: 
   756:   match pat, tgt with
   757:   | NO_INIT, NO_INIT -> []
   758:   | SINGLE_INIT(pe), SINGLE_INIT(te) ->
   759:       (unifyExpr pe te)
   760:   | COMPOUND_INIT(plist),
   761:     COMPOUND_INIT(tlist) -> (
   762:       let rec loop plist tlist =
   763:         match plist, tlist with
   764:         | ((pwhat, piexpr) :: prest),
   765:           ((twhat, tiexpr) :: trest) ->
   766:             (mustEq pwhat twhat);
   767:             (unifyInitExpr piexpr tiexpr) @
   768:             (loop prest trest)
   769:         | [], [] -> []
   770:         | _, _ -> (
   771:             if verbose then
   772:               (trace "patchDebug" (dprintf "mismatching compound init exprs\n"));
   773:             raise NoMatch
   774:           )
   775:       in
   776:       (loop plist tlist)
   777:     )
   778:   | _,_ -> (
   779:       if verbose then
   780:         (trace "patchDebug" (dprintf "mismatching init exprs\n"));
   781:       raise NoMatch
   782:     )
   783: end
   784: 
   785: and unifyExprs (pat : expression list) (tgt : expression list) : binding list =
   786:   (unifyList pat tgt unifyExpr)
   787: 
   788: 
   789: (* given the list of bindings 'b', substitute them into 'd' to yield a new definition *)
   790: and substDefn (bindings : binding list) (defn : definition) : definition =
   791: begin
   792:   if verbose then
   793:     (trace "patchDebug" (dprintf "substDefn with %d bindings\n" (List.length bindings)));
   794:   (printDefn defn);
   795: 
   796:   (* apply the transformation *)
   797:   match (visit_cabsDefinition (new substitutor bindings :> cabsVisitor) defn) with
   798:   | [d] -> d    (* expect a singleton list *)
   799:   | _ -> (failwith "didn't get a singleton list where I expected one")
   800: end
   801: 
   802: 
   803: (* end of file *)
End ocaml section to src/flx_cil_patch.ml[1]
Start ocaml section to src/flx_cil_patch.mli[1 /1 ]
     1: # 20628 "./lpsrc/flx_cil.ipk"
     2: 
     3: 
     4: (* patch.mli *)
     5: (* interface for patch.ml *)
     6: 
     7: val applyFlx_cil_patch : Flx_cil_cabs.file -> Flx_cil_cabs.file -> Flx_cil_cabs.file
End ocaml section to src/flx_cil_patch.mli[1]
Start ocaml section to src/flx_cil_errormsg.ml[1 /1 ]
     1: # 20636 "./lpsrc/flx_cil.ipk"
     2: 
     3: open Flx_cil_pretty
     4: 
     5: 
     6: 
     7: let debugFlag  = ref false              (* If set then print debugging info *)
     8: let verboseFlag = ref false
     9: 
    10: (**** Error reporting ****)
    11: exception Error
    12: let s (d : doc) = raise Error
    13: 
    14: let hadErrors = ref false
    15: 
    16: let errorContext = ref []
    17: let pushContext f = errorContext := f :: (!errorContext)
    18: let popContext () =
    19:   match !errorContext with
    20:     _ :: t -> errorContext := t
    21:   | [] -> s (eprintf "Bug: cannot pop error context")
    22: 
    23: 
    24: let withContext ctx f x =
    25:   pushContext ctx;
    26:   try
    27:     let res = f x in
    28:     popContext ();
    29:     res
    30:   with e -> begin
    31:     popContext ();
    32:     raise e
    33:   end
    34: 
    35:                                         (* Make sure that showContext calls
    36:                                          * each f with its appropriate
    37:                                          * errorContext as it was when it was
    38:                                          * pushed *)
    39: let showContext () =
    40:   let rec loop = function
    41:       [] -> ()
    42:     | f :: rest -> (errorContext := rest; (* Just in case f raises an error *)
    43:                     ignore (eprintf "  Context : %t@!" f);
    44:                     loop rest)
    45:   in
    46:   let old = !errorContext in
    47:   try
    48:     loop old;
    49:     errorContext := old
    50:   with e -> begin
    51:     errorContext := old;
    52:     raise e
    53:   end
    54: 
    55: let contextMessage name d =
    56:   ignore (eprintf "@!%s: %a@!" name insert d);
    57:   showContext ()
    58: 
    59: let warnFlag = ref false
    60: 
    61: let logChannel : out_channel ref = ref stderr
    62: 
    63: 
    64: let bug (fmt : ('a,unit,doc) format) : 'a =
    65:   let f d =
    66:     hadErrors := true; contextMessage "Bug" d;
    67:     flush !logChannel;
    68:     nil
    69:   in
    70:   Flx_cil_pretty.gprintf f fmt
    71: 
    72: let error (fmt : ('a,unit,doc) format) : 'a =
    73:   let f d = hadErrors := true; contextMessage "Error" d;
    74:     flush !logChannel;
    75:     nil
    76:   in
    77:   Flx_cil_pretty.gprintf f fmt
    78: 
    79: let unimp (fmt : ('a,unit,doc) format) : 'a =
    80:   let f d = hadErrors := true; contextMessage "Unimplemented" d;
    81:     flush !logChannel;
    82:     nil
    83:   in
    84:   Flx_cil_pretty.gprintf f fmt
    85: 
    86: let warn (fmt : ('a,unit,doc) format) : 'a =
    87:   let f d = contextMessage "Warning" d; flush !logChannel; nil in
    88:   Flx_cil_pretty.gprintf f fmt
    89: 
    90: let warnOpt (fmt : ('a,unit,doc) format) : 'a =
    91:     let f d =
    92:       if !warnFlag then contextMessage "Warning" d; flush !logChannel;
    93:       nil in
    94:     Flx_cil_pretty.gprintf f fmt
    95: 
    96: 
    97: let log (fmt : ('a,unit,doc) format) : 'a =
    98:   let f d = fprint !logChannel 80 d; flush !logChannel; d in
    99:   Flx_cil_pretty.gprintf f fmt
   100: 
   101: let null (fmt : ('a,unit,doc) format) : 'a =
   102:   let f d = Flx_cil_pretty.nil in
   103:   Flx_cil_pretty.gprintf f fmt
   104: 
   105: let check (what: bool) (fmt : ('a,unit,doc) format) : 'a =
   106:   if what then
   107:      what
   108:   else begin
   109:     let f d =
   110:       if not what then begin
   111:          hadErrors := true; contextMessage "Assert" d;
   112:          flush !logChannel; raise Error
   113:     end else nil in
   114:     Flx_cil_pretty.gprintf f fmt
   115:   end
   116: 
   117: let theLexbuf = ref (Lexing.from_string "")
   118: 
   119: let fail format = Flx_cil_pretty.gprintf (fun x -> Flx_cil_pretty.fprint stderr 80 x;
   120:                                            raise (Failure "")) format
   121: 
   122: 
   123: 
   124: (***** Handling parsing errors ********)
   125: type parseinfo =
   126:     { mutable  linenum: int      ; (* Current line *)
   127:       mutable  linestart: int    ; (* The position in the buffer where the
   128:                                     * current line starts *)
   129:       mutable fileName : string   ; (* Current file *)
   130:       mutable hfile   : string   ; (* High-level file *)
   131:       mutable hline   : int;       (* High-level line *)
   132:       lexbuf          : Lexing.lexbuf;
   133:       inchan          : in_channel option; (* None, if from a string *)
   134:       mutable   num_errors : int;  (* Errors so far *)
   135:     }
   136: 
   137: let dummyinfo =
   138:     { linenum   = 1;
   139:       linestart = 0;
   140:       fileName  = "" ;
   141:       lexbuf    = Lexing.from_string "";
   142:       inchan    = None;
   143:       hfile     = "";
   144:       hline     = 0;
   145:       num_errors = 0;
   146:     }
   147: 
   148: let current = ref dummyinfo
   149: 
   150: let setHLine (l: int) : unit =
   151:     !current.hline <- l
   152: let setHFile (f: string) : unit =
   153:     !current.hfile <- f
   154: 
   155: let rem_quotes str = String.sub str 1 ((String.length str) - 2)
   156: 
   157: (* Change \ into / in file names. To avoid complications with escapes *)
   158: let cleanFileName str =
   159:   let str1 =
   160:     if str <> "" && String.get str 0 = '"' (* '"' ( *)
   161:     then rem_quotes str else str in
   162:   let l = String.length str1 in
   163:   let rec loop (copyto: int) (i: int) =
   164:     if i >= l then
   165:       String.sub str1 0 copyto
   166:      else
   167:        let c = String.get str1 i in
   168:        if c <> '\\' then begin
   169:           String.set str1 copyto c; loop (copyto + 1) (i + 1)
   170:        end else begin
   171:           String.set str1 copyto '/';
   172:           if i < l - 2 && String.get str1 (i + 1) = '\\' then
   173:               loop (copyto + 1) (i + 2)
   174:           else
   175:               loop (copyto + 1) (i + 1)
   176:        end
   177:   in
   178:   loop 0 0
   179: 
   180: let startParsing (fname: string) =
   181:   let inchan =
   182:     try open_in fname with
   183:       _ -> s (error "Cannot find input file %s" fname) in
   184:   let lexbuf = Lexing.from_channel inchan in
   185:   let i =
   186:     { linenum = 1; linestart = 0;
   187:       fileName = cleanFileName (Filename.basename fname);
   188:       lexbuf = lexbuf; inchan = Some inchan;
   189:       hfile = ""; hline = 0;
   190:       num_errors = 0 } in
   191:   current := i;
   192:   lexbuf
   193: 
   194: let startParsingFromString ?(file="<string>") ?(line=1) (str: string) =
   195:   let lexbuf = Lexing.from_string str in
   196:   let i =
   197:     { linenum = line; linestart = line - 1;
   198:       fileName = file;
   199:       hfile = ""; hline = 0;
   200:       lexbuf = lexbuf;
   201:       inchan = None;
   202:       num_errors = 0 }
   203:   in
   204:   current := i;
   205:   lexbuf
   206: 
   207: let finishParsing () =
   208:   let i = !current in
   209:   (match i.inchan with Some c -> close_in c | _ -> ());
   210:   current := dummyinfo
   211: 
   212: 
   213: (* Call this function to announce a new line *)
   214: let newline () =
   215:   let i = !current in
   216:   i.linenum <- 1 + i.linenum;
   217:   i.linestart <- Lexing.lexeme_start i.lexbuf
   218: 
   219: let newHline () =
   220:   let i = !current in
   221:   i.hline <- 1 + i.hline
   222: 
   223: let setCurrentLine (i: int) =
   224:   !current.linenum <- i
   225: 
   226: let setCurrentFile (n: string) =
   227:   !current.fileName <- cleanFileName n
   228: 
   229: 
   230: let max_errors = 20  (* Stop after 20 errors *)
   231: 
   232: let parse_error (msg: string) : 'a =
   233:   (* Sometimes the Ocaml parser raises errors in symbol_start and symbol_end *)
   234:   let token_start, token_end =
   235:     try Parsing.symbol_start (), Parsing.symbol_end ()
   236:     with e -> begin
   237:       ignore (warn "Parsing raised %s\n" (Printexc.to_string e));
   238:       0, 0
   239:     end
   240:   in
   241:   let i = !current in
   242:   let adjStart =
   243:     if token_start < i.linestart then 0 else token_start - i.linestart in
   244:   let adjEnd =
   245:     if token_end < i.linestart then 0 else token_end - i.linestart in
   246:   output_string
   247:     stderr
   248:     (i.fileName ^ "[" ^ (string_of_int i.linenum) ^ ":"
   249:                         ^ (string_of_int adjStart) ^ "-"
   250:                         ^ (string_of_int adjEnd)
   251:                   ^ "]"
   252:      ^ " : " ^ msg);
   253:   output_string stderr "\n";
   254:   flush stderr ;
   255:   i.num_errors <- i.num_errors + 1;
   256:   if i.num_errors > max_errors then begin
   257:     output_string stderr "Too many errors. Aborting.\n" ;
   258:     exit 1
   259:   end;
   260:   raise Parsing.Parse_error
   261: 
   262: 
   263: 
   264: 
   265: (* More parsing support functions: line, file, char count *)
   266: let getPosition () : int * string * int =
   267:   let i = !current in
   268:   i.linenum, i.fileName, Lexing.lexeme_start i.lexbuf
   269: 
   270: 
   271: let getHPosition () =
   272:   !current.hline, !current.hfile
   273: 
   274: (** Type for source-file locations *)
   275: type location =
   276:     { file: string; (** The file name *)
   277:       line: int;    (** The line number *)
   278:       hfile: string; (** The high-level file name, or "" if not present *)
   279:       hline: int;    (** The high-level line number, or 0 if not present *)
   280:     }
   281: 
   282: let d_loc () l =
   283:   text (l.file ^ ":" ^ string_of_int l.line)
   284: 
   285: let d_hloc () (l: location) =
   286:   dprintf "%s:%d%a" l.file l.line
   287:     insert (if l.hline > 0 then dprintf " (%s:%d)" l.hfile l.hline else nil)
   288: 
   289: let locUnknown = { file = ""; hfile = ""; line = -1; hline = -1 }
   290: 
   291: let getLocation () =
   292:   let hl, hf = getHPosition () in
   293:   let l, f, c = getPosition () in
   294:   { hfile = hf; hline = hl;
   295:     file = f; line = l }
   296: 
End ocaml section to src/flx_cil_errormsg.ml[1]
Start ocaml section to src/flx_cil_errormsg.mli[1 /1 ]
     1: # 20933 "./lpsrc/flx_cil.ipk"
     2: (** Flx_cil_utility functions for error-reporting *)
     3: 
     4: (** A channel for printing log messages *)
     5: val logChannel : out_channel ref
     6: 
     7: (** If set then print debugging info *)
     8: val debugFlag  : bool ref
     9: 
    10: val verboseFlag : bool ref
    11: 
    12: 
    13: (** Set to true if you want to see all warnings. *)
    14: val warnFlag: bool ref
    15: 
    16: (** Error reporting functions raise this exception *)
    17: exception Error
    18: 
    19: 
    20:    (* Error reporting. All of these functions take same arguments as a
    21:     * Flx_cil_pretty.eprintf. They raise the exception Error after they print their
    22:     * stuff. However, their type indicates that they return a "Flx_cil_pretty.doc"
    23:     * (due to the need to use the built-in type "format") return a doc. Thus
    24:     * use as follows:  E.s (E.bug "different lengths (%d != %d)" l1 l2)
    25:      *)
    26: 
    27: (** Prints an error message of the form [Error: ...].
    28:     Use in conjunction with s, for example: [E.s (E.error ... )]. *)
    29: val error:         ('a,unit,Flx_cil_pretty.doc) format -> 'a
    30: 
    31: (** Similar to [error] except that its output has the form [Bug: ...] *)
    32: val bug:           ('a,unit,Flx_cil_pretty.doc) format -> 'a
    33: 
    34: (** Similar to [error] except that its output has the form [Unimplemented: ...] *)
    35: val unimp:         ('a,unit,Flx_cil_pretty.doc) format -> 'a
    36: 
    37: (** Stop the execution by raising an Error. Use "s (error "Foo")"  *)
    38: val s:             Flx_cil_pretty.doc -> 'a
    39: 
    40: (** This is set whenever one of the above error functions are called. It must
    41:     be cleared manually *)
    42: val hadErrors: bool ref
    43: 
    44: (** Like {!Flx_cil_errormsg.error} but does not raise the {!Flx_cil_errormsg.Error}
    45:  * exception. Use: [ignore (E.warn ...)] *)
    46: val warn:    ('a,unit,Flx_cil_pretty.doc) format -> 'a
    47: 
    48: (** Like {!Flx_cil_errormsg.warn} but optional. Printed only if the
    49:  * {!Flx_cil_errormsg.warnFlag} is set *)
    50: val warnOpt: ('a,unit,Flx_cil_pretty.doc) format -> 'a
    51: 
    52: (** Print something to [logChannel] *)
    53: val log:           ('a,unit,Flx_cil_pretty.doc) format -> 'a
    54: 
    55:    (* All of the error and warning reporting functions can also print a
    56:     * context. To register a context printing function use "pushContext". To
    57:     * remove the last registered one use "popContext". If one of the error
    58:     * reporting functions is called it will invoke all currently registered
    59:     * context reporting functions in the reverse order they were registered. *)
    60: 
    61: (** Do not actually print (i.e. print to /dev/null) *)
    62: val null : ('a,unit,Flx_cil_pretty.doc) format -> 'a
    63: 
    64: (** Registers a context printing function *)
    65: val pushContext  : (unit -> Flx_cil_pretty.doc) -> unit
    66: 
    67: (** Removes the last registered context printing function *)
    68: val popContext   : unit -> unit
    69: 
    70: (** Show the context stack to stderr *)
    71: val showContext : unit -> unit
    72: 
    73: (** To ensure that the context is registered and removed properly, use the
    74:     function below *)
    75: val withContext  : (unit -> Flx_cil_pretty.doc) -> ('a -> 'b) -> 'a -> 'b
    76: 
    77: 
    78: 
    79: val newline: unit -> unit  (* Call this function to announce a new line *)
    80: val newHline: unit -> unit
    81: 
    82: val getPosition: unit -> int * string * int (* Line number, file name,
    83:                                                current byte count in file *)
    84: val getHPosition: unit -> int * string (** high-level position *)
    85: 
    86: val setHLine: int -> unit
    87: val setHFile: string -> unit
    88: 
    89: val setCurrentLine: int -> unit
    90: val setCurrentFile: string -> unit
    91: 
    92: (** Type for source-file locations *)
    93: type location =
    94:     { file: string; (** The file name *)
    95:       line: int;    (** The line number *)
    96:       hfile: string; (** The high-level file name, or "" if not present *)
    97:       hline: int;    (** The high-level line number, or 0 if not present *)
    98:     }
    99: 
   100: val d_loc: unit -> location -> Flx_cil_pretty.doc
   101: val d_hloc: unit -> location -> Flx_cil_pretty.doc
   102: 
   103: val getLocation: unit -> location
   104: 
   105: val parse_error: string -> (* A message *)
   106:                  'a
   107: 
   108: (** An unknown location for use when you need one but you don't have one *)
   109: val locUnknown: location
   110: 
   111: 
   112: val startParsing: string -> Lexing.lexbuf (* Call this function to start
   113:                                            * parsing *)
   114: val startParsingFromString: ?file:string -> ?line:int -> string
   115:                             -> Lexing.lexbuf
   116: 
   117: val finishParsing: unit -> unit (* Call this function to finish parsing and
   118:                                  * close the input channel *)
   119: 
   120: 
End ocaml section to src/flx_cil_errormsg.mli[1]
Start ocaml section to src/flx_cil_inthash.mli[1 /1 ]
     1: # 21054 "./lpsrc/flx_cil.ipk"
     2: type 'a t = { mutable size : int; mutable data : 'a bucketlist array; }
     3: and 'a bucketlist = Empty | Cons of int * 'a * 'a bucketlist
     4: val create : int -> 'a t
     5: val clear : 'a t -> unit
     6: val copy : 'a t -> 'a t
     7: val resize : 'a t -> unit
     8: val add : 'a t -> int -> 'a -> unit
     9: val remove : 'a t -> int -> unit
    10: val find_rec : int -> 'a bucketlist -> 'a
    11: val find : 'a t -> int -> 'a
    12: val find_all : 'a t -> int -> 'a list
    13: val replace : 'a t -> int -> 'a -> unit
    14: val mem : 'a t -> int -> bool
    15: val iter : (int -> 'a -> 'b) -> 'a t -> unit
    16: val fold : (int -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
    17: val memoize : unit t -> int -> (int -> unit) -> unit
    18: 
End ocaml section to src/flx_cil_inthash.mli[1]
Start ocaml section to src/flx_cil_inthash.ml[1 /1 ]
     1: # 21073 "./lpsrc/flx_cil.ipk"
     2: (** A hash table specialized on integer keys *)
     3: type 'a t =
     4:   { mutable size: int;                        (* number of elements *)
     5:     mutable data: 'a bucketlist array } (* the buckets *)
     6: 
     7: and 'a bucketlist =
     8:     Empty
     9:   | Cons of int * 'a * 'a bucketlist
    10: 
    11: let create initial_size =
    12:   let s = min (max 1 initial_size) Sys.max_array_length in
    13:   { size = 0; data = Array.make s Empty }
    14: 
    15: let clear h =
    16:   for i = 0 to Array.length h.data - 1 do
    17:     h.data.(i) <- Empty
    18:   done;
    19:   h.size <- 0
    20: 
    21: let copy h =
    22:   { size = h.size;
    23:     data = Array.copy h.data }
    24: 
    25: let resize tbl =
    26:   let odata = tbl.data in
    27:   let osize = Array.length odata in
    28:   let nsize = min (2 * osize + 1) Sys.max_array_length in
    29:   if nsize <> osize then begin
    30:     let ndata = Array.create nsize Empty in
    31:     let rec insert_bucket = function
    32:         Empty -> ()
    33:       | Cons(key, data, rest) ->
    34:           insert_bucket rest; (* preserve original order of elements *)
    35:           let nidx = key mod nsize in
    36:           ndata.(nidx) <- Cons(key, data, ndata.(nidx)) in
    37:     for i = 0 to osize - 1 do
    38:       insert_bucket odata.(i)
    39:     done;
    40:     tbl.data <- ndata;
    41:   end
    42: 
    43: let add h key info =
    44:   let i = key mod (Array.length h.data) in
    45:   let bucket = Cons(key, info, h.data.(i)) in
    46:   h.data.(i) <- bucket;
    47:   h.size <- succ h.size;
    48:   if h.size > Array.length h.data lsl 1 then resize h
    49: 
    50: let remove h key =
    51:   let rec remove_bucket = function
    52:       Empty ->
    53:         Empty
    54:     | Cons(k, i, next) ->
    55:         if k = key
    56:         then begin h.size <- pred h.size; next end
    57:         else Cons(k, i, remove_bucket next) in
    58:   let i = key mod (Array.length h.data) in
    59:   h.data.(i) <- remove_bucket h.data.(i)
    60: 
    61: let rec find_rec key = function
    62:     Empty ->
    63:       raise Not_found
    64:   | Cons(k, d, rest) ->
    65:       if key = k then d else find_rec key rest
    66: 
    67: let find h key =
    68:   match h.data.(key mod (Array.length h.data)) with
    69:     Empty -> raise Not_found
    70:   | Cons(k1, d1, rest1) ->
    71:       if key = k1 then d1 else
    72:       match rest1 with
    73:         Empty -> raise Not_found
    74:       | Cons(k2, d2, rest2) ->
    75:           if key = k2 then d2 else
    76:           match rest2 with
    77:             Empty -> raise Not_found
    78:           | Cons(k3, d3, rest3) ->
    79:               if key = k3 then d3 else find_rec key rest3
    80: 
    81: let find_all h key =
    82:   let rec find_in_bucket = function
    83:     Empty ->
    84:       []
    85:   | Cons(k, d, rest) ->
    86:       if k = key then d :: find_in_bucket rest else find_in_bucket rest in
    87:   find_in_bucket h.data.(key mod (Array.length h.data))
    88: 
    89: let replace h key info =
    90:   let rec replace_bucket = function
    91:       Empty ->
    92:         raise Not_found
    93:     | Cons(k, i, next) ->
    94:         if k = key
    95:         then Cons(k, info, next)
    96:         else Cons(k, i, replace_bucket next) in
    97:   let i = key mod (Array.length h.data) in
    98:   let l = h.data.(i) in
    99:   try
   100:     h.data.(i) <- replace_bucket l
   101:   with Not_found ->
   102:     h.data.(i) <- Cons(key, info, l);
   103:     h.size <- succ h.size;
   104:     if h.size > Array.length h.data lsl 1 then resize h
   105: 
   106: let mem h key =
   107:   let rec mem_in_bucket = function
   108:   | Empty ->
   109:       false
   110:   | Cons(k, d, rest) ->
   111:       k = key || mem_in_bucket rest in
   112:   mem_in_bucket h.data.(key mod (Array.length h.data))
   113: 
   114: let iter f h =
   115:   let rec do_bucket = function
   116:       Empty ->
   117:         ()
   118:     | Cons(k, d, rest) ->
   119:         f k d; do_bucket rest in
   120:   let d = h.data in
   121:   for i = 0 to Array.length d - 1 do
   122:     do_bucket d.(i)
   123:   done
   124: 
   125: let fold (f: int -> 'a -> 'b -> 'b) (h: 'a t) (init: 'b) =
   126:   let rec do_bucket b accu =
   127:     match b with
   128:       Empty ->
   129:         accu
   130:     | Cons(k, d, rest) ->
   131:         do_bucket rest (f k d accu) in
   132:   let d = h.data in
   133:   let accu = ref init in
   134:   for i = 0 to Array.length d - 1 do
   135:     accu := do_bucket d.(i) !accu
   136:   done;
   137:   !accu
   138: 
   139: 
   140: let memoize (h: 'a t) (key: int) (f: int -> 'a) : 'a =
   141:   let i = key mod (Array.length h.data) in
   142:   let rec find_rec key = function
   143:       Empty -> addit ()
   144:     | Cons(k, d, rest) ->
   145:         if key = k then d else find_rec key rest
   146:   and find_in_bucket key = function
   147:       Empty -> addit ()
   148:     | Cons(k1, d1, rest1) ->
   149:         if key = k1 then d1 else
   150:         match rest1 with
   151:           Empty -> addit ()
   152:         | Cons(k2, d2, rest2) ->
   153:             if key = k2 then d2 else
   154:             match rest2 with
   155:               Empty -> addit ()
   156:             | Cons(k3, d3, rest3) ->
   157:                 if key = k3 then d3 else find_rec key rest3
   158:   and addit () =
   159:     let it = f key in
   160:     h.data.(i) <- Cons(key, it, h.data.(i));
   161:     h.size <- succ h.size;
   162:     if h.size > Array.length h.data lsl 1 then resize h
   163:   in
   164:   find_in_bucket key h.data.(i)
   165: 
   166: 
End ocaml section to src/flx_cil_inthash.ml[1]
Start ocaml section to src/flx_cil_pretty.ml[1 /1 ]
     1: # 21240 "./lpsrc/flx_cil.ipk"
     2: 
     3: (******************************************************************************)
     4: (* Flx_cil_pretty printer
     5:    This module contains several fast, but sub-optimal heuristics to pretty-print
     6:    structured text.
     7: *)
     8: 
     9: let debug =  false
    10: 
    11: (* Choose an algorithm *)
    12: type algo = George | Aman | Gap
    13: let  algo = George
    14: let fastMode       = ref false
    15: 
    16: 
    17: (** Whether to print identation or not (for faster printing and smaller
    18:   * output) *)
    19: let printIndent = ref true
    20: 
    21: (******************************************************************************)
    22: (* The doc type and constructors *)
    23: 
    24: type doc =
    25:     Nil
    26:   | Text     of string
    27:   | Concat   of doc * doc
    28:   | CText    of doc * string
    29:   | Break
    30:   | Line
    31:   | LeftFlush
    32:   | Align
    33:   | Unalign
    34:   | Mark
    35:   | Unmark
    36: 
    37: (* Break a string at \n *)
    38: let rec breakString (acc: doc) (str: string) : doc =
    39:   try
    40:     (* Printf.printf "breaking string %s\n" str; *)
    41:     let r = String.index str '\n' in
    42:     (* Printf.printf "r=%d\n" r; *)
    43:     let len = String.length str in
    44:     if r > 0 then begin
    45:       (* Printf.printf "Taking %s\n" (String.sub str 0 r); *)
    46:       let acc' = Concat(CText (acc, String.sub str 0 r), Line) in
    47:       if r = len - 1 then (* The last one *)
    48:         acc'
    49:       else begin
    50:         (* Printf.printf "Continuing with %s\n" (String.sub str (r + 1) (len - r - 1)); *)
    51:         breakString acc'
    52:           (String.sub str (r + 1) (len - r - 1))
    53:       end
    54:     end else (* The first is a newline *)
    55:       breakString (Concat(acc, Line))
    56:         (String.sub str (r + 1) (len - r - 1))
    57:   with Not_found ->
    58:     if acc = Nil then Text str else CText (acc, str)
    59: 
    60: let nil           = Nil
    61: let text s        = breakString nil s
    62: let num  i        = text (string_of_int i)
    63: let real f        = text (string_of_float f)
    64: let chr  c        = text (String.make 1 c)
    65: let align         = Align
    66: let unalign       = Unalign
    67: let line          = Line
    68: let leftflush     = LeftFlush
    69: let break         = Break
    70: let mark          = Mark
    71: let unmark        = Unmark
    72: 
    73: (* Note that the ++ operator in Ocaml are left-associative. This means
    74:  * that if you have a long list of ++ then the whole thing is very unbalanced
    75:  * towards the left side. This is the worst possible case since scanning the
    76:  * left side of a Concat is the non-tail recursive case. *)
    77: 
    78: let (++) d1 d2 = Concat (d1, d2)
    79: 
    80: (* Ben Liblit fix *)
    81: let indent n d = text (String.make n ' ') ++ (align ++ (d ++ unalign))
    82: 
    83: let markup d = mark ++ d ++ unmark
    84: 
    85: (* Format a sequence. The first argument is a separator *)
    86: let seq ~(sep:doc)  ~(doit:'a -> doc) ~(elements: 'a list) =
    87:   let rec loop (acc: doc) = function
    88:       []     -> acc
    89:     | h :: t ->
    90:         let fh = doit h in  (* Make sure this is done first *)
    91:         loop (acc ++ sep ++ fh) t
    92:   in
    93:   (match elements with
    94:     [] -> nil
    95:   | h :: t ->
    96:       let fh = doit h in loop fh t)
    97: 
    98: 
    99: let docArray (sep:doc) (doit:int -> 'a -> doc) () (elements:'a array) =
   100:   let len = Array.length elements in
   101:   if len = 0 then
   102:     nil
   103:   else
   104:     let rec loop (acc: doc) i =
   105:       if i >= len then acc else
   106:       let fi = doit i elements.(i) in (* Make sure this is done first *)
   107:       loop (acc ++ sep ++ fi) (i + 1)
   108:     in
   109:     let f0 = doit 0 elements.(0) in
   110:     loop f0 1
   111: 
   112: let docOpt delem () = function
   113:     None -> text "None"
   114:   | Some e -> text "Some(" ++ (delem () e) ++ chr ')'
   115: 
   116: 
   117: 
   118: let docList (sep:doc) (doit:'a -> doc) () (elements:'a list) =
   119:   seq sep doit elements
   120: 
   121: let insert () d = d
   122: 
   123: 
   124: let d_list (sep:string) (doit:unit -> 'a -> doc) () (elts:'a list) : doc =
   125:   (* thunk 'doit' to match docList's interface *)
   126:   let internalDoit (elt:'a) =
   127:     (doit () elt) in
   128:   (docList (text sep) internalDoit () elts)
   129: 
   130: 
   131: (******************************************************************************)
   132: (* Some debugging stuff *)
   133: 
   134: let dbgprintf x = Printf.fprintf stderr x
   135: 
   136: let rec dbgPrintDoc = function
   137:     Nil -> dbgprintf "(Nil)"
   138:   | Text s -> dbgprintf "(Text %s)" s
   139:   | Concat (d1,d2) -> dbgprintf ""; dbgPrintDoc  d1; dbgprintf " ++\n ";
   140:       dbgPrintDoc  d2; dbgprintf ""
   141:   | CText (d,s) -> dbgPrintDoc  d; dbgprintf " ++ \"%s\"" s;
   142:   | Break -> dbgprintf "(Break)"
   143:   | Line -> dbgprintf "(Line)"
   144:   | LeftFlush -> dbgprintf "(LeftFlush)"
   145:   | Align -> dbgprintf "(Align)"
   146:   | Unalign -> dbgprintf "(Unalign)"
   147:   | Mark -> dbgprintf "(Mark)"
   148:   | Unmark -> dbgprintf "(Unmark)"
   149: 
   150: (******************************************************************************)
   151: (* The "george" algorithm *)
   152: 
   153: (* When we construct documents, most of the time they are heavily unbalanced
   154:  * towards the left. This is due to the left-associativity of ++ and also to
   155:  * the fact that constructors such as docList construct from the let of a
   156:  * sequence. We would prefer to shift the imbalance to the right to avoid
   157:  * consuming a lot of stack when we traverse the document *)
   158: let rec flatten (acc: doc) = function
   159:   | Concat (d1, d2) -> flatten (flatten acc d2) d1
   160:   | CText (d, s) -> flatten (Concat(Text s, acc)) d
   161:   | Nil -> acc (* Get rid of Nil *)
   162:   | d -> Concat(d, acc)
   163: 
   164: (* We keep a stack of active aligns. *)
   165: type align =
   166:     { mutable gainBreak: int;  (* This is the gain that is associated with
   167:                                  * taking the break associated with this
   168:                                  * alignment mark. If this is 0, then there
   169:                                  * is no break associated with the mark *)
   170:       mutable isTaken: bool ref; (* If breakGain is > 0 then this is a ref
   171:                                   * cell that must be set to true when the
   172:                                   * break is taken. These ref cells are also
   173:                                   * int the "breaks" list  *)
   174:             deltaFromPrev: int ref; (* The column of this alignment mark -
   175:                                      * the column of the previous mark.
   176:                                      * Shared with the deltaToNext of the
   177:                                      * previous active align  *)
   178:              deltaToNext: int ref  (* The column of the next alignment mark -
   179:                                     * the columns of this one. Shared with
   180:                                     * deltaFromPrev of the next active align *)
   181:     }
   182: 
   183: (* We use references to avoid the need to pass data around all the time *)
   184: let aligns: align list ref =  (* The current stack of active alignment marks,
   185:                                * with the top at the head. Never empty.  *)
   186:   ref [{ gainBreak = 0; isTaken = ref false;
   187:          deltaFromPrev = ref 0; deltaToNext = ref 0; }]
   188: 
   189: let topAlignAbsCol = ref 0 (* The absolute column of the top alignment *)
   190: 
   191: let pushAlign (abscol: int) =
   192:   let topalign = List.hd !aligns in
   193:   let res =
   194:     { gainBreak = 0; isTaken = ref false;
   195:       deltaFromPrev = topalign.deltaToNext; (* Share with the previous *)
   196:       deltaToNext = ref 0; (* Allocate a new ref *)} in
   197:   aligns := res :: !aligns;
   198:   res.deltaFromPrev := abscol - !topAlignAbsCol;
   199:   topAlignAbsCol := abscol
   200: 
   201: let popAlign () =
   202:   match !aligns with
   203:     top :: t when t != [] ->
   204:       aligns := t;
   205:       topAlignAbsCol := !topAlignAbsCol - !(top.deltaFromPrev)
   206:   | _ -> failwith "Unmatched unalign\n"
   207: 
   208: (** We keep a list of active markup sections. For each one we keep the column
   209:  * we are in *)
   210: let activeMarkups: int list ref = ref []
   211: 
   212: 
   213: (* Keep a list of ref cells for the breaks, in the same order that we see
   214:  * them in the document *)
   215: let breaks: bool ref list ref = ref []
   216: 
   217: (* The maximum column that we should use *)
   218: let maxCol = ref 0
   219: 
   220: (* Sometimes we take all the optional breaks *)
   221: let breakAllMode = ref false
   222: 
   223: (* We are taking a newline and moving left *)
   224: let newline () =
   225:   let topalign = List.hd !aligns in (* aligns is never empty *)
   226:   if debug then
   227:     dbgprintf "Taking a newline: reseting gain of %d\n" topalign.gainBreak;
   228:   topalign.gainBreak <- 0;        (* Erase the current break info *)
   229:   if !breakAllMode && !topAlignAbsCol < !maxCol then
   230:     breakAllMode := false;
   231:   !topAlignAbsCol                          (* This is the new column *)
   232: 
   233: 
   234: 
   235: (* Choose the align with the best gain. We outght to find a better way to
   236:  * keep the aligns sorted, especially since they gain never changes (when the
   237:  * align is the top align) *)
   238: let chooseBestGain () : align option =
   239:   let bestGain = ref 0 in
   240:   let rec loop (breakingAlign: align option) = function
   241:       [] -> breakingAlign
   242:     | a :: resta ->
   243:         if debug then dbgprintf "Looking at align with gain %d\n" a.gainBreak;
   244:         if a.gainBreak > !bestGain then begin
   245:           bestGain := a.gainBreak;
   246:           loop (Some a) resta
   247:         end else
   248:           loop breakingAlign resta
   249:   in
   250:   loop None !aligns
   251: 
   252: 
   253: (* Another one that chooses the break associated with the current align only *)
   254: let chooseLastGain () : align option =
   255:   let topalign = List.hd !aligns in
   256:   if topalign.gainBreak > 0 then Some topalign else None
   257: 
   258: (* We have just advanced to a new column. See if we must take a line break *)
   259: let movingRight (abscol: int) : int =
   260:   (* Keep taking the best break until we get back to the left of maxCol or no
   261:    * more are left *)
   262:   let rec tryAgain abscol =
   263:     if abscol <= !maxCol then abscol else
   264:     begin
   265:       if debug then
   266:         dbgprintf "Looking for a break to take in column %d\n" abscol;
   267:       (* Find the best gain there is out there *)
   268:       match if !fastMode then None else chooseBestGain () with
   269:         None -> begin
   270:           (* No breaks are available. Take all breaks from now on *)
   271:           breakAllMode := true;
   272:           if debug then
   273:             dbgprintf "Can't find any breaks\n";
   274:           abscol
   275:         end
   276:       | Some breakingAlign -> begin
   277:           let topalign = List.hd !aligns in
   278:           let theGain = breakingAlign.gainBreak in
   279:           assert (theGain > 0);
   280:           if debug then dbgprintf "Taking break at %d. gain=%d\n" abscol theGain;
   281:           breakingAlign.isTaken := true;
   282:           breakingAlign.gainBreak <- 0;
   283:           if breakingAlign != topalign then begin
   284:             breakingAlign.deltaToNext :=
   285:                !(breakingAlign.deltaToNext) - theGain;
   286:             topAlignAbsCol := !topAlignAbsCol - theGain
   287:           end;
   288:           tryAgain (abscol - theGain)
   289:       end
   290:     end
   291:   in
   292:   tryAgain abscol
   293: 
   294: 
   295: (* Keep track of nested align in gprintf. Each gprintf format string must
   296:  * have properly nested align/unalign pairs. When the nesting depth surpasses
   297:  * !printDepth then we print ... and we skip until the matching unalign *)
   298: let printDepth = ref 10000000 (* WRW: must see whole thing *)
   299: let alignDepth = ref 0
   300: 
   301: let useAlignDepth = true
   302: 
   303: (** Start an align. Return true if we ahve just passed the threshhold *)
   304: let enterAlign () =
   305:   incr alignDepth;
   306:   useAlignDepth && !alignDepth = !printDepth + 1
   307: 
   308: (** Exit an align *)
   309: let exitAlign () =
   310:   decr alignDepth
   311: 
   312: (** See if we are at a low-enough align level (and we should be printing
   313:  * normally) *)
   314: let shallowAlign () =
   315:   not useAlignDepth || !alignDepth <= !printDepth
   316: 
   317: 
   318: (* Pass the current absolute column and compute the new column *)
   319: let rec scan (abscol: int) (d: doc) : int =
   320:   match d with
   321:     Nil -> abscol
   322:   | Concat (d1, d2) -> scan (scan abscol d1) d2
   323:   | Text s when shallowAlign () ->
   324:       let sl = String.length s in
   325:       if debug then
   326:         dbgprintf "Done string: %s from %d to %d\n" s abscol (abscol + sl);
   327:       movingRight (abscol + sl)
   328:   | CText (d, s) ->
   329:       let abscol' = scan abscol d in
   330:       if shallowAlign () then begin
   331:         let sl = String.length s in
   332:         if debug then
   333:           dbgprintf "Done string: %s from %d to %d\n" s abscol' (abscol' + sl);
   334:         movingRight (abscol' + sl)
   335:       end else
   336:         abscol'
   337: 
   338:   | Align ->
   339:       pushAlign abscol;
   340:       if enterAlign () then
   341:         movingRight (abscol + 3) (* "..." *)
   342:       else
   343:         abscol
   344: 
   345:   | Unalign -> exitAlign (); popAlign (); abscol
   346: 
   347:   | Line when shallowAlign () -> (* A forced line break *)
   348:       if !activeMarkups != [] then
   349:         failwith "Line breaks inside markup sections";
   350:       newline ()
   351: 
   352:   | LeftFlush when shallowAlign ()  -> (* Keep cursor left-flushed *) 0
   353: 
   354:   | Break when shallowAlign () -> (* An optional line break. Always a space
   355:                                    * followed by an optional line break *)
   356:       if !activeMarkups != [] then
   357:         failwith "Line breaks inside markup sections";
   358:       let takenref = ref false in
   359:       breaks := takenref :: !breaks;
   360:       let topalign = List.hd !aligns in (* aligns is never empty *)
   361:       if !breakAllMode then begin
   362:         takenref := true;
   363:         newline ()
   364:       end else begin
   365:         (* If there was a previous break there it stays not taken, forever.
   366:          * So we overwrite it. *)
   367:         topalign.isTaken <- takenref;
   368:         topalign.gainBreak <- 1 + abscol - !topAlignAbsCol;
   369:         if debug then
   370:           dbgprintf "Registering a break at %d with gain %d\n"
   371:             (1 + abscol) topalign.gainBreak;
   372:         movingRight (1 + abscol)
   373:       end
   374: 
   375:   | Mark -> activeMarkups := abscol :: !activeMarkups;
   376:             abscol
   377: 
   378:   | Unmark -> begin
   379:       match !activeMarkups with
   380:         old :: rest -> activeMarkups := rest;
   381:                        old
   382:       | [] -> failwith "Too many unmark"
   383:   end
   384: 
   385:   | _ -> (* Align level is too deep *) abscol
   386: 
   387: 
   388: (** Keep a running counter of the newlines we are taking. You can read and
   389:   * reset this from user code, if you want *)
   390: let countNewLines = ref 0
   391: 
   392: (* The actual function that takes a document and prints it *)
   393: let emitDoc
   394:     (emitString: string -> int -> unit) (* emit a number of copies of a
   395:                                          * string *)
   396:     (d: doc) =
   397:   let aligns: int list ref = ref [0] in (* A stack of alignment columns *)
   398: 
   399:   let wantIndent = ref false in
   400:   (* Use this function to take a newline *)
   401:   (* AB: modified it to flag wantIndent. The actual indentation is done only
   402:      if leftflush is not encountered *)
   403:   let newline () =
   404:     match !aligns with
   405:       [] -> failwith "Ran out of aligns"
   406:     | x :: _ ->
   407:         emitString "\n" 1;
   408:         incr countNewLines;
   409:         wantIndent := true;
   410:         x
   411:   in
   412:   (* Print indentation if wantIndent was previously flagged ; reset this flag *)
   413:   let indentIfNeeded () =
   414:     if !printIndent && !wantIndent then ignore (
   415:       match !aligns with
   416:         [] -> failwith "Ran out of aligns"
   417:       | x :: _ ->
   418:           if x > 0 then emitString " "  x;
   419:           x);
   420:     wantIndent := false
   421:   in
   422:   (* A continuation passing style loop *)
   423:   let rec loopCont (abscol: int) (d: doc) (cont: int -> unit) : unit
   424:       (* the new column *) =
   425:     match d with
   426:       Nil -> cont abscol
   427:     | Concat (d1, d2) ->
   428:         loopCont abscol d1 (fun abscol' -> loopCont abscol' d2 cont)
   429: 
   430:     | Text s when shallowAlign () ->
   431:         let sl = String.length s in
   432:         indentIfNeeded ();
   433:         emitString s 1;
   434:         cont (abscol + sl)
   435: 
   436:     | CText (d, s) ->
   437:         loopCont abscol d
   438:           (fun abscol' ->
   439:             if shallowAlign () then
   440:               let sl = String.length s in
   441:               indentIfNeeded ();
   442:               emitString s 1;
   443:               cont (abscol' + sl)
   444:             else
   445:               cont abscol')
   446: 
   447:     | Align ->
   448:         aligns := abscol :: !aligns;
   449:         if enterAlign () then begin
   450:           indentIfNeeded ();
   451:           emitString "..." 1;
   452:           cont (abscol + 3)
   453:         end else
   454:           cont abscol
   455: 
   456:     | Unalign -> begin
   457:         match !aligns with
   458:           [] -> failwith "Unmatched unalign"
   459:         | _ :: rest ->
   460:             exitAlign ();
   461:             aligns := rest; cont abscol
   462:     end
   463:     | Line when shallowAlign ()  -> cont (newline ())
   464:     | LeftFlush when shallowAlign () -> wantIndent := false;  cont (0)
   465:     | Break when shallowAlign () -> begin
   466:         match !breaks with
   467:           [] -> failwith "Break without a takenref"
   468:         | istaken :: rest ->
   469:             breaks := rest; (* Consume the break *)
   470:             if !istaken then cont (newline ())
   471:             else begin
   472:               indentIfNeeded ();
   473:               emitString " " 1;
   474:               cont (abscol + 1)
   475:             end
   476:     end
   477: 
   478:     | Mark ->
   479:         activeMarkups := abscol :: !activeMarkups;
   480:         cont abscol
   481: 
   482:     | Unmark -> begin
   483:         match !activeMarkups with
   484:           old :: rest -> activeMarkups := rest;
   485:                          cont old
   486:         | [] -> failwith "Unmark without a mark"
   487:     end
   488: 
   489:     | _ -> (* Align is too deep *)
   490:         cont abscol
   491:   in
   492: 
   493:   loopCont 0 d (fun x -> ())
   494: 
   495: 
   496: (* Print a document on a channel *)
   497: let fprint (chn: out_channel) ~(width: int) doc =
   498:   maxCol := width;
   499:   breaks := [];
   500:   alignDepth := 0;
   501:   activeMarkups := [];
   502:   ignore (scan 0 doc);
   503:   breaks := List.rev !breaks;
   504:   alignDepth := 0;
   505:   ignore (emitDoc
   506:             (fun s nrcopies ->
   507:               for i = 1 to nrcopies do
   508:                 output_string chn s
   509:               done) doc);
   510:   activeMarkups := [];
   511:   breaks := [] (* We must do this especially if we don't do emit (which
   512:                 * consumes breaks) because otherwise we waste memory *)
   513: 
   514: (* Print the document to a string *)
   515: let sprint ~(width : int)  doc : string =
   516:   maxCol := width;
   517:   breaks := [];
   518:   activeMarkups := [];
   519:   alignDepth := 0;
   520:   ignore (scan 0 doc);
   521:   breaks := List.rev !breaks;
   522:   let buf = Buffer.create 1024 in
   523:   let rec add_n_strings str num =
   524:     if num <= 0 then ()
   525:     else begin Buffer.add_string buf str; add_n_strings str (num - 1) end
   526:   in
   527:   alignDepth := 0;
   528:   emitDoc add_n_strings doc;
   529:   breaks  := [];
   530:   activeMarkups := [];
   531:   Buffer.contents buf
   532: 
   533: 
   534:                                         (* The rest is based on printf.ml *)
   535: (*
   536: external format_int: string -> int -> string = "format_int"
   537: external format_float: string -> float -> string = "format_float"
   538: *)
   539: let format_int fmt x = string_of_int x
   540: let format_float fmt x = string_of_float x
   541: 
   542: let gprintf (finish : doc -> doc)
   543:     (format : ('a, unit, doc) format) : 'a =
   544:   let format = (Obj.magic format : string) in
   545: 
   546:   (* Record the starting align depth *)
   547:   let startAlignDepth = !alignDepth in
   548:   (* Special concatenation functions *)
   549:   let dconcat (acc: doc) (another: doc) =
   550:     if !alignDepth > !printDepth then acc else acc ++ another in
   551:   let dctext1 (acc: doc) (str: string) =
   552:     if !alignDepth > !printDepth then acc else
   553:     CText(acc, str)
   554:   in
   555:   (* Special finish function *)
   556:   let dfinish dc =
   557:     if !alignDepth <> startAlignDepth then
   558:       prerr_string ("Unmatched align/unalign in " ^ format ^ "\n");
   559:     finish dc
   560:   in
   561:   let flen    = String.length format in
   562:                                         (* Reading a format character *)
   563:   let fget    = String.unsafe_get format in
   564:                                         (* Output a literal sequence of
   565:                                          * characters, starting at i. The
   566:                                          * character at i does not need to be
   567:                                          * checked.  *)
   568:   let rec literal acc i =
   569:     let rec skipChars j =
   570:       if j >= flen ||
   571:       (match fget j with
   572:         '%' -> true
   573:       | '@' -> true
   574:       | '\n' -> true
   575:       | _ -> false) then
   576:         collect (dctext1 acc (String.sub format i (j-i))) j
   577:       else
   578:         skipChars (succ j)
   579:     in
   580:     skipChars (succ i)
   581:                                         (* the main collection function *)
   582:   and collect (acc: doc) (i: int) =
   583:     if i >= flen then begin
   584:       Obj.magic (dfinish acc)
   585:     end else begin
   586:       let c = fget i in
   587:       if c = '%' then begin
   588:         let j = skip_args (succ i) in
   589:         match fget j with
   590:           '%' -> literal acc j
   591:         | 's' ->
   592:             Obj.magic(fun s ->
   593:               let str =
   594:                 if j <= i+1 then
   595:                   s
   596:                 else
   597:                   let sl = String.length s in
   598:                   let p =
   599:                     try
   600:                       int_of_string (String.sub format (i+1) (j-i-1))
   601:                     with _ ->
   602:                       invalid_arg "fprintf: bad %s format" in
   603:                   if p > 0 && sl < p then
   604:                     (String.make (p - sl) ' ') ^ s
   605:                   else if p < 0 && sl < -p then
   606:                     s ^ (String.make (-p - sl) ' ')
   607:                   else
   608:                     s
   609:               in
   610:               collect (breakString acc str) (succ j))
   611:         | 'c' ->
   612:             Obj.magic(fun c ->
   613:               collect (dctext1 acc (String.make 1 c)) (succ j))
   614:         | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
   615:             Obj.magic(fun n ->
   616:               collect (dctext1 acc
   617:                          (format_int (String.sub format i
   618:                                                   (j-i+1)) n))
   619:                 (succ j))
   620:     (* L, l, and n are the Int64, Int32, and Nativeint modifiers to the integer
   621:        formats d,i,o,x,X,u.  For example, %Lo means print an Int64 in octal.*)
   622:         | 'L' ->
   623:             if j != i + 1 then  (*Int64.format handles simple formats like %d.
   624:                      * Any special flags eaten by skip_args will confuse it. *)
   625:               invalid_arg ("dprintf: unimplemented format "
   626:                            ^ (String.sub format i (j-i+1)));
   627:             let j' = succ j in (* eat the d,i,x etc. *)
   628:             let format_spec = "% " in
   629:             String.set format_spec 1 (fget j'); (* format_spec = "%x", etc. *)
   630:             Obj.magic(fun n ->
   631:               collect (dctext1 acc
   632:                          (Int64.format format_spec n))
   633:                 (succ j'))
   634:         | 'l' ->
   635:             if j != i + 1 then invalid_arg ("dprintf: unimplemented format "
   636:                                             ^ (String.sub format i (j-i+1)));
   637:             let j' = succ j in (* eat the d,i,x etc. *)
   638:             let format_spec = "% " in
   639:             String.set format_spec 1 (fget j'); (* format_spec = "%x", etc. *)
   640:             Obj.magic(fun n ->
   641:               collect (dctext1 acc
   642:                          (Int32.format format_spec n))
   643:                 (succ j'))
   644:         | 'n' ->
   645:             if j != i + 1 then invalid_arg ("dprintf: unimplemented format "
   646:                                             ^ (String.sub format i (j-i+1)));
   647:             let j' = succ j in (* eat the d,i,x etc. *)
   648:             let format_spec = "% " in
   649:             String.set format_spec 1 (fget j'); (* format_spec = "%x", etc. *)
   650:             Obj.magic(fun n ->
   651:               collect (dctext1 acc
   652:                          (Nativeint.format format_spec n))
   653:                 (succ j'))
   654:         | 'f' | 'e' | 'E' | 'g' | 'G' ->
   655:             Obj.magic(fun f ->
   656:               collect (dctext1 acc
   657:                          (format_float (String.sub format i (j-i+1)) f))
   658:                 (succ j))
   659:         | 'b' ->
   660:             Obj.magic(fun b ->
   661:               collect (dctext1 acc (string_of_bool b)) (succ j))
   662:         | 'a' ->
   663:             Obj.magic(fun pprinter arg ->
   664:               collect (dconcat acc (pprinter () arg)) (succ j))
   665:         | 't' ->
   666:             Obj.magic(fun pprinter ->
   667:               collect (dconcat acc (pprinter ())) (succ j))
   668:         | c ->
   669:             invalid_arg ("dprintf: unknown format %s" ^ String.make 1 c)
   670: 
   671:       end else if c = '@' then begin
   672:         if i + 1 < flen then begin
   673:           match fget (succ i) with
   674: 
   675:                                         (* Now the special format characters *)
   676:             '[' ->                      (* align *)
   677:               let newacc =
   678:                 if !alignDepth > !printDepth then
   679:                   acc
   680:                 else if !alignDepth = !printDepth then
   681:                   CText(acc, "...")
   682:                 else
   683:                   acc ++ align
   684:               in
   685:               incr alignDepth;
   686:               collect newacc (i + 2)
   687: 
   688:           | ']' ->                        (* unalign *)
   689:               decr alignDepth;
   690:               let newacc =
   691:                 if !alignDepth >= !printDepth then
   692:                   acc
   693:                 else
   694:                   acc ++ unalign
   695:               in
   696:               collect newacc (i + 2)
   697:           | '!' ->                        (* hard-line break *)
   698:               collect (dconcat acc line) (i + 2)
   699:           | '?' ->                        (* soft line break *)
   700:               collect (dconcat acc (break)) (i + 2)
   701:           | '<' ->
   702:               collect (dconcat acc mark) (i +1)
   703:           | '>' ->
   704:               collect (dconcat acc unmark) (i +1)
   705:           | '^' ->                        (* left-flushed *)
   706:               collect (dconcat acc (leftflush)) (i + 2)
   707:           | '@' ->
   708:               collect (dctext1 acc "@") (i + 2)
   709:           | c ->
   710:               invalid_arg ("dprintf: unknown format @" ^ String.make 1 c)
   711:         end else
   712:           invalid_arg "dprintf: incomplete format @"
   713:       end else if c = '\n' then begin
   714:         collect (dconcat acc line) (i + 1)
   715:       end else
   716:         literal acc i
   717:     end
   718: 
   719:   and skip_args j =
   720:     match String.unsafe_get format j with
   721:       '0' .. '9' | ' ' | '.' | '-' -> skip_args (succ j)
   722:     | c -> j
   723: 
   724:   in
   725:   collect Nil 0
   726: 
   727: let withPrintDepth dp thunk =
   728:   let opd = !printDepth in
   729:   printDepth := dp;
   730:   thunk ();
   731:   printDepth := opd
   732: 
   733: 
   734: 
   735: let flushOften = ref false
   736: 
   737: let dprintf format     = gprintf (fun x -> x) format
   738: let fprintf chn format =
   739:   let f d = fprint chn 80 d; d in
   740:         (* weimeric hack begins -- flush output to streams *)
   741:   let res = gprintf f format in
   742:         (* save the value we would have returned, flush the channel and then
   743:          * return it -- this allows us to see debug input near infinite loops
   744:          * *)
   745:   if !flushOften then flush chn;
   746:   res
   747:         (* weimeric hack ends *)
   748: 
   749: let printf format = fprintf stdout format
   750: let eprintf format = fprintf stderr format
   751: 
   752: 
   753: 
   754: (******************************************************************************)
   755: let getAlgoName = function
   756:     George -> "George"
   757:   | Aman   -> "Aman"
   758:   | Gap    -> "Gap"
   759: 
   760: let getAboutString () : string =
   761:   "(Flx_cil_pretty: ALGO=" ^ (getAlgoName algo) ^ ")"
   762: 
   763: 
End ocaml section to src/flx_cil_pretty.ml[1]
Start ocaml section to src/flx_cil_pretty.mli[1 /1 ]
     1: # 22004 "./lpsrc/flx_cil.ipk"
     2: (** Flx_cil_utility functions for pretty-printing. The major features provided by
     3:     this module are
     4: - An [fprintf]-style interface with support for user-defined printers
     5: - The printout is fit to a width by selecting some of the optional newlines
     6: - Constructs for alignment and indentation
     7: - Print ellipsis starting at a certain nesting depth
     8: - Constructs for printing lists and arrays
     9: 
    10:  Flx_cil_pretty-printing occurs in two stages:
    11: - Construct a {!Flx_cil_pretty.doc} object that encodes all of the elements to be
    12:   printed
    13:   along with alignment specifiers and optional and mandatory newlines
    14: - Format the {!Flx_cil_pretty.doc} to a certain width and emit it as a string, to an
    15:   output stream or pass it to a user-defined function
    16: 
    17:  The formatting algorithm is not optimal but it does a pretty good job while
    18:  still operating in linear time. The original version was based on a pretty
    19:  printer by Philip Wadler which turned out to not scale to large jobs.
    20: *)
    21: 
    22: (** API *)
    23: 
    24: (** The type of unformated documents. Elements of this type can be
    25:  * constructed in two ways. Either with a number of constructor shown below,
    26:  * or using the {!Flx_cil_pretty.dprintf} function with a [printf]-like interface.
    27:  * The {!Flx_cil_pretty.dprintf} method is slightly slower so we do not use it for
    28:  * large jobs such as the output routines for a compiler. But we use it for
    29:  * small jobs such as logging and error messages. *)
    30: type doc
    31: 
    32: 
    33: 
    34: (** Constructors for the doc type. *)
    35: 
    36: 
    37: 
    38: 
    39: (** Constructs an empty document *)
    40: val nil          : doc
    41: 
    42: 
    43: (** Concatenates two documents. This is an infix operator that associates to
    44:     the left. *)
    45: val (++)         : doc -> doc -> doc
    46: 
    47: 
    48: (** A document that prints the given string *)
    49: val text         : string -> doc
    50: 
    51: 
    52: (** A document that prints an integer in decimal form *)
    53: val num          : int    -> doc
    54: 
    55: 
    56: (** A document that prints a real number *)
    57: val real         : float  -> doc
    58: 
    59: (** A document that prints a character. This is just like {!Flx_cil_pretty.text}
    60:     with a one-character string. *)
    61: val chr          : char   -> doc
    62: 
    63: 
    64: (** A document that consists of a mandatory newline. This is just like [(text
    65:     "\n")]. The new line will be indented to the current indentation level,
    66:     unless you use {!Flx_cil_pretty.leftflush} right after this. *)
    67: val line         : doc
    68: 
    69: (** Use after a {!Flx_cil_pretty.line} to prevent the indentation. Whatever follows
    70:  * next will be flushed left. Indentation resumes on the next line. *)
    71: val leftflush    : doc
    72: 
    73: 
    74: (** A document that consists of either a space or a line break. Also called
    75:     an optional line break. Such a break will be
    76:     taken only if necessary to fit the document in a given width. If the break
    77:     is not taken a space is printed instead. *)
    78: val break: doc
    79: 
    80: (** Mark the current column as the current indentation level. Does not print
    81:     anything. All taken line breaks will align to this column. The previous
    82:     alignment level is saved on a stack. *)
    83: val align: doc
    84: 
    85: (** Reverts to the last saved indentation level. *)
    86: val unalign: doc
    87: 
    88: 
    89: (** Mark the beginning of a markup section. The width of a markup section is
    90:  * considered 0 for the purpose of computing identation *)
    91: val mark: doc
    92: 
    93: (** The end of a markup section *)
    94: val unmark: doc
    95: 
    96: (************* Now some syntactic sugar *****************)
    97: (** Syntactic sugar *)
    98: 
    99: (** Indents the document. Same as [((text "  ") ++ align ++ doc ++ unalign)],
   100:     with the specified number of spaces. *)
   101: val indent: int -> doc -> doc
   102: 
   103: (** Prints a document as markup. The marked document cannot contain line
   104:  * breaks or alignment constructs. *)
   105: val markup: doc -> doc
   106: 
   107: (** Formats a sequence. [sep] is a separator, [doit] is a function that
   108:  * converts an element to a document. *)
   109: val seq: sep:doc -> doit:('a ->doc) -> elements:'a list -> doc
   110: 
   111: 
   112: (** An alternative function for printing a list. The [unit] argument is there
   113:  * to make this function more easily usable with the {!Flx_cil_pretty.dprintf}
   114:  * interface. *)
   115: val docList: doc -> ('a -> doc) -> unit -> 'a list -> doc
   116: 
   117: (** sm: Yet another list printer.  This one accepts the same kind of
   118:   * printing function that {!Flx_cil_pretty.dprintf} does, and itself works
   119:   * in the dprintf context.  Also accepts
   120:   * a string as the separator since that's by far the most common.  *)
   121: val d_list: string -> (unit -> 'a -> doc) -> unit -> 'a list -> doc
   122: 
   123: (** Formats an array. A separator and a function that prints an array
   124:     element *)
   125: val docArray: doc -> (int -> 'a -> doc) -> unit -> 'a array -> doc
   126: 
   127: (** Prints an ['a option] with [None] or [Some] *)
   128: val docOpt: (unit -> 'a -> doc) -> unit -> 'a option -> doc
   129: 
   130: 
   131: (** A function that is useful with the [printf]-like interface *)
   132: val insert: unit -> doc -> doc
   133: 
   134: val dprintf: ('a, unit, doc) format -> 'a
   135: (** This function provides an alternative method for constructing
   136:     [doc] objects. The first argument for this function is a format string
   137:     argument (of type [('a, unit, doc) format]; if you insist on
   138:     understanding what that means see the module [Printf]). The format string
   139:     is like that for the [printf] function in C, except that it understands a
   140:     few more formatting controls, all starting with the @ character.
   141: 
   142:  The following special formatting characters are understood (these do not
   143:  correspond to arguments of the function):
   144: -  @\[ Inserts an {!Flx_cil_pretty.align}. Every format string must have matching
   145:         {!Flx_cil_pretty.align} and {!Flx_cil_pretty.unalign}.
   146: -  @\] Inserts an {!Flx_cil_pretty.unalign}.
   147: -  @!  Inserts a {!Flx_cil_pretty.line}. Just like "\n"
   148: -  @?  Inserts a {!Flx_cil_pretty.break}.
   149: -  @<  Inserts a {!Flx_cil_pretty.mark}.
   150: -  @<  Inserts a {!Flx_cil_pretty.unmark}.
   151: -  @^  Inserts a {!Flx_cil_pretty.leftflush}
   152:        Should be used immediately after @! or "\n".
   153: -  @@ : inserts a @ character
   154: 
   155:  In addition to the usual [printf] % formatting characters the following two
   156:  new characters are supported:
   157: - %t Corresponds to an argument of type [unit -> doc]. This argument is
   158:      invoked to produce a document
   159: - %a Corresponds to {b two} arguments. The first of type [unit -> 'a -> doc]
   160:      and the second of type ['a]. (The extra [unit] is do to the
   161:      peculiarities of the built-in support for format strings in Ocaml. It
   162:      turns out that it is not a major problem.) Here is an example of how
   163:      you use this:
   164: 
   165: {v dprintf "Name=%s, SSN=%7d, Children=\@\[%a\@\]\n"
   166:              pers.name pers.ssn (docList (chr ',' ++ break) text)
   167:              pers.children v}
   168: 
   169:  The result of [dprintf] is a {!Flx_cil_pretty.doc}. You can format the document and
   170:  emit it using the functions {!Flx_cil_pretty.fprint} and {!Flx_cil_pretty.sprint}.
   171: 
   172: *)
   173: 
   174: (** Format the document to the given width and emit it to the given channel *)
   175: val fprint: out_channel -> width:int -> doc -> unit
   176: 
   177: (** Format the document to the given width and emit it as a string *)
   178: val sprint: width:int -> doc -> string
   179: 
   180: (** Like {!Flx_cil_pretty.dprintf} followed by {!Flx_cil_pretty.fprint} *)
   181: val fprintf: out_channel -> ('a, unit, doc) format -> 'a
   182: 
   183: (** Like {!Flx_cil_pretty.fprintf} applied to [stdout] *)
   184: val printf: ('a, unit, doc) format -> 'a
   185: 
   186: (** Like {!Flx_cil_pretty.fprintf} applied to [stderr] *)
   187: val eprintf: ('a, unit, doc) format -> 'a
   188: 
   189: (** Like {!Flx_cil_pretty.dprintf} but more general. It also takes a function that is
   190:  * invoked on the constructed document but before any formatting is done. *)
   191: val gprintf: (doc -> doc) -> ('a, unit, doc) format -> 'a
   192: 
   193: (* sm: arg!  why can't I write this function?! *)
   194: (* * Like {!Flx_cil_pretty.dprintf} but yielding a string with no newlines *)
   195: (*val sprintf: (doc, unit, doc) format -> string*)
   196: 
   197: (* sm: different tack.. *)
   198: (* doesn't work either.  well f it anyway *)
   199: (*val failwithf: ('a, unit, doc) format -> 'a*)
   200: 
   201: 
   202: (** Invokes a thunk, with printDepth temporarily set to the specified value *)
   203: val withPrintDepth : int -> (unit -> unit) -> unit
   204: 
   205: (** The following variables can be used to control the operation of the printer *)
   206: 
   207: (** Specifies the nesting depth of the [align]/[unalign] pairs at which
   208:     everything is replaced with ellipsis *)
   209: val printDepth   : int ref
   210: 
   211: val printIndent  : bool ref  (** If false then does not indent *)
   212: 
   213: 
   214: (** If set to [true] then optional breaks are taken only when the document
   215:     has exceeded the given width. This means that the printout will looked
   216:     more ragged but it will be faster *)
   217: val fastMode  : bool ref
   218: 
   219: val flushOften   : bool ref  (** If true the it flushes after every print *)
   220: 
   221: 
   222: (** Keep a running count of the taken newlines. You can read and write this
   223:   * from the client code if you want *)
   224: val countNewLines : int ref
End ocaml section to src/flx_cil_pretty.mli[1]
Start ocaml section to src/flx_cil_stats.ml[1 /1 ]
     1: # 22229 "./lpsrc/flx_cil.ipk"
     2: (* The following functions are implemented in perfcount.c *)
     3: 
     4: (* Returns true is we have the performance counters *)
     5: external has_performance_counters: unit -> bool = "has_performance_counters"
     6: 
     7: (* Returns number of seconds since the first read *)
     8: external read_pentium_perfcount : unit -> float = "read_pentium_perfcount"
     9: 
    10: 
    11: 
    12: (* Whether to use the performance counters (on Pentium only) *)
    13: 
    14: (* The performance counters are disabled by default. *)
    15: let do_use_performance_counters = ref false
    16: 
    17:                                         (* A hierarchy of timings *)
    18: 
    19: type t = { name : string;
    20:            mutable time : float; (* In seconds *)
    21:            mutable sub  : t list}
    22: 
    23:                                         (* Create the top level *)
    24: let top = { name = "TOTAL";
    25:             time = 0.0;
    26:             sub  = []; }
    27: 
    28:                                         (* The stack of current path through
    29:                                          * the hierarchy. The first is the
    30:                                          * leaf. *)
    31: let current : t list ref = ref [top]
    32: 
    33: exception NoPerfCount
    34: let reset (perfcount: bool) =
    35:   top.sub <- [];
    36:   if perfcount then begin
    37:     if not (has_performance_counters ()) then begin
    38:       raise NoPerfCount
    39:     end
    40:   end;
    41:   do_use_performance_counters := perfcount
    42: 
    43: 
    44: 
    45: let print chn msg =
    46:   (* Total up *)
    47:   top.time <- List.fold_left (fun sum f -> sum +. f.time) 0.0 top.sub;
    48:   let rec prTree ind node =
    49:     if !do_use_performance_counters then
    50:       (Printf.fprintf chn "%s%-20s          %8.5f s\n"
    51:          (String.make ind ' ') node.name node.time)
    52:     else
    53:       (Printf.fprintf chn "%s%-20s          %6.3f s\n"
    54:          (String.make ind ' ') node.name node.time);
    55: 
    56:    List.iter (prTree (ind + 2)) node.sub
    57:   in
    58:   Printf.fprintf chn "%s" msg;
    59:   List.iter (prTree 0) [ top ];
    60:   Printf.fprintf chn "Timing used %s\n"
    61:     (if !do_use_performance_counters then "performance counters" else "Unix.time");
    62:   ()
    63: 
    64: 
    65: 
    66: (* Get the current time, in seconds *)
    67: let get_current_time () : float =
    68:   if !do_use_performance_counters then
    69:     read_pentium_perfcount ()
    70:   else
    71:     (Unix.times ()).Unix.tms_utime
    72: 
    73: let repeattime limit str f arg =
    74:                                         (* Find the right stat *)
    75:   let stat : t =
    76:     let curr = match !current with h :: _ -> h | _ -> assert false in
    77:     let rec loop = function
    78:         h :: _ when h.name = str -> h
    79:       | _ :: rest -> loop rest
    80:       | [] ->
    81:           let nw = {name = str; time = 0.0; sub = []} in
    82:           curr.sub <- nw :: curr.sub;
    83:           nw
    84:     in
    85:     loop curr.sub
    86:   in
    87:   let oldcurrent = !current in
    88:   current := stat :: oldcurrent;
    89:   let start = get_current_time () in
    90:   let rec loop count =
    91:     let res   = f arg in
    92:     let diff = get_current_time () -. start in
    93:     if diff < limit then
    94:       loop (count + 1)
    95:     else begin
    96:       stat.time <- stat.time +. (diff /. float(count));
    97:       current := oldcurrent;                (* Pop the current stat *)
    98:       res                                   (* Return the function result *)
    99:     end
   100:   in
   101:   loop 1
   102: 
   103: 
   104: let time str f arg = repeattime 0.0 str f arg
   105: 
   106: 
   107: 
   108: 
   109: 
   110: 
   111: 
   112: 
   113: 
   114: 
   115: 
   116: 
   117: 
   118: 
   119: 
End ocaml section to src/flx_cil_stats.ml[1]
Start ocaml section to src/flx_cil_stats.mli[1 /1 ]
     1: # 22349 "./lpsrc/flx_cil.ipk"
     2: (** Flx_cil_utilities for maintaining timing statistics *)
     3: 
     4: (** Resets all the timings. Invoke with "true" if you want to switch to using
     5:  * the hardware performance counters from now on. You get an exception if
     6:  * there are not performance counters available *)
     7: val reset: bool -> unit
     8: exception NoPerfCount
     9: 
    10: (** Flx_cil_check if we have performance counters *)
    11: val has_performance_counters: unit -> bool
    12: 
    13: (** Time a function and associate the time with the given string. If some
    14:     timing information is already associated with that string, then accumulate
    15:     the times. If this function is invoked within another timed function then
    16:     you can have a hierarchy of timings *)
    17: val time : string -> ('a -> 'b) -> 'a -> 'b
    18: 
    19: (** repeattime is like time but runs the function several times until the total
    20:     running time is greater or equal to the first argument. The total time is
    21:     then divided by the number of times the function was run. *)
    22: val repeattime : float -> string -> ('a -> 'b) -> 'a -> 'b
    23: 
    24: (** Print the current stats preceeded by a message *)
    25: val print : out_channel -> string -> unit
    26: 
    27: 
    28: 
    29: 
    30: 
    31: 
End ocaml section to src/flx_cil_stats.mli[1]
Start ocaml section to src/flx_cil_trace.ml[1 /1 ]
     1: # 22381 "./lpsrc/flx_cil.ipk"
     2: (* Flx_cil_trace module implementation
     3:  * see trace.mli
     4:  *)
     5: 
     6: open Flx_cil_pretty;;
     7: 
     8: 
     9: (* --------- traceSubsystems --------- *)
    10: (* this is the list of tags (usually subsystem names) for which
    11:  * trace output will appear *)
    12: let traceSubsystems : string list ref = ref [];;
    13: 
    14: 
    15: let traceAddSys (subsys : string) : unit =
    16:   (* (ignore (printf "traceAddSys %s\n" subsys)); *)
    17:   traceSubsystems := subsys :: !traceSubsystems
    18: ;;
    19: 
    20: 
    21: let traceActive (subsys : string) : bool =
    22:   (* (List.mem elt list) returns true if something in list equals ('=') elt *)
    23:   (List.mem subsys !traceSubsystems)
    24: ;;
    25: 
    26: 
    27: let rec parseString (str : string) (delim : char) : string list =
    28: begin
    29:   if (not (String.contains str delim)) then
    30:     if ((String.length str) = 0) then
    31:       []
    32:     else
    33:       [str]
    34: 
    35:   else
    36:     let d = ((String.index str delim) + 1) in
    37:     if (d = 1) then
    38:       (* leading delims are eaten *)
    39:       (parseString (String.sub str d ((String.length str) - d)) delim)
    40:     else
    41:       (String.sub str 0 (d-1)) ::
    42:         (parseString (String.sub str d ((String.length str) - d)) delim)
    43: end;;
    44: 
    45: let traceAddMulti (systems : string) : unit =
    46: begin
    47:   let syslist = (parseString systems ',') in
    48:   (List.iter traceAddSys syslist)
    49: end;;
    50: 
    51: 
    52: 
    53: (* --------- traceIndent --------- *)
    54: let traceIndentLevel : int ref = ref 0;;
    55: 
    56: 
    57: let traceIndent (sys : string) : unit =
    58:   if (traceActive sys) then
    59:     traceIndentLevel := !traceIndentLevel + 2
    60: ;;
    61: 
    62: let traceOutdent (sys : string) : unit =
    63:   if ((traceActive sys) &&
    64:       (!traceIndentLevel >= 2)) then
    65:     traceIndentLevel := !traceIndentLevel - 2
    66: ;;
    67: 
    68: 
    69: (* --------- trace --------- *)
    70: (* return a tag to prepend to a trace output
    71:  * e.g. "  %%% mysys: "
    72:  *)
    73: let traceTag (sys : string) : Flx_cil_pretty.doc =
    74:   (* return string of 'i' spaces *)
    75:   let rec ind (i : int) : string =
    76:     if (i <= 0) then
    77:       ""
    78:     else
    79:       " " ^ (ind (i-1))
    80: 
    81:   in
    82:   (text ((ind !traceIndentLevel) ^ "%%% " ^ sys ^ ": "))
    83: ;;
    84: 
    85: 
    86: (* this is the trace function; its first argument is a string
    87:  * tag, and subsequent arguments are like printf formatting
    88:  * strings ("%a" and whatnot) *)
    89: let trace
    90:     (subsys : string)                   (* subsystem identifier for enabling tracing *)
    91:     (d : Flx_cil_pretty.doc)                    (* something made by 'dprintf' *)
    92:     : unit =                            (* no return value *)
    93:   (* (ignore (printf "trace %s\n" subsys)); *)
    94: 
    95:   (* see if the subsystem's tracing is turned on *)
    96:   if (traceActive subsys) then
    97:     begin
    98:       (fprint stderr 80                 (* print it *)
    99:          ((traceTag subsys) ++ d));     (* with prepended subsys tag *)
   100:       (* mb: flush after every message; useful if the program hangs in an
   101:          infinite loop... *)
   102:       (flush stderr)
   103:     end
   104:   else
   105:     ()                                           (* eat it *)
   106: ;;
   107: 
   108: 
   109: let tracei (sys : string) (d : Flx_cil_pretty.doc) : unit =
   110:   (* trace before indent *)
   111:   (trace sys d);
   112:   (traceIndent sys)
   113: ;;
   114: 
   115: let traceu (sys : string) (d : Flx_cil_pretty.doc) : unit =
   116:   (* trace after outdent *)
   117:   (* no -- I changed my mind -- I want trace *then* outdent *)
   118:   (trace sys d);
   119:   (traceOutdent sys)
   120: ;;
   121: 
   122: 
   123: 
   124: 
   125: (* -------------------------- trash --------------------- *)
   126: (* TRASH START
   127: 
   128: (* sm: more experimenting *)
   129: (trace "no" (dprintf "no %d\n" 5));
   130: (trace "yes" (dprintf "yes %d\n" 6));
   131: (trace "maybe" (dprintf "maybe %d\n" 7));
   132: 
   133: TRASH END *)
End ocaml section to src/flx_cil_trace.ml[1]
Start ocaml section to src/flx_cil_trace.mli[1 /1 ]
     1: # 22515 "./lpsrc/flx_cil.ipk"
     2: (* Flx_cil_trace module
     3:  * Scott McPeak, 5/4/00
     4:  *
     5:  * The idea is to pepper the source with debugging printfs,
     6:  * and be able to select which ones to actually display at
     7:  * runtime.
     8:  *
     9:  * It is built on top of the Flx_cil_pretty module for printing data
    10:  * structures.
    11:  *
    12:  * To a first approximation, this is needed to compensate for
    13:  * the lack of a debugger that does what I want...
    14:  *)
    15: 
    16: 
    17: (* this is the list of tags (usually subsystem names) for which
    18:  * trace output will appear *)
    19: val traceSubsystems : string list ref
    20: 
    21: (* interface to add a new subsystem to trace (slightly more
    22:  * convenient than direclty changing 'tracingSubsystems') *)
    23: val traceAddSys : string -> unit
    24: 
    25: (* query whether a particular subsystem is being traced *)
    26: val traceActive : string -> bool
    27: 
    28: (* add several systems, separated by commas *)
    29: val traceAddMulti : string -> unit
    30: 
    31: 
    32: (* current indentation level for tracing *)
    33: val traceIndentLevel : int ref
    34: 
    35: (* bump up or down the indentation level, if the given subsys
    36:  * is being traced *)
    37: val traceIndent : string -> unit
    38: val traceOutdent : string -> unit
    39: 
    40: 
    41: (* this is the trace function; its first argument is a string
    42:  * tag, and second argument is a 'doc' (which is what 'dprintf'
    43:  * returns).
    44:  *
    45:  * so a sample usage might be
    46:  *   (trace "mysubsys" (dprintf "something neat happened %d times\n" counter))
    47:  *)
    48: val trace : string -> Flx_cil_pretty.doc -> unit
    49: 
    50: 
    51: (* special flavors that indent/outdent as well.  the indent version
    52:  * indents *after* printing, while the outdent version outdents
    53:  * *before* printing.  thus, a sequence like
    54:  *
    55:  *   (tracei "foo" (dprintf "beginning razzle-dazzle\n"))
    56:  *     ..razzle..
    57:  *     ..dazzle..
    58:  *   (traceu "foo" (dprintf "done with razzle-dazzle\n"))
    59:  *
    60:  * will do the right thing
    61:  *
    62:  * update -- I changed my mind!  I decided I prefer it like this
    63:  *   %%% sys: (myfunc args)
    64:  *     %%% ...inner stuff...
    65:  *     %%% sys: myfunc returning 56
    66:  *
    67:  * so now they both print before in/outdenting
    68:  *)
    69: val tracei : string -> Flx_cil_pretty.doc -> unit
    70: val traceu : string -> Flx_cil_pretty.doc -> unit
    71: 
    72: 
End ocaml section to src/flx_cil_trace.mli[1]
Start ocaml section to src/flx_cil_util.mli[1 /1 ]
     1: # 22588 "./lpsrc/flx_cil.ipk"
     2: (** A bunch of generally useful functions *)
     3: 
     4: exception GotSignal of int
     5: 
     6: val withTimeout : float -> (* Seconds for timeout *)
     7:                 (int -> 'b) -> (* What to do if we have a timeout. The
     8:                                         * argument passed is the signal number
     9:                                         * received. *)
    10:                 ('a -> 'b) -> (* The function to run *)
    11:                 'a -> (* And its argument *)
    12:    'b
    13: 
    14: val docHash : ('a -> 'b -> Flx_cil_pretty.doc) -> unit ->
    15:   (('a, 'b) Hashtbl.t) -> Flx_cil_pretty.doc
    16: 
    17: 
    18: val hash_to_list: ('a, 'b) Hashtbl.t -> ('a * 'b) list
    19: 
    20: val keys: ('a, 'b) Hashtbl.t -> 'a list
    21: 
    22: 
    23: (** Copy a hash table into another *)
    24: val hash_copy_into: ('a, 'b) Hashtbl.t -> ('a, 'b) Hashtbl.t -> unit
    25: 
    26: (** First, a few utility functions I wish were in the standard prelude *)
    27: 
    28: val anticompare: 'a -> 'a -> int
    29: 
    30: val list_drop : int -> 'a list -> 'a list
    31: val list_span: ('a -> bool) -> ('a list) -> 'a list * 'a list
    32: val list_insert_by: ('a -> 'a -> int) -> 'a -> 'a list -> 'a list
    33: val list_head_default: 'a -> 'a list -> 'a
    34: val list_iter3 : ('a -> 'b -> 'c -> unit) ->
    35:   'a list -> 'b list -> 'c list -> unit
    36: val get_some_option_list : 'a option list -> 'a list
    37: 
    38: (** Iterate over a list passing the index as you go *)
    39: val list_iteri: (int -> 'a -> unit) -> 'a list -> unit
    40: val list_mapi: (int -> 'a -> 'b) -> 'a list -> 'b list
    41: 
    42: (** Like fold_left but pass the index into the list as well *)
    43: val list_fold_lefti: ('acc -> int -> 'a -> 'acc) -> 'acc -> 'a list -> 'acc
    44: 
    45: val int_range_list : int -> int -> int list
    46: 
    47: (* Create a list of length l *)
    48: val list_init : int -> (int -> 'a) -> 'a list
    49: 
    50: 
    51: (** mapNoCopy is like map but avoid copying the list if the function does not
    52:  * change the elements *)
    53: 
    54: val mapNoCopy: ('a -> 'a) -> 'a list -> 'a list
    55: 
    56: val mapNoCopyList: ('a -> 'a list) -> 'a list -> 'a list
    57: 
    58: val filterNoCopy: ('a -> bool) -> 'a list -> 'a list
    59: 
    60: (** Growable arrays *)
    61: type 'a growArrayFill =
    62:     Elem of 'a
    63:   | Susp of (int -> 'a)
    64: 
    65: type 'a growArray = {
    66:             gaFill: 'a growArrayFill;
    67:             (** Stuff to use to fill in the array as it grows *)
    68: 
    69:     mutable gaMaxInitIndex: int;
    70:             (** Maximum index that was written to. -1 if no writes have
    71:              * been made.  *)
    72: 
    73:     mutable gaData: 'a array;
    74:   }
    75: 
    76: val newGrowArray: int -> 'a growArrayFill -> 'a growArray
    77: (** [newGrowArray initsz fillhow] *)
    78: 
    79: val getReg: 'a growArray -> int -> 'a
    80: val setReg: 'a growArray -> int -> 'a -> unit
    81: val copyGrowArray: 'a growArray -> 'a growArray
    82: val deepCopyGrowArray: 'a growArray -> ('a -> 'a) -> 'a growArray
    83: 
    84: 
    85: val growArray_iteri:  (int -> 'a -> unit) -> 'a growArray -> unit
    86: (** Iterate over the initialized elements of the array *)
    87: 
    88: val growArray_foldl: ('acc -> 'a -> 'acc) -> 'acc ->'a growArray -> 'acc
    89: (** Fold left over the initialized elements of the array *)
    90: 
    91: (** hasPrefix prefix str returns true with str starts with prefix *)
    92: val hasPrefix: string -> string -> bool
    93: 
    94: 
    95: (** Given a ref cell, produce a thunk that later restores it to its current value *)
    96: val restoreRef: ?deepCopy:('a -> 'a) -> 'a ref -> unit -> unit
    97: 
    98: (** Given a hash table, produce a thunk that later restores it to its current value *)
    99: val restoreHash: ?deepCopy:('b -> 'b) -> ('a, 'b) Hashtbl.t -> unit -> unit
   100: 
   101: (** Given an array, produce a thunk that later restores it to its current value *)
   102: val restoreArray: ?deepCopy:('a -> 'a) -> 'a array -> unit -> unit
   103: 
   104: 
   105: (** Given a list of thunks, produce a thunk that runs them all *)
   106: val runThunks: (unit -> unit) list -> unit -> unit
   107: 
   108: 
   109: val memoize: ('a, 'b) Hashtbl.t ->
   110:             'a ->
   111:             ('a -> 'b) -> 'b
   112: 
   113: (** Just another name for memoize *)
   114: val findOrAdd: ('a, 'b) Hashtbl.t ->
   115:             'a ->
   116:             ('a -> 'b) -> 'b
   117: 
   118: val tryFinally:
   119:     ('a -> 'b) -> (* The function to run *)
   120:     ('b option -> unit) -> (* Something to run at the end. The None case is
   121:                           * used when an exception is thrown *)
   122:     'a -> 'b
   123: 
   124: 
   125: (** The state information that the UI must display is viewed abstractly as a
   126:  * set of registers. *)
   127: type registerInfo = {
   128:     rName: string; (** The name of the register *)
   129:     rGroup: string; (** The name of the group to which this register belongs.
   130:                      * The special group Engine.machineRegisterGroup
   131:                      * contains the machine registers, which are displayed in
   132:                      * a special window. *)
   133:     rVal: Flx_cil_pretty.doc; (** The value to be displayed about a register *)
   134:     rOneLineVal: Flx_cil_pretty.doc option (** The value to be displayed on one line *)
   135: }
   136: 
   137: 
   138: (** Get the value of an option.  Raises Failure if None *)
   139: val valOf : 'a option -> 'a
   140: 
   141: (**
   142:  * An accumulating for loop.
   143:  *
   144:  * Initialize the accumulator with init.  The current index and accumulator
   145:  * from the previous iteration is passed to f.
   146:  *)
   147: val fold_for : init:'a -> lo:int -> hi:int -> (int -> 'a -> 'a) -> 'a
   148: 
   149: (************************************************************************)
   150: 
   151: module type STACK = sig
   152:   type 'a t
   153:   (** The type of stacks containing elements of type ['a]. *)
   154: 
   155:   exception Empty
   156:   (** Raised when Stack.pop or Stack.top is applied to an empty stack. *)
   157: 
   158:   val create : unit -> 'a t
   159: 
   160: 
   161:   val push : 'a -> 'a t -> unit
   162:   (** [push x s] adds the element [x] at the top of stack [s]. *)
   163: 
   164:   val pop : 'a t -> 'a
   165:   (** [pop s] removes and returns the topmost element in stack [s],
   166:      or raises [Empty] if the stack is empty. *)
   167: 
   168:   val top : 'a t -> 'a
   169:   (** [top s] returns the topmost element in stack [s],
   170:      or raises [Empty] if the stack is empty. *)
   171: 
   172:   val clear : 'a t -> unit
   173:   (** Discard all elements from a stack. *)
   174: 
   175:   val copy : 'a t -> 'a t
   176:   (** Return a copy of the given stack. *)
   177: 
   178:   val is_empty : 'a t -> bool
   179:   (** Return [true] if the given stack is empty, [false] otherwise. *)
   180: 
   181:   val length : 'a t -> int
   182:   (** Return the number of elements in a stack. *)
   183: 
   184:   val iter : ('a -> unit) -> 'a t -> unit
   185:   (** [iter f s] applies [f] in turn to all elements of [s],
   186:      from the element at the top of the stack to the element at the
   187:      bottom of the stack. The stack itself is unchanged. *)
   188: end
   189: 
   190: module Stack : STACK
   191: 
   192: (************************************************************************
   193:    Configuration
   194: ************************************************************************)
   195: (** The configuration data can be of several types **)
   196: type configData =
   197:     ConfInt of int
   198:   | ConfBool of bool
   199:   | ConfFloat of float
   200:   | ConfString of string
   201:   | ConfList of configData list
   202: 
   203: 
   204: (** Load the configuration from a file *)
   205: val loadConfiguration: string -> unit
   206: 
   207: (** Save the configuration in a file. Overwrites the previous values *)
   208: val saveConfiguration: string -> unit
   209: 
   210: 
   211: (** Clear all configuration data *)
   212: val clearConfiguration: unit -> unit
   213: 
   214: (** Set a configuration element, with a key. Overwrites the previous values *)
   215: val setConfiguration: string -> configData -> unit
   216: 
   217: (** Find a configuration elements, given a key. Raises Not_found if it canont
   218:  * find it *)
   219: val findConfiguration: string -> configData
   220: 
   221: (** Like findConfiguration but extracts the integer *)
   222: val findConfigurationInt: string -> int
   223: 
   224: (** Looks for an integer configuration element, and if it is found, it uses
   225:  * the given function. Otherwise, does nothing *)
   226: val useConfigurationInt: string -> (int -> unit) -> unit
   227: 
   228: 
   229: val findConfigurationBool: string -> bool
   230: val useConfigurationBool: string -> (bool -> unit) -> unit
   231: 
   232: val findConfigurationString: string -> string
   233: val useConfigurationString: string -> (string -> unit) -> unit
   234: 
   235: val findConfigurationList: string -> configData list
   236: val useConfigurationList: string -> (configData list -> unit) -> unit
   237: 
   238: 
   239: (************************************************************************)
   240: 
   241: (** Symbols are integers that are uniquely associated with names *)
   242: type symbol = int
   243: 
   244: (** Get the name of a symbol *)
   245: val symbolName: symbol -> string
   246: 
   247: (** Register a symbol name and get the symbol for it *)
   248: val registerSymbolName: string -> symbol
   249: 
   250: (** Register a number of consecutive symbol ids. The naming function will be
   251:  * invoked with indices from 0 to the counter - 1. Returns the id of the
   252:  * first symbol created *)
   253: val registerSymbolRange: int -> (int -> string) -> symbol
   254: 
End ocaml section to src/flx_cil_util.mli[1]
Start ocaml section to src/flx_cil_util.ml[1 /1 ]
     1: # 22843 "./lpsrc/flx_cil.ipk"
     2: (** Flx_cil_utility functions for Coolaid *)
     3: module E = Flx_cil_errormsg
     4: module H = Hashtbl
     5: module IH = Flx_cil_inthash
     6: 
     7: open Flx_cil_pretty
     8: 
     9: exception GotSignal of int
    10: 
    11: let withTimeout (secs: float) (* Seconds for timeout *)
    12:                 (handler: int -> 'b) (* What to do if we have a timeout. The
    13:                                         * argument passed is the signal number
    14:                                         * received. *)
    15:                 (f: 'a -> 'b) (* The function to run *)
    16:                 (arg: 'a) (* And its argument *)
    17:    : 'b =
    18:   let oldHandler =
    19:     Sys.signal Sys.sigalrm
    20:       (Sys.Signal_handle
    21:          (fun i ->
    22:            ignore (E.log "Got signal %d\n" i);
    23:            raise (GotSignal i)))
    24:   in
    25:   let reset_sigalrm () =
    26:     ignore (Unix.setitimer Unix.ITIMER_REAL { Unix.it_value = 0.0;
    27:                                               Unix.it_interval = 0.0;});
    28:     Sys.set_signal Sys.sigalrm oldHandler;
    29:   in
    30:   ignore (Unix.setitimer Unix.ITIMER_REAL
    31:             { Unix.it_value    = secs;
    32:               Unix.it_interval = 0.0;});
    33:   (* ignore (Unix.alarm 2); *)
    34:   try
    35:     let res = f arg in
    36:     reset_sigalrm ();
    37:     res
    38:   with exc -> begin
    39:     reset_sigalrm ();
    40:     ignore (E.log "Got an exception\n");
    41:     match exc with
    42:       GotSignal i ->
    43:         handler i
    44:     | _ -> raise exc
    45:   end
    46: 
    47: (** Print a hash table *)
    48: let docHash (one: 'a -> 'b -> doc) () (h: ('a, 'b) H.t) =
    49:   let theDoc = ref nil in
    50:   (H.fold
    51:      (fun key data acc -> acc ++ one key data)
    52:      h
    53:      align) ++ unalign
    54: 
    55: 
    56: 
    57: let hash_to_list (h: ('a, 'b) H.t) : ('a * 'b) list =
    58:   H.fold
    59:     (fun key data acc -> (key, data) :: acc)
    60:     h
    61:     []
    62: 
    63: let keys (h: ('a, 'b) H.t) : 'a list =
    64:   H.fold
    65:     (fun key data acc -> key :: acc)
    66:     h
    67:     []
    68: 
    69: let hash_copy_into (hfrom: ('a, 'b) H.t) (hto: ('a, 'b) H.t) : unit =
    70:   H.clear hto;
    71:   H.iter (H.add hto) hfrom
    72: 
    73: let anticompare a b = compare b a
    74: ;;
    75: 
    76: 
    77: let rec list_drop (n : int) (xs : 'a list) : 'a list =
    78:   if n < 0 then invalid_arg "Flx_cil_util.list_drop";
    79:   if n = 0 then
    80:     xs
    81:   else begin
    82:     match xs with
    83:     | [] -> invalid_arg "Flx_cil_util.list_drop"
    84:     | y::ys -> list_drop (n-1) ys
    85:   end
    86: 
    87: 
    88: let rec list_span (p : 'a -> bool) (xs : 'a list) : 'a list * 'a list =
    89:   begin match xs with
    90:   | [] -> ([],[])
    91:   | x::xs' ->
    92:       if p x then
    93:         let (ys,zs) = list_span p xs' in (x::ys,zs)
    94:       else ([],xs)
    95:   end
    96: ;;
    97: 
    98: let rec list_rev_append revxs ys =
    99:   begin match revxs with
   100:   | [] -> ys
   101:   | x::xs -> list_rev_append xs (x::ys)
   102:   end
   103: ;;
   104: let list_insert_by (cmp : 'a -> 'a -> int)
   105:     (x : 'a) (xs : 'a list) : 'a list =
   106:   let rec helper revhs ts =
   107:     begin match ts with
   108:     | [] -> List.rev (x::revhs)
   109:     | t::ts' ->
   110:         if cmp x t >= 0 then helper (t::revhs) ts'
   111:         else list_rev_append (x::revhs) ts
   112:     end
   113:   in
   114:   helper [] xs
   115: ;;
   116: 
   117: let list_head_default (d : 'a) (xs : 'a list) : 'a =
   118:   begin match xs with
   119:   | [] -> d
   120:   | x::_ -> x
   121:   end
   122: ;;
   123: 
   124: let rec list_iter3 f xs ys zs =
   125:   begin match xs, ys, zs with
   126:   | [], [], [] -> ()
   127:   | x::xs, y::ys, z::zs -> f x y z; list_iter3 f xs ys zs
   128:   | _ -> invalid_arg "Flx_cil_util.list_iter3"
   129:   end
   130: ;;
   131: 
   132: let rec get_some_option_list (xs : 'a option list) : 'a list =
   133:   begin match xs with
   134:   | [] -> []
   135:   | None::xs  -> get_some_option_list xs
   136:   | Some x::xs -> x :: get_some_option_list xs
   137:   end
   138: ;;
   139: 
   140: let list_iteri (f: int -> 'a -> unit) (l: 'a list) : unit =
   141:   let rec loop (i: int) (l: 'a list) : unit =
   142:     match l with
   143:       [] -> ()
   144:     | h :: t -> f i h; loop (i + 1) t
   145:   in
   146:   loop 0 l
   147: 
   148: let list_mapi (f: int -> 'a -> 'b) (l: 'a list) : 'b list =
   149:   let rec loop (i: int) (l: 'a list) : 'b list =
   150:     match l with
   151:       [] -> []
   152:     | h :: t ->
   153:         let headres = f i h in
   154:         headres :: loop (i + 1) t
   155:   in
   156:   loop 0 l
   157: 
   158: let list_fold_lefti (f: 'acc -> int -> 'a -> 'acc) (start: 'acc)
   159:                    (l: 'a list) : 'acc =
   160:   let rec loop (i, acc) l =
   161:     match l with
   162:       [] -> acc
   163:     | h :: t -> loop (i + 1, f acc i h) t
   164:   in
   165:   loop (0, start) l
   166: 
   167: 
   168: let list_init (len : int) (init_fun : int -> 'a) : 'a list =
   169:   let rec loop n acc =
   170:     if n < 0 then acc
   171:     else loop (n-1) ((init_fun n)::acc)
   172:   in
   173:   loop (len - 1) []
   174: ;;
   175: 
   176: 
   177: (** Generates the range of integers starting with a and ending with b *)
   178: let int_range_list (a: int) (b: int) =
   179:   list_init (b - a + 1) (fun i -> a + i)
   180: 
   181: 
   182: (** Some handling of registers *)
   183: type 'a growArrayFill =
   184:     Elem of 'a
   185:   | Susp of (int -> 'a)
   186: 
   187: type 'a growArray = {
   188:             gaFill: 'a growArrayFill;
   189:             (** Stuff to use to fill in the array as it grows *)
   190: 
   191:     mutable gaMaxInitIndex: int;
   192:             (** Maximum index that was written to. -1 if no writes have
   193:              * been made.  *)
   194: 
   195:     mutable gaData: 'a array;
   196:   }
   197: 
   198: let growTheArray (ga: 'a growArray) (len: int)
   199:                  (toidx: int) (why: string) : unit =
   200:   if toidx >= len then begin
   201:     (* Grow the array by 50% *)
   202:     let newlen = toidx + 1 + len  / 2 in
   203: (*
   204:     ignore (E.log "growing an array to idx=%d (%s)\n" toidx why);
   205: *)
   206:     let data' = begin match ga.gaFill with
   207:       Elem x ->
   208: 
   209:         let data'' = Array.create newlen x in
   210:         Array.blit ga.gaData 0 data'' 0 len;
   211:         data''
   212:     | Susp f -> Array.init newlen
   213:           (fun i -> if i < len then ga.gaData.(i) else f i)
   214:     end
   215:     in
   216:     ga.gaData <- data'
   217:   end
   218: 
   219: let getReg (ga: 'a growArray) (r: int) : 'a =
   220:   let len = Array.length ga.gaData in
   221:   if r >= len then
   222:     growTheArray ga len r "get";
   223: 
   224:   ga.gaData.(r)
   225: 
   226: let setReg (ga: 'a growArray) (r: int) (what: 'a) : unit =
   227:   let len = Array.length ga.gaData in
   228:   if r >= len then
   229:     growTheArray ga len r "set";
   230:   if r > ga.gaMaxInitIndex then ga.gaMaxInitIndex <- r;
   231:   ga.gaData.(r) <- what
   232: 
   233: let newGrowArray (initsz: int) (fill: 'a growArrayFill) : 'a growArray =
   234:   { gaFill = fill;
   235:     gaMaxInitIndex = -1;
   236:     gaData = begin match fill with
   237:       Elem x -> Array.create initsz x
   238:     | Susp f -> Array.init initsz f
   239:     end; }
   240: 
   241: let copyGrowArray (ga: 'a growArray) : 'a growArray =
   242:   { ga with gaData = Array.copy ga.gaData }
   243: 
   244: let deepCopyGrowArray (ga: 'a growArray) (copy: 'a -> 'a): 'a growArray =
   245:   { ga with gaData = Array.map copy ga.gaData }
   246: 
   247: 
   248: 
   249: (** Iterate over the initialized elements of the array *)
   250: let growArray_iteri  (f: int -> 'a -> unit) (ga: 'a growArray) =
   251:   for i = 0 to ga.gaMaxInitIndex do
   252:     f i ga.gaData.(i)
   253:   done
   254: 
   255: 
   256: (** Fold left over the initialized elements of the array *)
   257: let growArray_foldl (f: 'acc -> 'a -> 'acc)
   258:                     (acc: 'acc) (ga: 'a growArray) : 'acc =
   259:   let rec loop (acc: 'acc) (idx: int) : 'acc =
   260:     if idx > ga.gaMaxInitIndex then
   261:       acc
   262:     else
   263:       loop (f acc ga.gaData.(idx)) (idx + 1)
   264:   in
   265:   loop acc 0
   266: 
   267: 
   268: 
   269: 
   270: let hasPrefix (prefix: string) (what: string) : bool =
   271:   let pl = String.length prefix in
   272:   try String.sub what 0 pl = prefix
   273:   with Invalid_argument _ -> false
   274: 
   275: 
   276: 
   277: let restoreRef ?(deepCopy=(fun x -> x)) (r: 'a ref) : (unit -> unit) =
   278:   let old = deepCopy !r in
   279:   (fun () -> r := old)
   280: 
   281: let restoreHash ?deepCopy (h: ('a, 'b) H.t) : (unit -> unit) =
   282:   let old =
   283:     match deepCopy with
   284:       None -> H.copy h
   285:     | Some f ->
   286:         let old = H.create 13 in
   287:         H.iter (fun k d -> H.add old k (f d)) h;
   288:         old
   289:   in
   290:   (fun () -> hash_copy_into old h)
   291: 
   292: let restoreArray ?deepCopy (a: 'a array) : (unit -> unit) =
   293:   let old = Array.copy a in
   294:   (match deepCopy with
   295:     None -> ()
   296:   | Some f -> Array.iteri (fun i v -> old.(i) <- f v) old);
   297:   (fun () -> Array.blit old 0 a 0 (Array.length a))
   298: 
   299: let runThunks (l: (unit -> unit) list) : (unit -> unit) =
   300:   fun () -> List.iter (fun f -> f ()) l
   301: 
   302: 
   303: 
   304: (* Memoize *)
   305: let memoize (h: ('a, 'b) Hashtbl.t)
   306:             (arg: 'a)
   307:             (f: 'a -> 'b) : 'b =
   308:   try
   309:     Hashtbl.find h arg
   310:   with Not_found -> begin
   311:     let res = f arg in
   312:     Hashtbl.add h arg res;
   313:     res
   314:   end
   315: 
   316: (* Just another name for memoize *)
   317: let findOrAdd h arg f = memoize h arg f
   318: 
   319: (* A tryFinally function *)
   320: let tryFinally
   321:     (main: 'a -> 'b) (* The function to run *)
   322:     (final: 'b option -> unit)  (* Something to run at the end *)
   323:     (arg: 'a) : 'b =
   324:   try
   325:     let res: 'b = main arg in
   326:     final (Some res);
   327:     res
   328:   with e -> begin
   329:     final None;
   330:     raise e
   331:   end
   332: 
   333: 
   334: 
   335: 
   336: (** The state information that the GUI must display is viewed abstractly as a
   337:  * set of registers. *)
   338: type registerInfo = {
   339:     rName: string; (** The name of the register *)
   340:     rGroup: string; (** The name of the group to which this register belongs.
   341:                      * The special group Engine.machineRegisterGroup
   342:                      * contains the machine registers. *)
   343:     rVal: Flx_cil_pretty.doc; (** The value to be displayed about a register *)
   344:     rOneLineVal: Flx_cil_pretty.doc option (** The value to be displayed on one line *)
   345: }
   346: 
   347: 
   348: 
   349: let valOf : 'a option -> 'a = function
   350:     None -> raise (Failure "Flx_cil_util.valOf")
   351:   | Some x -> x
   352: 
   353: (**
   354:  * An accumulating for loop.
   355:  *
   356:  * Initialize the accumulator with init.  The current index and accumulator
   357:  * from the previous iteration is passed to f.
   358:  *)
   359: let fold_for ~(init: 'a) ~(lo: int) ~(hi: int) (f: int -> 'a -> 'a) =
   360:   let rec forloop i acc =
   361:     if i > hi then acc
   362:     else forloop (i+1) (f i acc)
   363:   in
   364:   forloop lo init
   365: 
   366: (************************************************************************)
   367: 
   368: module type STACK = sig
   369:   type 'a t
   370:   (** The type of stacks containing elements of type ['a]. *)
   371: 
   372:   exception Empty
   373:   (** Raised when Stack.pop or Stack.top is applied to an empty stack. *)
   374: 
   375:   val create : unit -> 'a t
   376:   (** Return a new stack, initially empty. *)
   377: 
   378:   val push : 'a -> 'a t -> unit
   379:   (** [push x s] adds the element [x] at the top of stack [s]. *)
   380: 
   381:   val pop : 'a t -> 'a
   382:   (** [pop s] removes and returns the topmost element in stack [s],
   383:      or raises [Empty] if the stack is empty. *)
   384: 
   385:   val top : 'a t -> 'a
   386:   (** [top s] returns the topmost element in stack [s],
   387:      or raises [Empty] if the stack is empty. *)
   388: 
   389:   val clear : 'a t -> unit
   390:   (** Discard all elements from a stack. *)
   391: 
   392:   val copy : 'a t -> 'a t
   393:   (** Return a copy of the given stack. *)
   394: 
   395:   val is_empty : 'a t -> bool
   396:   (** Return [true] if the given stack is empty, [false] otherwise. *)
   397: 
   398:   val length : 'a t -> int
   399:   (** Return the number of elements in a stack. *)
   400: 
   401:   val iter : ('a -> unit) -> 'a t -> unit
   402:   (** [iter f s] applies [f] in turn to all elements of [s],
   403:      from the element at the top of the stack to the element at the
   404:      bottom of the stack. The stack itself is unchanged. *)
   405: end
   406: 
   407: module Stack = struct
   408: 
   409:   type 'a t = { mutable length : int;
   410:                 stack : 'a Stack.t; }
   411: 
   412:   exception Empty
   413: 
   414:   let create () = { length = 0;
   415:                     stack = Stack.create(); }
   416: 
   417:   let push x s =
   418:     s.length <- s.length + 1;
   419:     Stack.push x s.stack
   420: 
   421:   let pop s =
   422:     s.length <- s.length - 1;
   423:     Stack.pop s.stack
   424: 
   425:   let top s =
   426:     Stack.top s.stack
   427: 
   428:   let clear s =
   429:     s.length <- 0;
   430:     Stack.clear s.stack
   431: 
   432:   let copy s = { length = s.length;
   433:                  stack = Stack.copy s.stack; }
   434: 
   435:   let is_empty s =
   436:     Stack.is_empty s.stack
   437: 
   438:   let length s = s.length
   439: 
   440:   let iter f s =
   441:     Stack.iter f s.stack
   442: 
   443: end
   444: 
   445: (************************************************************************)
   446: 
   447: let absoluteFilename (fname: string) =
   448:   if Filename.is_relative fname then
   449:     Filename.concat (Sys.getcwd ()) fname
   450:   else
   451:     fname
   452: 
   453: 
   454: (* mapNoCopy is like map but avoid copying the list if the function does not
   455:  * change the elements. *)
   456: let rec mapNoCopy (f: 'a -> 'a) = function
   457:     [] -> []
   458:   | (i :: resti) as li ->
   459:       let i' = f i in
   460:       let resti' = mapNoCopy f resti in
   461:       if i' != i || resti' != resti then i' :: resti' else li
   462: 
   463: let rec mapNoCopyList (f: 'a -> 'a list) = function
   464:     [] -> []
   465:   | (i :: resti) as li ->
   466:       let il' = f i in
   467:       let resti' = mapNoCopyList f resti in
   468:       match il' with
   469:         [i'] when i' == i && resti' == resti -> li
   470:       | _ -> il' @ resti'
   471: 
   472: 
   473: (* Use a filter function that does not rewrite the list unless necessary *)
   474: let rec filterNoCopy (f: 'a -> bool) (l: 'a list) : 'a list =
   475:   match l with
   476:     [] -> []
   477:   | h :: rest when not (f h) -> filterNoCopy f rest
   478:   | h :: rest ->
   479:       let rest' = filterNoCopy f rest in
   480:       if rest == rest' then l else h :: rest'
   481: 
   482: 
   483: (************************************************************************
   484: 
   485:  Configuration
   486: 
   487:  ************************************************************************)
   488: (** The configuration data can be of several types **)
   489: type configData =
   490:     ConfInt of int
   491:   | ConfBool of bool
   492:   | ConfFloat of float
   493:   | ConfString of string
   494:   | ConfList of configData list
   495: 
   496: 
   497: (* Store here window configuration file *)
   498: let configurationData: (string, configData) H.t = H.create 13
   499: 
   500: let clearConfiguration () = H.clear configurationData
   501: 
   502: let setConfiguration (key: string) (c: configData) =
   503:   H.replace configurationData key c
   504: 
   505: let findConfiguration (key: string) : configData =
   506:   H.find configurationData key
   507: 
   508: let findConfigurationInt (key: string) : int =
   509:   match findConfiguration key with
   510:     ConfInt i -> i
   511:   | _ ->
   512:       ignore (E.warn "Configuration %s is not an integer" key);
   513:       raise Not_found
   514: 
   515: let useConfigurationInt (key: string) (f: int -> unit) =
   516:   try f (findConfigurationInt key)
   517:   with Not_found -> ()
   518: 
   519: let findConfigurationString (key: string) : string =
   520:   match findConfiguration key with
   521:     ConfString s -> s
   522:   | _ ->
   523:       ignore (E.warn "Configuration %s is not a string" key);
   524:       raise Not_found
   525: 
   526: let useConfigurationString (key: string) (f: string -> unit) =
   527:   try f (findConfigurationString key)
   528:   with Not_found -> ()
   529: 
   530: 
   531: let findConfigurationBool (key: string) : bool =
   532:   match findConfiguration key with
   533:     ConfBool b -> b
   534:   | _ ->
   535:       ignore (E.warn "Configuration %s is not a boolean" key);
   536:       raise Not_found
   537: 
   538: let useConfigurationBool (key: string) (f: bool -> unit) =
   539:   try f (findConfigurationBool key)
   540:   with Not_found -> ()
   541: 
   542: let findConfigurationList (key: string) : configData list  =
   543:   match findConfiguration key with
   544:     ConfList l -> l
   545:   | _ ->
   546:       ignore (E.warn "Configuration %s is not a list" key);
   547:       raise Not_found
   548: 
   549: let useConfigurationList (key: string) (f: configData list -> unit) =
   550:   try f (findConfigurationList key)
   551:   with Not_found -> ()
   552: 
   553: 
   554: let saveConfiguration (fname: string) =
   555:   (** Convert configuration data to a string, for saving externally *)
   556:   let configToString (c: configData) : string =
   557:     let buff = Buffer.create 80 in
   558:     let rec loop (c: configData) : unit =
   559:       match c with
   560:         ConfInt i ->
   561:           Buffer.add_char buff 'i';
   562:           Buffer.add_string buff (string_of_int i);
   563:           Buffer.add_char buff ';'
   564: 
   565:       | ConfBool b ->
   566:           Buffer.add_char buff 'b';
   567:           Buffer.add_string buff (string_of_bool b);
   568:           Buffer.add_char buff ';'
   569: 
   570:       | ConfFloat f ->
   571:           Buffer.add_char buff 'f';
   572:           Buffer.add_string buff (string_of_float f);
   573:           Buffer.add_char buff ';'
   574: 
   575:       | ConfString s ->
   576:           if String.contains s '"' then
   577:             E.s (E.unimp "Guilib: configuration string contains quotes");
   578:           Buffer.add_char buff '"';
   579:           Buffer.add_string buff s;
   580:           Buffer.add_char buff '"'; (* '"' *)
   581: 
   582:       | ConfList l ->
   583:           Buffer.add_char buff '[';
   584:           List.iter loop l;
   585:           Buffer.add_char buff ']'
   586:     in
   587:     loop c;
   588:     Buffer.contents buff
   589:   in
   590:   try
   591:     let oc = open_out fname in
   592:     ignore (E.log "Saving configuration to %s\n" (absoluteFilename fname));
   593:     H.iter (fun k c ->
   594:       output_string oc (k ^ "\n");
   595:       output_string oc ((configToString c) ^ "\n"))
   596:       configurationData;
   597:     close_out oc
   598:   with _ ->
   599:     ignore (E.warn "Cannot open configuration file %s\n" fname)
   600: 
   601: 
   602: (** Make some regular expressions early *)
   603: let intRegexp = Str.regexp "i\\([0-9]+\\);"
   604: let floatRegexp = Str.regexp "f\\([0-9]+\\.[0-9]+\\);"
   605: let boolRegexp = Str.regexp "b\\(\\(true\\)\\|\\(false\\)\\);"
   606: let stringRegexp = Str.regexp "\"\\([^\"]*\\)\""
   607: 
   608: let loadConfiguration (fname: string) : unit =
   609:   H.clear configurationData;
   610: 
   611:   let stringToConfig (s: string) : configData =
   612:     let idx = ref 0 in (** the current index *)
   613:     let l = String.length s in
   614: 
   615:     let rec getOne () : configData =
   616:       if !idx >= l then raise Not_found;
   617: 
   618:       if Str.string_match intRegexp s !idx then begin
   619:         idx := Str.match_end ();
   620:         ConfInt (int_of_string (Str.matched_group 1 s))
   621:       end else if Str.string_match floatRegexp s !idx then begin
   622:         idx := Str.match_end ();
   623:         ConfFloat (float_of_string (Str.matched_group 1 s))
   624:       end else if Str.string_match boolRegexp s !idx then begin
   625:         idx := Str.match_end ();
   626:         ConfBool (bool_of_string (Str.matched_group 1 s))
   627:       end else if  Str.string_match stringRegexp s !idx then begin
   628:         idx := Str.match_end ();
   629:         ConfString (Str.matched_group 1 s)
   630:       end else if String.get s !idx = '[' then begin
   631:         (* We are starting a list *)
   632:         incr idx;
   633:         let rec loop (acc: configData list) : configData list =
   634:           if !idx >= l then begin
   635:             ignore (E.warn "Non-terminated list in configuration %s" s);
   636:             raise Not_found
   637:           end;
   638:           if String.get s !idx = ']' then begin
   639:             incr idx;
   640:             List.rev acc
   641:           end else
   642:             loop (getOne () :: acc)
   643:         in
   644:         ConfList (loop [])
   645:       end else begin
   646:         ignore (E.warn "Bad configuration element in a list: %s\n"
   647:                   (String.sub s !idx (l - !idx)));
   648:         raise Not_found
   649:       end
   650:     in
   651:     getOne ()
   652:   in
   653:   (try
   654:     let ic = open_in fname in
   655:     ignore (E.log "Loading configuration from %s\n" (absoluteFilename fname));
   656:     (try
   657:       while true do
   658:         let k = input_line ic in
   659:         let s = input_line ic in
   660:         try
   661:           let c = stringToConfig s in
   662:           setConfiguration k c
   663:         with Not_found -> ()
   664:       done
   665:     with End_of_file -> ());
   666:     close_in ic;
   667:   with _ -> () (* no file, ignore *));
   668: 
   669:   ()
   670: 
   671: 
   672: 
   673: (************************************************************************)
   674: 
   675: (*********************************************************************)
   676: type symbol = int
   677: 
   678: (**{ Registering symbol names} *)
   679: let registeredSymbolNames: (string, symbol) H.t = H.create 113
   680: let symbolNames: string IH.t = IH.create 113
   681: let nextSymbolId = ref 0
   682: 
   683: let registerSymbolName (n: string) : symbol =
   684:   try H.find registeredSymbolNames n
   685:   with Not_found -> begin
   686:     let id = !nextSymbolId in
   687:     incr nextSymbolId;
   688:     H.add registeredSymbolNames n id;
   689:     IH.add symbolNames id n;
   690:     id
   691:   end
   692: 
   693: (** Register a range of symbols. The mkname function will be invoked for
   694:  * indices starting at 0 *)
   695: let registerSymbolRange (count: int) (mkname: int -> string) : symbol =
   696:   if count < 0 then E.s (E.bug "registerSymbolRange: invalid counter");
   697:   let first = !nextSymbolId in
   698:   for i = 0 to count - 1 do
   699:     ignore (registerSymbolName (mkname i))
   700:   done;
   701:   first
   702: 
   703: let symbolName (id: symbol) : string =
   704:   try IH.find symbolNames id
   705:   with Not_found ->
   706:     ignore (E.warn "Cannot find the name of symbol %d" id);
   707:     "pseudo" ^ string_of_int id
   708: 
   709: 
End ocaml section to src/flx_cil_util.ml[1]
Start ocaml section to src/flxcc.ml[1 /1 ]
     1: # 69 "./lpsrc/flx_flxcc.pak"
     2: open List
     3: open Flx_util
     4: open Flx_types
     5: open Flx_version
     6: open Flx_mtypes1
     7: open Flx_cil_cabs
     8: open Flx_cil_cil
     9: ;;
    10: 
    11: let force_open_in place f =
    12:   try
    13:     open_in f
    14:   with
    15:   |  _ -> failwith ("[" ^ place ^ "] Can't open " ^ f ^ " for input")
    16: 
    17: let force_open_out place f =
    18:   try
    19:     open_out f
    20:   with
    21:   |  _ -> failwith ("[" ^ place ^ "] Can't open " ^ f ^ " for output")
    22: 
    23: type stab_t = {
    24:   stab_cfile: string;
    25:   stab_flxfile: string;
    26:   stab_flxinclude: string;
    27:   stab_module: string;
    28: 
    29:   aliases: (string,string) Hashtbl.t;
    30:   struct_aliases: (string,string) Hashtbl.t;
    31:   abstract_types: (string,string) Hashtbl.t;
    32:   incomplete_types: (string,string) Hashtbl.t;
    33:   mutable xtyps: (string,string) Hashtbl.t;
    34:   mutable udt: (string,unit) Hashtbl.t;
    35:   mutable ict: (string,string) Hashtbl.t;
    36:   used_types: (string,unit) Hashtbl.t;
    37:   variables : (string,string) Hashtbl.t;
    38:   functions: (string * typsig list * string,string * string) Hashtbl.t;
    39:   fields: (string,string * string) Hashtbl.t;
    40:   cstructs : (string,(string * string) list) Hashtbl.t;
    41:   procedures: (string * typsig list * string,string * string) Hashtbl.t;
    42:   callback_types: (string,typ * int) Hashtbl.t;
    43:   callback_clients: (string,typ * string * int * int) Hashtbl.t;
    44:   enums: (string,string) Hashtbl.t;
    45:   registry: (typsig, string * string) Hashtbl.t;
    46:   mutable includes: StringSet.t;
    47:   counter: int ref
    48: }
    49: ;;
    50: 
    51: let isprefix p s =
    52:   let pn = String.length p in
    53:   String.length s >= pn &&
    54:   String.sub s 0 pn = p
    55: ;;
    56: 
    57: exception Next
    58: ;;
    59: type control_t = {
    60:   mutable control_filename: string;
    61:   mutable flxg_command: string;
    62:   mutable prein_filename: string;
    63:   mutable preout_filename: string;
    64:   mutable log_filename: string;
    65:   mutable language: Flx_cil_cabs.lang_t;
    66:   mutable preprocessor: string;
    67:   mutable raw_includes: StringSet.t;
    68:   mutable raw_include_dirs : StringSet.t;
    69:   mutable include_path: string list;
    70:   mutable noincludes: string list;
    71:   mutable merge_files: (string * string) list;
    72:   mutable rev_merge_files: (string,string list) Hashtbl.t;
    73:   mutable outdir: string;
    74:   mutable repl_prefix: (string * string) list;
    75:   stabs : (string,stab_t) Hashtbl.t;
    76:   all_types : (string,string) Hashtbl.t;
    77:   incomplete_types_cache: (string,string * string list) Hashtbl.t;
    78:   mutable files: StringSet.t;
    79:   replacements : (string,string) Hashtbl.t;
    80:   nontype_replacements : (string,string) Hashtbl.t;
    81:   rejects: (string,unit) Hashtbl.t;
    82:   mutable root_includes: string list;
    83:   mutable root_rec_includes: string list;
    84:   mutable root_excludes : string list;
    85: }
    86: ;;
    87: 
    88: let control = {
    89:   control_filename = Sys.argv.(1);
    90:   flxg_command = "";
    91:   prein_filename = Sys.argv.(1) ^ ".h";
    92:   preout_filename = Sys.argv.(1) ^ ".i";
    93:   log_filename = Sys.argv.(1) ^ ".log";
    94:   language = `C;
    95:   preprocessor ="cpp ";
    96:   noincludes = [];
    97:   raw_includes = StringSet.empty;
    98:   raw_include_dirs = StringSet.empty;
    99:   include_path = [];
   100:   merge_files = [];
   101:   rev_merge_files = Hashtbl.create 97;
   102:   outdir = "flxcc_out";
   103:   repl_prefix = [];
   104:   stabs  = Hashtbl.create 97;
   105:   all_types = Hashtbl.create 97;
   106:   incomplete_types_cache = Hashtbl.create 97;
   107:   files = StringSet.empty;
   108:   replacements = Hashtbl.create 97;
   109:   nontype_replacements = Hashtbl.create 97;
   110:   rejects = Hashtbl.create 97;
   111:   root_rec_includes = [];
   112:   root_includes = [];
   113:   root_excludes = [];
   114: }
   115: ;;
   116: 
   117: (* map the name of a #include file which is
   118:   intended to be a physical part of another
   119:   into that filename.
   120: 
   121:   The mapping is used to prevent
   122:   a Felix include file or module being
   123:   created for definitions in this file,
   124:   but it should *only* be used when a file
   125:   is uniquely included by another
   126: 
   127:   When we're scanning for includes,
   128:   we need all the physical (unmapped)
   129:   filenames as inputs to find the transitive
   130:   closure. Once that is done, the transitive
   131:   closure itself must be mapped to avoid
   132:   references to non-existent Felix modules.
   133: *)
   134: 
   135: let rec glob dir recurse level =
   136:   if not (mem dir control.root_excludes) then
   137:   let spaces = String.make level ' ' in
   138:   try
   139:     let f = Unix.opendir dir in
   140:     control.raw_include_dirs <- StringSet.add dir control.raw_include_dirs;
   141:     begin
   142:       try
   143:         while true do let m = Unix.readdir f in
   144:           let path = Filename.concat dir m in
   145:           let st =
   146:             try Unix.lstat path
   147:             with _ -> failwith ("Can't lstat " ^ path)
   148:           in
   149:           match st.Unix.st_kind with
   150:           | Unix.S_REG ->
   151:             if not (mem path control.root_excludes)
   152:             then begin
   153:               control.raw_includes <- StringSet.add path control.raw_includes;
   154:               control.files <- StringSet.add path control.files
   155:             end
   156: 
   157:           | Unix.S_DIR ->
   158:             if recurse then
   159:             if not (isprefix "." m) then
   160:             begin
   161:               glob path recurse (level + 1)
   162:             end
   163: 
   164:           | _ -> ()
   165:         done
   166:       with End_of_file -> Unix.closedir f
   167:     end
   168:   with Unix.Unix_error _ ->
   169:     failwith ("Can't find directory " ^ dir)
   170: ;;
   171: 
   172: let pattern = ref "*.h"
   173: ;;
   174: 
   175: let rec parse_control_file filename =
   176:   let f = force_open_in "parse_control_file" filename
   177:   in
   178:   let rec aux () =
   179:     try
   180:       let line = input_line f in
   181:       let n = String.length line in
   182:       let i = ref 0 in
   183:       try
   184:           (* skip white *)
   185:           while !i < n && line.[!i]=' ' do incr i done;
   186:           if !i = n then raise Next;
   187: 
   188:           (* detect C++ style comment *)
   189:           if isprefix "//" (String.sub line !i (n - !i))
   190:           then raise Next
   191:           ;
   192:           let j = !i in
   193:           while !i < n && line.[!i]<>' ' do incr i done;
   194:           let keyword = String.sub line j (!i-j) in
   195: 
   196:           match keyword with
   197:           | "#include" ->
   198:             while !i < n && line.[!i]=' ' do incr i done;
   199:             if !i = n then failwith "outdir statement requires filename";
   200:             let j = !i in
   201:             while !i < n && line.[!i]<>' ' do incr i done;
   202:             let fn = String.sub line j (!i-j) in
   203:             parse_control_file fn;
   204:             raise Next
   205: 
   206:           | "outdir" ->
   207:             while !i < n && line.[!i]=' ' do incr i done;
   208:             if !i = n then failwith "outdir statement requires filename";
   209:             let j = !i in
   210:             while !i < n && line.[!i]<>' ' do incr i done;
   211:             control.outdir <- String.sub line j (!i-j);
   212:             raise Next
   213: 
   214:           | "prein" ->
   215:             while !i < n && line.[!i]=' ' do incr i done;
   216:             if !i = n then failwith "prein statement requires filename";
   217:             let j = !i in
   218:             while !i < n && line.[!i]<>' ' do incr i done;
   219:             control.prein_filename <- String.sub line j (!i-j);
   220:             raise Next
   221: 
   222:           | "preout" ->
   223:             while !i < n && line.[!i]=' ' do incr i done;
   224:             if !i = n then failwith "preout statement requires filename";
   225:             let j = !i in
   226:             while !i < n && line.[!i]<>' ' do incr i done;
   227:             control.preout_filename <- String.sub line j (!i-j);
   228:             raise Next
   229: 
   230:           | "language" ->
   231:             while !i < n && line.[!i]=' ' do incr i done;
   232:             if !i = n then failwith "preout statement requires filename";
   233:             let j = !i in
   234:             while !i < n && line.[!i]<>' ' do incr i done;
   235:             let x = String.sub line j (!i-j) in
   236:             control.language <-
   237:               (
   238:                 match x with
   239:                 | "C" | "c" -> `C
   240:                 | "C++" | "c++" | "cxx" -> `Cxx
   241:                 | _ -> failwith ("Unknown language " ^ x ^", must be C or C++")
   242:               )
   243:             ;
   244:             raise Next
   245: 
   246:           | "flx_compiler" ->
   247:             while !i < n && line.[!i]=' ' do incr i done;
   248:             let j = !i in
   249:             while !i < n do incr i done;
   250:             control.flxg_command <- String.sub line j (!i-j);
   251:             raise Next
   252: 
   253:           | "preprocessor" ->
   254:             while !i < n && line.[!i]=' ' do incr i done;
   255:             if !i = n then failwith "preprocessor statement requires arguments";
   256:             let j = !i in
   257:             while !i < n do incr i done;
   258:             control.preprocessor <- String.sub line j (!i-j);
   259:             raise Next
   260: 
   261:           | "noheader" ->
   262:             while !i < n && line.[!i]=' ' do incr i done;
   263:             if !i = n then failwith "noinclude statement requires filename";
   264:             let j = !i in
   265:             while !i < n && line.[!i]<>' ' do incr i done;
   266:             let fn = String.sub line j (!i-j) in
   267:             control.noincludes <- fn :: control.noincludes;
   268:             raise Next
   269: 
   270:           | "incdir" ->
   271:             while !i < n && line.[!i]=' ' do incr i done;
   272:             if !i = n then failwith "incdir statement requires filename";
   273:             let j = !i in
   274:             while !i < n && line.[!i]<>' ' do incr i done;
   275:             let fn = String.sub line j (!i-j) in
   276:             control.root_includes <- fn :: control.root_includes;
   277:             raise Next
   278: 
   279:           | "incfile" ->
   280:             while !i < n && line.[!i]=' ' do incr i done;
   281:             if !i = n then failwith "incfile statement requires filename";
   282:             let j = !i in
   283:             while !i < n && line.[!i]<>' ' do incr i done;
   284:             let fn = String.sub line j (!i-j) in
   285:             control.raw_includes <- StringSet.add fn control.raw_includes;
   286:             raise Next
   287: 
   288:           | "recincdir" ->
   289:             while !i < n && line.[!i]=' ' do incr i done;
   290:             if !i = n then failwith "incdir statement requires filename";
   291:             let j = !i in
   292:             while !i < n && line.[!i]<>' ' do incr i done;
   293:             let fn = String.sub line j (!i-j) in
   294:             control.root_rec_includes <- fn :: control.root_rec_includes;
   295:             raise Next
   296: 
   297:           | "path" ->
   298:             while !i < n && line.[!i]=' ' do incr i done;
   299:             if !i = n then failwith "path statement requires filename";
   300:             let j = !i in
   301:             while !i < n && line.[!i]<>' ' do incr i done;
   302:             let fn = String.sub line j (!i-j) in
   303:             control.include_path <- control.include_path @ [fn];
   304:             raise Next
   305: 
   306:           | "exclude" ->
   307:             while !i < n && line.[!i]=' ' do incr i done;
   308:             if !i = n then failwith "exclude statement requires filename";
   309:             let j = !i in
   310:             while !i < n && line.[!i]<>' ' do incr i done;
   311:             let fn = String.sub line j (!i-j) in
   312:             control.root_excludes<- fn :: control.root_excludes;
   313:             raise Next
   314: 
   315:           | "prefix" ->
   316:             while !i < n && line.[!i]=' ' do incr i done;
   317:             if !i = n then failwith "prefix statement requires filename";
   318:             let j = !i in
   319:             while !i < n && line.[!i]<>' ' do incr i done;
   320:             let fn1 = String.sub line j (!i-j) in
   321: 
   322:             while !i < n && line.[!i]=' ' do incr i done;
   323:             let fn2 =
   324:               if !i = n then ""
   325:               else begin
   326:                 let j = !i in
   327:                 while !i < n && line.[!i]<>' ' do incr i done;
   328:                 String.sub line j (!i-j)
   329:               end
   330:             in
   331:             control.repl_prefix <- (fn1, fn2) :: control.repl_prefix;
   332:             raise Next
   333: 
   334:           | "merge" ->
   335:             while !i < n && line.[!i]=' ' do incr i done;
   336:             if !i = n then failwith "merge statement requires filename";
   337:             let j = !i in
   338:             while !i < n && line.[!i]<>' ' do incr i done;
   339:             let fn1 = String.sub line j (!i-j) in
   340: 
   341:             while !i < n && line.[!i]=' ' do incr i done;
   342:             if !i = n then failwith "merge statement requires 2 filenames";
   343:             let j = !i in
   344:             while !i < n && line.[!i]<>' ' do incr i done;
   345:             let fn2 = String.sub line j (!i-j) in
   346:             control.merge_files <- (fn1,fn2) :: control.merge_files;
   347:             let x =
   348:               try Hashtbl.find control.rev_merge_files fn2
   349:               with Not_found -> []
   350:             in Hashtbl.replace control.rev_merge_files fn2 (fn1::x)
   351:             ;
   352:             raise Next
   353: 
   354:           | "rename" ->
   355:             while !i < n && line.[!i]=' ' do incr i done;
   356:             if !i = n then failwith "rename statement requires name";
   357:             let j = !i in
   358:             while !i < n && line.[!i]<>' ' do incr i done;
   359:             let fn1 = String.sub line j (!i-j) in
   360: 
   361:             while !i < n && line.[!i]=' ' do incr i done;
   362:             if !i = n then failwith "rename statement requires 2 names";
   363:             let j = !i in
   364:             while !i < n && line.[!i]<>' ' do incr i done;
   365:             let fn2 = String.sub line j (!i-j) in
   366:             Hashtbl.add control.replacements fn1 fn2;
   367:             raise Next
   368: 
   369:           | "rename_nontype" ->
   370:             while !i < n && line.[!i]=' ' do incr i done;
   371:             if !i = n then failwith "rename_nontype statement requires name";
   372:             let j = !i in
   373:             while !i < n && line.[!i]<>' ' do incr i done;
   374:             let fn1 = String.sub line j (!i-j) in
   375: 
   376:             while !i < n && line.[!i]=' ' do incr i done;
   377:             if !i = n then failwith "rename_nontype statement requires 2 names";
   378:             let j = !i in
   379:             while !i < n && line.[!i]<>' ' do incr i done;
   380:             let fn2 = String.sub line j (!i-j) in
   381:             Hashtbl.add control.nontype_replacements fn1 fn2;
   382:             raise Next
   383: 
   384:           | "ignore" ->
   385:             while !i < n && line.[!i]=' ' do incr i done;
   386:             if !i = n then failwith "ignore statement requires name";
   387:             let j = !i in
   388:             while !i < n && line.[!i]<>' ' do incr i done;
   389:             let fn = String.sub line j (!i-j) in
   390:             Hashtbl.add control.rejects fn ();
   391:             raise Next
   392: 
   393:           | _ -> failwith ("Unknown keyword " ^keyword^ " in control file")
   394: 
   395:       with Next -> aux()
   396:     with End_of_file -> ()
   397:   in
   398:     aux ();
   399:     close_in f
   400: ;;
   401: parse_control_file control.control_filename
   402: ;;
   403: 
   404: iter
   405: (fun s -> glob s false 0)
   406: control.root_includes
   407: ;;
   408: 
   409: iter
   410: (fun s -> glob s true 0)
   411: control.root_rec_includes
   412: ;;
   413: 
   414: let autocreate x =
   415:   try open_out x
   416:   with | _ ->
   417:   let rec mkpath x  =
   418:     let d = Filename.dirname x in
   419:     if d <> "" then begin
   420:       try Unix.mkdir d 0o777
   421:       with _ ->
   422:         mkpath d;
   423:         try Unix.mkdir d 0o777
   424:         with _ -> failwith ("[autocreate] Can't create (p=0777) directory " ^ d)
   425:     end
   426:   in
   427:   mkpath x;
   428:   force_open_out "autocreate" x
   429: 
   430: ;;
   431: 
   432: let f = autocreate control.prein_filename in
   433: StringSet.iter
   434: (fun s ->
   435:   output_string f ("#include \"" ^ s ^ "\"\n")
   436: )
   437: control.raw_includes
   438: ;
   439: close_out f
   440: ;;
   441: 
   442: let precmd =
   443:   let path = ref "" in
   444:   (*
   445:   StringSet.iter
   446:   (fun s -> path := !path ^ "-I" ^ s ^ " ")
   447:   control.raw_include_dirs
   448:   ;
   449:   *)
   450:   path :=
   451:   (
   452:     String.concat " "
   453:     (
   454:       map
   455:       (fun s-> "-I"^s^" ")
   456:       control.include_path
   457:     )
   458:   ) ^ " " ^ !path
   459:   ;
   460: 
   461:   control.preprocessor ^ " " ^
   462:   !path ^ " " ^
   463:   control.prein_filename ^
   464:   " >" ^control.preout_filename
   465: ;;
   466: 
   467: print_endline "PREPROCESSOR COMMAND:";
   468: print_endline precmd
   469: ;;
   470: 
   471: Unix.system precmd
   472: ;;
   473: 
   474: let format_time tm =
   475:   si (tm.Unix.tm_year + 1900) ^ "/" ^
   476:   si (tm.Unix.tm_mon + 1) ^ "/" ^
   477:   si tm.Unix.tm_mday ^ " " ^
   478:   si tm.Unix.tm_hour ^ ":" ^
   479:   si tm.Unix.tm_min ^ ":" ^
   480:   si tm.Unix.tm_sec
   481: ;;
   482: 
   483: let compile_start = Unix.time ()
   484: let compile_start_gm = Unix.gmtime compile_start
   485: let compile_start_local = Unix.localtime compile_start
   486: let compile_start_gm_string = format_time compile_start_gm ^ " UTC"
   487: let compile_start_local_string = format_time compile_start_local ^ " (local)"
   488: ;;
   489: 
   490: Flx_cil_cil.initCIL()
   491: ;;
   492: 
   493: let lexbuf = Flx_cil_clexer.init control.preout_filename control.language;;
   494: let cabs = Flx_cil_cparser.file Flx_cil_clexer.initial lexbuf
   495: ;;
   496: Flx_cil_clexer.finish()
   497: ;;
   498: 
   499: (*
   500: Flx_cil_cprint.print_defs cabs;;
   501: *)
   502: 
   503: let ns (s,_,_,_) = s
   504: ;;
   505: let is_def = function | Some _ -> "complete" | None -> "incomplete"
   506: ;;
   507: let type_of_se = function
   508: | SpecType ts ->
   509:   begin match ts with
   510:   | Tnamed s -> print_endline ("type " ^ s)
   511:   | Tstruct (s,fglo,_) ->
   512:     print_endline ("struct " ^ s ^ " " ^ is_def fglo)
   513:   | Tunion (s,fglo,_) ->
   514:     print_endline ("union " ^ s ^ " " ^ is_def fglo)
   515:   | Tenum (s,fglo,_) ->
   516:     print_endline ("enum " ^ s ^ " " ^ is_def fglo)
   517:   | _ -> ()
   518:   end
   519: | _ -> ()
   520: 
   521: let types_in sp = List.iter type_of_se sp
   522: ;;
   523: 
   524: let cil = Flx_cil_cabs2cil.convFile (control.preout_filename, cabs)
   525: ;;
   526: 
   527: 
   528: (*
   529: dumpFile defaultCilPrinter stdout cil ;;
   530: *)
   531: 
   532: let {fileName=f; globals=gs} = cil
   533: ;;
   534: 
   535: (* files not corresponding to a module *)
   536: let excludes : string list ref = ref
   537: [
   538: ]
   539: ;;
   540: 
   541: let rpltname s =
   542:   try Hashtbl.find control.replacements s
   543:   with Not_found -> s
   544: 
   545: let rplname s =
   546:   try Hashtbl.find control.nontype_replacements s
   547:   with Not_found ->
   548:   try Hashtbl.find control.replacements s
   549:   with Not_found -> s
   550: 
   551: let soi = function
   552: | IBool -> "bool"
   553: | IChar -> "char"
   554: | ISChar -> "tiny"
   555: | IUChar -> "utiny"
   556: | IInt -> "int"
   557: | IUInt -> "uint"
   558: | IShort -> "short"
   559: | IUShort -> "ushort"
   560: | ILong -> "long"
   561: | IULong -> "ulong"
   562: | ILongLong -> "vlong"
   563: | IULongLong -> "uvlong"
   564: 
   565: let sof = function
   566: | FFloat -> "float"
   567: | FDouble -> "double"
   568: | FLongDouble -> "ldouble"
   569: 
   570: | IFloat -> "imaginary"
   571: | IDouble -> "dimaginary"
   572: | ILongDouble -> "limaginary"
   573: 
   574: | CFloat -> "complex"
   575: | CDouble -> "dcomplex"
   576: | CLongDouble -> "lcomplex"
   577: 
   578: let cvqual a =
   579:   let const = ref false
   580:   and volatile = ref false
   581:   in
   582:   List.iter
   583:   (fun (Attr (s,_)) ->
   584:     if s = "const" then const := true
   585:     else if s = "volatile" then volatile := true
   586:   )
   587:   a
   588:   ;
   589:   if !const && !volatile then "cv"
   590:   else if !const then "c"
   591:   else if !volatile then "v"
   592:   else ""
   593: 
   594: let attrof = function
   595: | TVoid a
   596: | TInt (_,a)
   597: | TFloat (_,a)
   598: | TPtr (_,a)
   599: | TArray (_,_,a)
   600: | TFun (_,_,_,a)
   601: | TNamed (_,a)
   602: | TComp (_,a)
   603: | TEnum (_,a)
   604: | TBuiltin_va_list a
   605: -> a
   606: 
   607: let strexp n = "0" (* cheat *)
   608: ;;
   609: 
   610: let remove_pnames t = match t with
   611: | TPtr (TFun (t,Some ps,b,a),a') ->
   612:   let ps = map (fun (_,t,a)->"",t,a) ps in
   613:   TPtr (TFun (t,Some ps,b,a),a')
   614: | _ -> t
   615: 
   616: (* strip multiple spaces and newlines out *)
   617: let reformatc s =
   618:   let s' = ref "" in
   619:   let n = String.length s in
   620:   for i=0 to n - 1 do
   621:     let
   622:       ch = s.[i] and
   623:       ch2 = if i < n-2 then s.[i+1] else '\000'
   624:     in
   625:     if
   626:       ch = ' ' &&
   627:         (ch2=' ' ||ch2=',' || ch2=';' || ch2=')' || ch2='\n')
   628:     then ()
   629:     else if ch='\n' then s' := !s' ^ " "
   630:     else s' := !s' ^ String.make 1 ch
   631:   done;
   632:   let n = ref (String.length !s' - 1) in
   633:   while !n >= 0 && !s'.[!n]=' ' do decr n done;
   634:   String.sub !s' 0 (!n+1)
   635: 
   636: let choose_alias stab s =
   637:   let ss = ref [] in
   638:   begin try
   639:     let s' = Hashtbl.find stab.aliases s in
   640:     ss := s' :: !ss
   641:   with Not_found -> ()
   642:   end
   643:   ;
   644: 
   645:   begin try
   646:     let s' = Hashtbl.find stab.struct_aliases s in
   647:     ss := s' :: !ss
   648:   with Not_found -> ()
   649:   end
   650:   ;
   651: 
   652:   (* just pick the shortest name *)
   653:   let s = s :: !ss in
   654:   let s = map (fun x -> String.length x,x) s in
   655:   let s = sort compare s in
   656:   let _,p = hd s in
   657:   p
   658: 
   659: let prefered_alias stab s = choose_alias stab s
   660: 
   661: 
   662: let rec sot stab t = match t with
   663: | TVoid a -> "void_t"
   664: | TInt (ik,a) -> soi ik
   665: | TFloat (fk,a) -> sof fk
   666: | TPtr (TVoid a',a) -> (cvqual a')^"address"
   667: | TPtr (TFun _,a) ->
   668:   let t' = typeSig t in
   669:   begin try
   670:     fst (Hashtbl.find stab.registry t')
   671:   with
   672:     Not_found ->
   673:     let name = stab.stab_module ^"_cft_" ^ si !(stab.counter) in
   674:     incr stab.counter;
   675:     let sr = locUnknown in
   676:     let t = remove_pnames t in
   677:     let si = {tname=name;ttype=t;treferenced=true } in
   678:     let gt =  GType (si,sr) in
   679:     let d = defaultCilPrinter#pGlobal () gt in
   680:     let s = Flx_cil_pretty.sprint 65 d in
   681:     let s = reformatc s in
   682:     Hashtbl.add stab.registry t' (name,s);
   683:     name
   684:   end
   685: 
   686: | TPtr (t',a) -> cvqual (attrof t') ^ "ptr[" ^ sot stab t'^ "]"
   687: | TArray (t',Some n,a)->
   688:   cvqual (attrof t') ^ "ptr[" ^ sot stab t'^ "]"
   689: 
   690: | TArray (t',None,a)->
   691:   cvqual (attrof t') ^ "ptr[" ^ sot stab t' ^ "]"
   692: 
   693: | TFun (t',Some ps,false,a) ->
   694:   let ret = sot stab t'
   695:   and args =
   696:     if length ps = 0 then "1"
   697:     else String.concat " * " (List.map (soa stab) ps)
   698:   in args ^ " -> " ^ ret
   699: 
   700: | TFun (t',None,false,a) ->
   701:   let ret = sot stab t'
   702:   and args = "1"
   703:   in args ^ " -> " ^ ret
   704: 
   705: | TFun (t',_,_,a) -> "CANT HANDLE THIS FUN"
   706: 
   707: | TNamed (ti,a) ->
   708:   let name = ptname ti in
   709:   let name = prefered_alias stab name in
   710:   Hashtbl.add stab.used_types name ();
   711:   rpltname name
   712: 
   713: | TComp (ci,a) ->
   714:   let name = pci ci in
   715:   let name = prefered_alias stab name in
   716:   Hashtbl.add stab.used_types name ();
   717:   rpltname name
   718: 
   719: | TEnum (ei,a) -> "int"
   720: | TBuiltin_va_list a -> "__builtin_va_list"
   721: 
   722: and ptname {tname=tname} = tname
   723: and ciname {cname=cname} = cname
   724: and einame {ename=ename} = ename
   725: and viname {vname=vname} = vname
   726: 
   727: and pci ci = match ci with
   728: {cname=cname; cstruct=cstruct} ->
   729: (if cstruct then "_struct_" else "_union_") ^ cname
   730: 
   731: and pcci ci = match ci with
   732: {cname=cname; cstruct=cstruct} ->
   733: (if cstruct then "struct " else " union ") ^ cname
   734: 
   735: and pei ei = match ei with
   736: {ename=ename} -> "_enum_" ^ ename
   737: 
   738: and pcei ei = match ei with
   739: {ename=ename} -> "enum " ^ ename
   740: 
   741: and ptdef registry ti:string = match ti with
   742: {ttype=tt} -> sot registry tt
   743: 
   744: and pcomp pi = match pi with
   745: {cname=name} -> name
   746: 
   747: and soa stab (name,t,a) = sot stab t
   748: 
   749: and sov registry vi = match vi with
   750: {vname=vname; vtype=vtype} ->
   751: "const " ^ vname ^ ": " ^ sot registry vtype
   752: 
   753: let pe x = print_endline x
   754: ;;
   755: 
   756: let achk x =
   757:   let a = "__anon" in
   758:   let n = String.length a in
   759:   String.length x > n &&
   760:   a = String.sub x 0 n
   761: 
   762: let isanon = function
   763:   | GType ({tname=tname},_) -> achk tname
   764:   | GCompTag ({cname=cname},_) -> achk cname
   765:   | GCompTagDecl ({cname=cname},_) -> achk cname
   766:   | GEnumTag ({ename=ename},_) -> achk ename
   767:   | GEnumTagDecl ({ename=ename},_) -> achk ename
   768:   | GVarDecl ({vname=vname},_) -> false
   769:   | GVar ({vname=vname},_,_) -> false
   770:   | GFun (fd,sr) -> false
   771:   | GAsm _ -> true
   772:   | GPragma _ -> true
   773:   | GText _ -> true
   774: 
   775: (* pure name *)
   776: let flx_name' = function
   777:   | GType ({tname=tname},_) -> Some tname
   778:   | GCompTag (ci,sr) -> Some (pci ci)
   779:   | GCompTagDecl (ci,_) -> Some (pci ci)
   780:   | GEnumTag ({ename=ename},_) -> Some ename
   781:   | GEnumTagDecl ({ename=ename},_) -> Some ename
   782:   | GVarDecl ({vname=vname},_) -> Some vname
   783:   | GVar ({vname=vname},_,_) -> Some vname
   784:   | GFun ({svar={vname=vname}},sr) -> Some vname
   785:   | GAsm _ -> None
   786:   | GPragma _ -> None
   787:   | GText _ -> None
   788: 
   789: (* name with replacement *)
   790: let flx_name x = match flx_name' x with
   791: | Some x -> Some (rplname x)
   792: | None -> None
   793: 
   794: (* type name with replacement *)
   795: let flx_tname x = match flx_name' x with
   796: | Some x -> rpltname x
   797: | None -> "error!!"
   798: 
   799: let c_name = function
   800:   | GType ({tname=tname},_) -> Some tname
   801:   | GCompTag (ci,sr) -> Some (pcci ci)
   802:   | GCompTagDecl (ci,_) -> Some (pcci ci)
   803:   | GEnumTag (ei,_) -> Some "int"
   804:   | GEnumTagDecl (ei,_) -> Some "int"
   805:   | GVarDecl ({vname=vname},_) -> Some vname
   806:   | GVar ({vname=vname},_,_) -> Some vname
   807:   | GFun ({svar={vname=vname}},sr) -> Some vname
   808:   | GAsm _ -> None
   809:   | GPragma _ -> None
   810:   | GText _ -> None
   811: ;;
   812: 
   813: let rec isanont t =  match t with
   814: | TVoid _
   815: | TInt _
   816: | TFloat _ -> false
   817: | TPtr (t,_) -> isanont t
   818: | TArray (t,_,_) -> isanont t
   819: | TFun (t,Some ps,_,_) ->
   820:   fold_left (fun b (_,t,_)-> b || isanont t ) (isanont t) ps
   821: 
   822: | TFun (t,None,_,_) -> isanont t
   823: | TNamed ({tname=tname},_) -> achk tname
   824: | TComp ({cname=cname},_) -> achk cname
   825: | TEnum _ -> false
   826: | TBuiltin_va_list _ -> false
   827: 
   828: (* got to be a named non function type *)
   829: let is_cstruct_field t =  match t with
   830: | TVoid _
   831: | TInt _
   832: | TFloat _
   833: | TNamed _
   834: | TPtr _
   835: | TArray _
   836: | TComp _
   837: | TEnum _
   838:   -> true
   839: 
   840: | TFun _
   841: | TBuiltin_va_list _
   842:   -> false
   843: 
   844: let ispublic s =
   845:  String.length s < 2 || String.sub s 0 2 <> "__"
   846: 
   847: let can_gen_ctype cstruct cfields =  cstruct &&
   848:   fold_left
   849:   (fun t {fname=fname; ftype=ftype} ->
   850:     t && not (isanont ftype) && ispublic fname &&
   851:     is_cstruct_field ftype
   852:   )
   853:   true cfields
   854: 
   855: let chop_extension f =
   856:   let b = Filename.basename f in
   857:   let d = Filename.dirname f in
   858:   let b = try Filename.chop_extension b with _ -> b in
   859:   if d = "." then b else Filename.concat d b
   860: 
   861: let replace_prefix x ls =
   862:   let x = ref x in
   863:   iter
   864:   (fun (a,b) ->
   865:     if isprefix a !x then
   866:     let n = String.length a in
   867:     let m = String.length !x in
   868:     x := b ^ String.sub !x n (m-n)
   869:   )
   870:   ls
   871:   ;
   872:   !x
   873: let map_filename f =
   874:   let f = replace_prefix f control.merge_files in
   875:   f
   876: 
   877: let flxinclude_of_cfile cfilename =
   878:   let x = map_filename cfilename in
   879:   let x = replace_prefix x control.repl_prefix in
   880:   let x = chop_extension x ^ "_lib" in
   881:   let x = if isprefix "/" x then String.sub x 1 (String.length x - 1) else x in
   882:   let x = if isprefix "." x then String.sub x 1 (String.length x - 1) else x in
   883:   x
   884: 
   885: let flxfile_of_cfile cfilename =
   886:   let base = flxinclude_of_cfile cfilename in
   887:   Filename.concat (control.outdir)  (base ^ ".flx")
   888: 
   889: let srepl s c1 c2 =
   890:   for i = 0 to String.length s - 1 do
   891:     if s.[i]=c1 then s.[i] <- c2
   892:   done
   893: ;;
   894: 
   895: let module_of_cfilename s =
   896:   let module_of_filename fname =
   897:     let x = String.copy fname in
   898:     let fixup x =
   899:       srepl x '.' '_';
   900:       srepl x ' ' '_';
   901:       srepl x '/' '_';
   902:       srepl x '-' '_';
   903:       srepl x '+' '_';
   904:       srepl x ':' '_';
   905:     in
   906:     let mname =
   907:       try
   908:         let x = (chop_extension x) in
   909:         let x =
   910:           let m = String.length x in
   911:           if m>0 && x.[0] = '/' then String.sub x 1 (m-1) else x
   912:         in
   913:         fixup x;
   914:         x ^ "_h"
   915:       with Invalid_argument _ ->
   916:         print_endline ("Weird (C++??) filename " ^ fname ^ " without extension");
   917:         fixup x;
   918:         x
   919:     in rplname mname (* apply user renaming to modules too *)
   920:   in
   921:   let s = map_filename s in
   922:   let s = replace_prefix s control.repl_prefix in
   923:   module_of_filename s
   924: 
   925: ;;
   926: 
   927: let mk_stab cfile =
   928: {
   929:   stab_cfile = cfile;
   930:   stab_flxfile = flxfile_of_cfile cfile;
   931:   stab_flxinclude = flxinclude_of_cfile cfile;
   932:   stab_module = module_of_cfilename cfile;
   933: 
   934:   aliases= Hashtbl.create 97;
   935:   struct_aliases= Hashtbl.create 97;
   936:   abstract_types= Hashtbl.create 97;
   937:   incomplete_types= Hashtbl.create 97;
   938:   used_types= Hashtbl.create 97;
   939:   variables= Hashtbl.create 97;
   940:   functions= Hashtbl.create 97;
   941:   fields= Hashtbl.create 97;
   942:   cstructs = Hashtbl.create 97;
   943:   procedures= Hashtbl.create 97;
   944:   callback_types = Hashtbl.create 97;
   945:   callback_clients = Hashtbl.create 97;
   946:   enums= Hashtbl.create 97;
   947:   registry= Hashtbl.create 97;
   948:   includes = StringSet.empty;
   949:   xtyps = Hashtbl.create 97;
   950:   ict = Hashtbl.create 97;
   951:   udt = Hashtbl.create 97;
   952:   counter = ref 1
   953: }
   954: ;;
   955: 
   956: let getstab s =
   957:   let lfn = map_filename s in
   958:   try Hashtbl.find control.stabs lfn
   959:   with Not_found ->
   960:     let x = mk_stab s in
   961:     Hashtbl.add control.stabs lfn x;
   962:     x
   963: 
   964: let getreg {file=s} = getstab s
   965: 
   966: let oplist = [
   967:   "+","add";
   968:   "-","sub";
   969:   "*","mul";
   970:   "/","div";
   971:   "%","mod";
   972: 
   973:   "<","lt";
   974:   ">","gt";
   975:   "<=","le";
   976:   ">=","ge";
   977:   "==","eq";
   978:   "!=","ne";
   979: 
   980:   "=","_set";
   981: 
   982:   "||","lor";
   983:   "&&","land";
   984:   "!","lnot";
   985: 
   986:   "^","bxor";
   987:   "|","bor";
   988:   "&","band";
   989:   "~","compl";
   990: 
   991:   "+=","pluseq";
   992:   "-=","minuseq";
   993:   "*=","muleq";
   994:   "/=","diveq";
   995:   "%=","modeq";
   996:   "^=","careteq";
   997:   "|=","vbareq";
   998:   "&=","ampereq";
   999:   "~=","tildeeq";
  1000:   "<<=","leftshifteq";
  1001:   ">>=","rightshifteq";
  1002: 
  1003:   "++","incr";
  1004:   "--","decr";
  1005:   "[]","subscript";
  1006: ]
  1007: ;;
  1008: let operators = Hashtbl.create 97
  1009: ;;
  1010: List.iter
  1011: (fun (k,v)-> Hashtbl.add operators ("operator"^k) v)
  1012: oplist
  1013: ;;
  1014: 
  1015: let fixsym k =
  1016:   try  (* hackery .. won't work with qualified names *)
  1017:     Hashtbl.find operators k
  1018:   with Not_found ->
  1019:     let k = String.copy k in
  1020:     srepl k ':' '_';
  1021:     k
  1022: 
  1023: let rpl {file=s} which =
  1024:   let stab = getstab s in
  1025:   match which with
  1026:   | `aliases (k,v) ->
  1027:     let k = fixsym k in
  1028:     Hashtbl.replace stab.aliases k v;
  1029:     Hashtbl.replace control.all_types k s
  1030: 
  1031:   | `struct_aliases(k,v)  ->
  1032:     let k = fixsym k in
  1033:     Hashtbl.replace stab.struct_aliases k v;
  1034:     Hashtbl.replace control.all_types k s
  1035: 
  1036:   | `abstract_types (k,v)  ->
  1037:     let k = fixsym k in
  1038:     Hashtbl.replace stab.abstract_types k v;
  1039:     Hashtbl.replace control.all_types k s
  1040: 
  1041:   | `incomplete_types (k,v)  ->
  1042:     let k = fixsym k in
  1043:     Hashtbl.replace stab.incomplete_types k v
  1044: 
  1045:   | `variables(k,v)  ->
  1046:     let k = fixsym k in
  1047:     Hashtbl.replace stab.variables k v
  1048: 
  1049:   | `functions((k,ts,cv),v)  ->
  1050:     let k = fixsym k in
  1051:     Hashtbl.replace stab.functions (k,ts,cv) v
  1052: 
  1053:   | `fields(k,v)  ->
  1054:     let k = fixsym k in
  1055:     Hashtbl.replace stab.fields k v
  1056: 
  1057:   | `cstruct (k,v)  ->
  1058:     let k = fixsym k in
  1059:     Hashtbl.replace control.all_types k k;
  1060:     Hashtbl.replace stab.cstructs k v
  1061: 
  1062:   | `procedures((k,ts,cv),v)  ->
  1063:     let k = fixsym k in
  1064:     Hashtbl.replace stab.procedures (k,ts,cv) v
  1065: 
  1066:   | `enums(k,v)  ->
  1067:     let k = fixsym k in
  1068:     Hashtbl.replace stab.enums k v
  1069: 
  1070:   | `callback_type (s,(t,i))  ->
  1071:     Hashtbl.replace stab.callback_types s (t,i)
  1072: 
  1073:   | `callback_client (s,(t,cbt,i,j))  ->
  1074:     Hashtbl.replace stab.callback_clients s (t,cbt,i,j)
  1075: 
  1076: ;;
  1077: 
  1078: let add_file fname =
  1079:   control.files <- StringSet.add fname control.files
  1080: ;;
  1081: 
  1082: let add_loc {file=fname} =
  1083:   add_file fname
  1084: ;;
  1085: 
  1086: (* find all the void* in an argument list *)
  1087: let find_voidps ps =
  1088:   let voids = ref [] in
  1089:   let i = ref 0 in
  1090:   List.iter
  1091:   (fun (_,t,_) ->
  1092:     (match unrollType t with
  1093:     | TPtr (TVoid _,[]) -> voids := !i :: !voids
  1094:     | _ -> ()
  1095:     );
  1096:     incr i
  1097:   )
  1098:   ps
  1099:   ;
  1100:   !voids
  1101: 
  1102: (* check if a function pointer is a callback, by
  1103: seeing if it contains exactly one void * argument
  1104: *)
  1105: let is_callbackp t =
  1106:   match t with
  1107:   | TPtr (TFun (_,Some ps,false,_),_) ->
  1108:     List.length (find_voidps ps) = 1
  1109:   | _ -> false
  1110: 
  1111: (* Find all the arguments which are callbacks *)
  1112: let find_callbackps ps =
  1113:   let callbacks = ref [] in
  1114:   let i = ref 0 in
  1115:   List.iter
  1116:   (fun (_,t,_) ->
  1117:     if is_callbackp t
  1118:     then callbacks := !i :: !callbacks
  1119:     ;
  1120:     incr i
  1121:   )
  1122:   ps
  1123:   ;
  1124:   !callbacks
  1125: 
  1126: (* get the indices in an argument list of the callback
  1127: and client data pointer, and the index of the client
  1128: data pointer in the callback type as well, return None
  1129: if they can't be uniquely identified
  1130: *)
  1131: 
  1132: let get_callback_data ps =
  1133:   let callbacks = find_callbackps ps in
  1134:   let voids = find_voidps ps in
  1135:   match callbacks, voids with
  1136:   | [cbc_i], [cbc_adri] ->
  1137:     begin match List.nth ps cbc_i with
  1138:     | _,TPtr (TFun (_,Some ps,false,_),_),_ ->
  1139:       begin match find_voidps ps with
  1140:       | [cbi] -> Some (cbc_i,cbc_adri,cbi)
  1141:       | _ -> assert false
  1142:       end
  1143:     | _ -> assert false
  1144:     end
  1145:   | _ -> None
  1146: 
  1147: let check_callback t = match t with
  1148:   | TFun (_,Some ps,false,_) ->
  1149:     begin match get_callback_data ps with
  1150:     | Some (cbc_i, cbc_adri,cbi) ->
  1151:       let _,cbt,_ = List.nth ps cbc_i in
  1152:       Some (cbc_i, cbc_adri,cbi, cbt)
  1153:     | None -> None
  1154:     end
  1155:   | TFun _ -> None
  1156:   | _ -> failwith "Check for callbacks in non-function"
  1157: 
  1158: let handle_callback_maybe ft registry key key' fname loc =
  1159:   match check_callback ft with
  1160:   | None -> ()
  1161:   | Some (cbc_i, cbc_adri, cbi, cbt) ->
  1162:     (*
  1163:     print_endline
  1164:     (
  1165:       "Found callback client " ^ fname ^
  1166:       "\n  callback index = " ^ string_of_int cbc_i ^
  1167:       "\n  client data index = " ^ string_of_int cbc_adri ^
  1168:       "\n  callback type = " ^ sot registry cbt ^
  1169:       "\n  callback type client data index = " ^ string_of_int cbi
  1170:     )
  1171:     ;
  1172:     *)
  1173:     let s = sot registry cbt in
  1174:     rpl loc (`callback_type (s,(cbt,cbi)));
  1175:     rpl loc (`callback_client (fname,(ft,s,cbc_i,cbc_adri)))
  1176: 
  1177: let ptr key a =
  1178:   cvqual a ^ "ptr[" ^ key ^ "]"
  1179: 
  1180: let handle_global_fun ft registry key key' fname loc =
  1181:   handle_callback_maybe ft registry key key' fname loc;
  1182:   match ft with
  1183:   | TFun (TVoid _,Some ps,false,a) ->
  1184:     let tsig = map (fun (_,t,a) -> typeSig t) ps in
  1185:     let args =
  1186:       if length ps = 0 then "1"
  1187:       else String.concat " * " (List.map (soa registry) ps)
  1188:     in
  1189:     let cv = cvqual a in
  1190:     let ct = if key = key' then "" else key'^"($a);" in
  1191:     rpl loc (`procedures ((key,tsig,cv), (args,ct)))
  1192: 
  1193:   | TFun (TVoid _,None,false,a) ->
  1194:     let args = "1" in
  1195:     let cv = cvqual a in
  1196:     rpl loc (`procedures ((key,[],cv), (args,key'^"();")))
  1197: 
  1198:   | TFun (TVoid _,Some _,true,a) ->
  1199:     let cv = cvqual a in
  1200:     let ct = if key = key' then "" else key'^"($a);" in
  1201:     rpl loc (`procedures ((key^"[t]",[],cv), ("t",ct)))
  1202: 
  1203:   | TFun (ret,Some ps,false,a) ->
  1204:     let ftb =
  1205:       let ret = sot (getreg loc) ret
  1206:       and args = List.map (soa registry) ps
  1207:       and ct = if key = key' then "" else key'^"($a)"
  1208:       in
  1209:       (
  1210:         (
  1211:           if length ps = 0
  1212:           then "1"
  1213:           else String.concat " * " args
  1214:         )
  1215:         ^
  1216:         " -> " ^ ret,ct
  1217:       )
  1218:     in
  1219:       let tsig = map (fun (_,t,a) -> typeSig t) ps in
  1220:       let cv = cvqual a in
  1221:       rpl loc (`functions ((key,tsig,cv), ftb))
  1222: 
  1223:   | TFun (ret,None,false,a) ->
  1224:     let ret = sot (getreg loc) ret in
  1225:     let ftb =  "1 -> " ^ ret,key'^"()" in
  1226:     let cv = cvqual a in
  1227:     rpl loc (`functions ((key,[],cv), ftb))
  1228: 
  1229:   | TFun (ret,Some _,true,a) ->
  1230:     let ftb =
  1231:       let ret = sot (getreg loc) ret in
  1232:       "t -> " ^ ret,key'^"($a)"
  1233:     in
  1234:       let cv = cvqual a in
  1235:       rpl loc (`functions ((key^"[t]",[],cv), ftb))
  1236: 
  1237:   | _ -> assert false
  1238: 
  1239: let handle_method ft registry key fname loc =
  1240:   match ft with
  1241:   (* procedures *)
  1242:   | (TVoid _,Some ps,false,a) ->
  1243:     let key = ptr (fixsym key) a in
  1244:     let args =
  1245:       if length ps = 0 then key
  1246:       else String.concat " * " (key :: (List.map (soa registry) ps))
  1247:     in
  1248:       let tsig = map (fun (_,t,a) -> typeSig t) ps in
  1249:       let cv = cvqual a in
  1250:       rpl loc (`procedures ((fname,tsig,cv), (args,"$1->"^fname^"($b);")))
  1251: 
  1252:   (* no type arg = void *)
  1253:   | (TVoid _,None,false,a) ->
  1254:     let key = ptr key a in
  1255:     let args = key in
  1256:     let cv = cvqual a in
  1257:     rpl loc (`procedures ((fname,[],cv), (args,"$1->"^fname^"();")))
  1258: 
  1259:   (* variadic *)
  1260:   | (TVoid _,Some t,true,a) ->
  1261:     let key = ptr key a in
  1262:     let cv = cvqual a in
  1263:     rpl loc (`procedures ((fname^"[t]",[],cv), ("t","$1->"^fname^"($b);")))
  1264: 
  1265:   (* functions *)
  1266:   | (ret,Some ps,false,a) ->
  1267:     let key = ptr key a in
  1268:     let ftb =
  1269:       let ret = sot (getreg loc) ret
  1270:       and args = List.map (soa registry) ps
  1271:       in
  1272:       (
  1273:         (
  1274:           if length ps = 0
  1275:           then key
  1276:           else String.concat " * " (key :: args)
  1277:         )
  1278:         ^
  1279:         " -> " ^ ret,"$1->"^fname^"($a)"
  1280:       )
  1281:     in
  1282:       let tsig = map (fun (_,t,a) -> typeSig t) ps in
  1283:       let cv = cvqual a in
  1284:       rpl loc (`functions ((fname,tsig,cv), ftb))
  1285: 
  1286:   (* no type arg = void *)
  1287:   | (ret,None,false,a) ->
  1288:     let key = ptr key a in
  1289:     let ret = sot (getreg loc) ret in
  1290:     let ftb =  key ^ " -> " ^ ret,"$1->"^fname^"()" in
  1291:     let cv = cvqual a in
  1292:     rpl loc (`functions ((fname,[],cv), ftb))
  1293: 
  1294:   (* variadic *)
  1295:   | (ret,Some _,true,a) ->
  1296:     let key = ptr key a in
  1297:     let ftb =
  1298:       let ret = sot (getreg loc) ret in
  1299:       "t -> " ^ ret,"$1->"^fname^"($b)"
  1300:     in
  1301:       let cv = cvqual a in
  1302:       rpl loc (`functions ((fname^"[t]",[],cv), ftb))
  1303: 
  1304:   (* can't be both variadic and have no arguments *)
  1305:   | (_,None,true,_) -> assert false
  1306: 
  1307: let handle_field registry key fname ftype loc =
  1308:   match ftype with
  1309:   | TFun (a,b,c,d) -> handle_method (a,b,c,d) registry key fname loc
  1310: 
  1311:   | _ ->
  1312:     let t = key ^ " -> " ^ sot registry ftype in
  1313:     rpl loc (`fields (("get_"^fname), (t,"$1->"^fname)))
  1314: 
  1315: let gen_cstruct registry loc key cname cfields =
  1316:   let flds = ref [] in
  1317:   iter
  1318:   (fun {fname=fname; ftype=ftype} ->
  1319:     let t = sot registry ftype in
  1320:     flds := (rplname fname,t) :: !flds
  1321:   )
  1322:   cfields
  1323:   ;
  1324:   let flds = rev !flds in
  1325:   rpl loc (`cstruct (cname, flds));
  1326:   if key <> cname then
  1327:     rpl loc (`aliases (key, cname))
  1328: 
  1329: let handle_global g =  let loc = get_globalLoc g in
  1330:   add_loc loc;
  1331:   let type_name = flx_tname g in
  1332:   match isanon g,flx_name g,flx_name' g with
  1333:   | _,None,_
  1334:   | true,_,_ ->
  1335:     begin match g with
  1336: 
  1337:     (* enum { .. }; *)
  1338:     | GEnumTag (ei,_) ->
  1339:       begin match ei with { eitems=eitems } ->
  1340:         iter
  1341:         (fun (s,_,_) ->
  1342:           if ispublic s then rpl loc (`enums (rplname s,s))
  1343:         )
  1344:         eitems
  1345:       end
  1346:     | _ -> ()
  1347:     end
  1348: 
  1349:   | _,Some _,None -> assert false
  1350:   | false,Some key,Some key' ->
  1351:   if not (Hashtbl.mem control.rejects key) then
  1352:   match g with
  1353:   | GType (ti,loc) ->
  1354:     let registry = getreg loc in
  1355:     begin
  1356:       match ti with {ttype=ttype} ->
  1357:       match  ttype with
  1358:       | TComp (ci,_) ->
  1359:         let anon= achk (ciname ci) in
  1360:         (*
  1361:         begin match ci with { cname=cname; cfields=cfields } ->
  1362:         iter
  1363:         (fun {fname=fname; ftype=ftype} ->
  1364:           if not (isanont ftype) && ispublic fname then
  1365:           handle_field registry key fname ftype loc
  1366:         )
  1367:         cfields
  1368:         end
  1369:         ;
  1370:         *)
  1371:         if anon then
  1372:           rpl loc (`abstract_types (type_name, key'))
  1373:         else
  1374:           let v = ptdef registry ti in
  1375:           rpl loc (`struct_aliases (type_name, v))
  1376: 
  1377:       | TEnum (ei,_) ->
  1378:         begin match ei with { eitems=eitems } ->
  1379:         iter
  1380:         (fun (s,_,_) -> if ispublic s then rpl loc (`enums (rplname s,s)))
  1381:         eitems
  1382:         end
  1383:         ;
  1384:         if achk (einame ei) then
  1385:           rpl loc (`abstract_types (type_name, key'))
  1386:         else
  1387:           rpl loc (`aliases (type_name, (ptdef registry ti)))
  1388: 
  1389:       | TFun (_,_,true,_) ->
  1390:         (* HACK: varargs function typedef *)
  1391:         rpl loc (`abstract_types (type_name, key'))
  1392: 
  1393:       | t ->
  1394:         if isanont t then
  1395:           rpl loc (`abstract_types (type_name, key'))
  1396:         else
  1397:           let v = ptdef registry ti in
  1398:           rpl loc (`aliases (type_name, v))
  1399:     end
  1400: 
  1401:   | GCompTag (ci,loc) ->
  1402:     let registry = getreg loc in
  1403:     begin match ci with {
  1404:       cname=cname;
  1405:       cfields=cfields;
  1406:       cstruct=cstruct
  1407:     } ->
  1408:       if can_gen_ctype cstruct cfields then
  1409:         gen_cstruct registry loc type_name cname cfields
  1410:       else begin
  1411:         rpl loc (`abstract_types (type_name, (pcci ci)));
  1412:         iter
  1413:         (fun {fname=fname; ftype=ftype} ->
  1414:           if not (isanont ftype) && ispublic fname then
  1415:           handle_field registry type_name fname ftype loc
  1416:         )
  1417:         cfields
  1418:       end
  1419:     end
  1420: 
  1421: 
  1422:   | GCompTagDecl (ci,loc) ->
  1423:     rpl loc (`incomplete_types (type_name, (pcci ci)))
  1424: 
  1425:   | GEnumTag (ei,loc) ->
  1426:     rpl loc (`aliases (type_name, "int"));
  1427:     begin match ei with { eitems=eitems } ->
  1428:     iter
  1429:     (fun (s,_,_) -> if ispublic s then rpl loc (`enums (rplname s,s)))
  1430:     eitems
  1431:     end
  1432: 
  1433:   | GEnumTagDecl (ci,loc) -> rpl loc (`aliases (type_name, "int"))
  1434: 
  1435:   | GVar (vi,_,loc)
  1436:   | GFun ({svar=vi},loc)
  1437:   | GVarDecl (vi,loc) ->
  1438:     let registry = getreg loc in
  1439:     let vname, vtype=
  1440:       match vi with {vname=vname; vtype=vtype}->vname,vtype
  1441:     in
  1442:     if ispublic vname then
  1443:     begin match vtype with
  1444:     | TFun _ -> handle_global_fun vtype registry key key' vname loc
  1445:     | _ ->
  1446:       rpl loc (`variables (key, (sot (getreg loc) vtype)))
  1447:     end
  1448: 
  1449:   | GAsm _ -> print_endline "GASM"
  1450:   | GPragma _ -> print_endline "PRAGMA"
  1451:   | GText _ -> print_endline "TEXT"
  1452: ;;
  1453: 
  1454: List.iter handle_global gs
  1455: ;;
  1456: 
  1457: let is_nonempty h =
  1458:   try
  1459:     Hashtbl.iter (fun _ -> raise Not_found) h;
  1460:     false
  1461:    with Not_found -> true
  1462: ;;
  1463: 
  1464: exception Found of string
  1465: 
  1466: let pathname_of f =
  1467:   try
  1468:     iter
  1469:     (fun s ->
  1470:       let x = Filename.concat s f in
  1471:       if Sys.file_exists x then raise (Found x)
  1472:     )
  1473:     control.include_path;
  1474:     raise Not_found
  1475:   with Found s -> s
  1476: ;;
  1477: 
  1478: let rec find_includes' includes fname =
  1479:   if not (StringSet.mem fname !includes) then
  1480:     let f = force_open_in "find_includes'" fname in
  1481:     includes := StringSet.add fname !includes;
  1482:     begin try
  1483:       let rec aux () =
  1484:         let line = input_line f in
  1485:         let n = String.length line in
  1486:         let i = ref 0 in
  1487: 
  1488:         try
  1489:           (* skip white *)
  1490:           while !i < n && line.[!i]=' ' do incr i done;
  1491:           if !i = n then raise Next;
  1492: 
  1493:           (* check # *)
  1494:           if line.[!i]<>'#' then raise Next;
  1495:           incr i;
  1496: 
  1497:           (* skip white *)
  1498:           while !i < n && line.[!i]=' ' do incr i done;
  1499:           if !i = n then raise Next;
  1500: 
  1501:           (* check include *)
  1502:           if !i+String.length "include" > n then raise Next;
  1503:           let li = String.length "include" in
  1504:           if (String.sub line !i li)  <> "include" then raise Next;
  1505:           i := !i + li;
  1506: 
  1507:           (* skip white *)
  1508:           while !i < n && line.[!i]=' ' do incr i done;
  1509: 
  1510:           (* check < or '"' *)
  1511:           if line.[!i]<>'"' && line.[!i]<>'<' then raise Next;
  1512:           incr i;
  1513: 
  1514:           (* skip to > or '"' *)
  1515:           let j = !i in
  1516:           while !i < n && line.[!i]<>'>' && line.[!i]<>'"' do incr i done;
  1517: 
  1518:           (* extract filename *)
  1519:           let filename = String.sub line j (!i-j) in
  1520: 
  1521: 
  1522:           (* lookup full path name *)
  1523:           let filename =
  1524:             if not (Filename.is_relative filename) then filename else
  1525:             try pathname_of filename
  1526:             with Not_found ->
  1527:               (*
  1528:               print_endline
  1529:               (
  1530:                 "[include_file'] Can't resolve " ^ filename ^
  1531:                 " included from " ^ fname
  1532:               );
  1533:               *)
  1534:               raise Next
  1535:           in
  1536:           add_file filename;
  1537: 
  1538:           (* if not already known, put transitive closure in set *)
  1539:           if StringSet.mem filename !includes then raise Next;
  1540:           includes := StringSet.add filename !includes;
  1541:           find_includes' includes filename;
  1542: 
  1543:           (* next line *)
  1544:           raise Next
  1545:         with Next -> aux ()
  1546:       in
  1547:         aux()
  1548:     with End_of_file -> close_in f
  1549:     end
  1550: ;;
  1551: 
  1552: let find_includes fname =
  1553:   let includes = ref StringSet.empty in
  1554:   find_includes' includes fname;
  1555:   let extras =
  1556:     try Hashtbl.find control.rev_merge_files fname
  1557:     with Not_found -> []
  1558:   in
  1559:   iter (find_includes' includes) extras
  1560:   ;
  1561:   stringset_map map_filename !includes
  1562: ;;
  1563: 
  1564: let global_includes = ref StringSet.empty
  1565: ;;
  1566: 
  1567: Hashtbl.iter
  1568: begin
  1569:   fun fname stab ->
  1570:   let includes = ref (find_includes stab.stab_cfile) in
  1571:   let ict = Hashtbl.create 97 in
  1572:   let xtyps = Hashtbl.create 97 in
  1573:   Hashtbl.iter
  1574:   (fun k v ->
  1575:     if not (Hashtbl.mem stab.abstract_types k) then
  1576:     try
  1577:       let file = Hashtbl.find control.all_types k in
  1578:       includes := StringSet.add file !includes;
  1579:       Hashtbl.add xtyps k file;
  1580: 
  1581:     with Not_found ->
  1582:       Hashtbl.add ict k v;
  1583:       let v',ms =
  1584:         try Hashtbl.find control.incomplete_types_cache k
  1585:         with Not_found -> v,[]
  1586:       in
  1587:       if v'<>v then
  1588:       failwith ("Inconsistent type " ^k^"->"^ v ^ " <> " ^ v')
  1589:       ;
  1590:       Hashtbl.replace control.incomplete_types_cache k (v,stab.stab_module::ms)
  1591:     else
  1592:       ()
  1593:   )
  1594:   stab.incomplete_types
  1595:   ;
  1596: 
  1597:   let udt = Hashtbl.create 97 in
  1598:   Hashtbl.iter
  1599:   (fun k v ->
  1600:     let k = rplname k in
  1601:     if not (Hashtbl.mem control.rejects k) then
  1602:     try
  1603:       let file = Hashtbl.find control.all_types k in
  1604:       includes := StringSet.add file !includes;
  1605:     with Not_found ->
  1606:       if not (Hashtbl.mem control.incomplete_types_cache k) then
  1607:       Hashtbl.add udt k v
  1608:   )
  1609:   stab.used_types
  1610:   ;
  1611:   stab.includes <- !includes;
  1612:   global_includes := StringSet.union !global_includes !includes;
  1613:   stab.udt <- udt;
  1614:   stab.ict <- ict;
  1615:   stab.xtyps <- xtyps
  1616: end
  1617: control.stabs
  1618: ;;
  1619: 
  1620: (* closure for stabs .. *)
  1621: StringSet.iter
  1622: (fun s -> ignore(getstab s))
  1623: !global_includes
  1624: ;;
  1625: 
  1626: StringSet.iter
  1627: (fun s ->
  1628:    let filename =
  1629:      if not (Filename.is_relative s) then s else
  1630:      try pathname_of s
  1631:      with Not_found ->
  1632:        print_endline ( "Can't resolve primary file " ^ s);
  1633:        print_endline ("in path: ");
  1634:        iter
  1635:        (fun s -> print_endline s)
  1636:        control.include_path
  1637:        ;
  1638:        print_endline "Try adding path statement to control file";
  1639:        failwith ("Filename resolution error")
  1640:    in
  1641:      ignore(getstab filename)
  1642: )
  1643: control.raw_includes
  1644: ;;
  1645: 
  1646: let rec find_macros fname =
  1647:   let macros = ref [] in
  1648:   begin
  1649:     try
  1650:       let f = open_in fname in
  1651:       begin
  1652:         try
  1653:           let rec aux () =
  1654:             let line = input_line f in
  1655:             let n = String.length line in
  1656:             let i = ref 0 in
  1657: 
  1658:             try
  1659:               (* skip white *)
  1660:               while !i < n && line.[!i]=' ' do incr i done;
  1661:               if !i = n then raise Next;
  1662: 
  1663:               (* check # *)
  1664:               if line.[!i]<>'#' then raise Next;
  1665:               incr i;
  1666: 
  1667:               (* skip white *)
  1668:               while !i < n && line.[!i]=' ' do incr i done;
  1669:               if !i = n then raise Next;
  1670: 
  1671:               (* check include *)
  1672:               let li = String.length "define" in
  1673:               if !i+li > n then raise Next;
  1674:               if (String.sub line !i li)  <> "define" then raise Next;
  1675:               i := !i + li;
  1676: 
  1677:               (* skip white *)
  1678:               while !i < n && line.[!i]=' ' do incr i done;
  1679:               let m = String.sub line !i (n - !i) in
  1680:               macros := m :: !macros;
  1681: 
  1682:               (* next line *)
  1683:               raise Next
  1684:             with Next -> aux ()
  1685:           in
  1686:             aux()
  1687:         with End_of_file -> close_in f
  1688:       end
  1689:     with _ -> ()
  1690:   end
  1691:   ;
  1692:   !macros
  1693: ;;
  1694: exception Equal
  1695: exception Not_equal
  1696: ;;
  1697: let fnames = ref [];;
  1698: Hashtbl.iter
  1699: (fun f _ -> fnames := f :: !fnames)
  1700: control.stabs
  1701: ;;
  1702: let fnames = List.sort compare !fnames
  1703: ;;
  1704: iter begin
  1705:   fun fname ->
  1706:   let stab = Hashtbl.find control.stabs fname in
  1707:   let outname = stab.stab_flxfile in
  1708:   let mode, outf =
  1709:     if Sys.file_exists outname then
  1710:       `tmp, force_open_out "generate_file" "tmp.tmp"
  1711:     else
  1712:       `orig,autocreate outname
  1713:   in
  1714:   let pe s = output_string outf (s ^ "\n") in
  1715: 
  1716:   pe ("//Module        : " ^ stab.stab_module);
  1717:   pe ("//Timestamp     : " ^ compile_start_gm_string);
  1718:   pe ("//Timestamp     : " ^ compile_start_local_string);
  1719:   pe ("//Raw Header    : " ^ fname);
  1720:   pe ("//Preprocessor  : " ^ control.preprocessor);
  1721:   pe ("//Input file: " ^ control.preout_filename);
  1722:   pe ("//Flxcc Control : " ^ control.control_filename);
  1723:   pe ("//Felix Version : " ^ !version_data.version_string);
  1724:   pe ("include 'std';");
  1725:   pe "";
  1726:   let macros = find_macros fname in
  1727:   iter
  1728:   (fun s-> pe ("//#define " ^ s))
  1729:   macros
  1730:   ;
  1731:   if not (mem fname control.noincludes) then
  1732:     pe ("header '#include \"" ^ fname^"\"';")
  1733:   else
  1734:     pe ("//NOT INCLUDED: \"" ^ fname^"\"")
  1735:   ;
  1736: 
  1737: 
  1738:   begin
  1739:     try
  1740:       Hashtbl.iter
  1741:       (fun k v->
  1742:         match Hashtbl.find control.incomplete_types_cache k with
  1743:         | (_,[_]) -> ()
  1744:         | _ ->
  1745:           pe ("include \"_incomplete_types_cache\";");
  1746:           raise Not_found
  1747:       )
  1748:       stab.ict
  1749:     with Not_found -> ()
  1750:   end
  1751:   ;
  1752: 
  1753: 
  1754:   let include_depends =
  1755:     let x = stringset_map map_filename stab.includes in
  1756:     let x = stringset_map flxinclude_of_cfile x in
  1757:     StringSet.remove stab.stab_flxinclude x
  1758:   in
  1759:   let module_depends =
  1760:     let x = stringset_map map_filename stab.includes in
  1761:     let x = stringset_map (fun s -> module_of_cfilename s) x in
  1762:     StringSet.remove stab.stab_module x
  1763:   in
  1764: 
  1765:   if StringSet.cardinal include_depends > 0 then
  1766:   begin
  1767:     pe "";
  1768:     pe "//INCLUDES";
  1769:     StringSet.iter
  1770:     (fun incname ->
  1771:       pe ("include \"" ^ incname^ "\";")
  1772:     )
  1773:     include_depends
  1774:   end
  1775:   ;
  1776: 
  1777:   pe "";
  1778:   pe ("module " ^ stab.stab_module ^ "\n{");
  1779:   begin
  1780:     let pe s = output_string outf ("  " ^ s ^ "\n") in
  1781:     pe "open C_hack;";
  1782:     if StringSet.cardinal module_depends > 0 then
  1783:     begin
  1784:       StringSet.iter
  1785:       (fun modulename' ->
  1786:         pe ("open " ^ modulename' ^";")
  1787:       )
  1788:       module_depends
  1789:     end
  1790:     ;
  1791: 
  1792:     if is_nonempty stab.abstract_types then
  1793:     begin
  1794:       pe "";
  1795:       pe "//ABSTRACT TYPES";
  1796:       Hashtbl.iter
  1797:       (fun k v->
  1798:         pe ("type " ^ k ^ " = '" ^ v ^ "';")
  1799:       )
  1800:       stab.abstract_types
  1801:     end
  1802:     ;
  1803: 
  1804:     if is_nonempty stab.cstructs then
  1805:     begin
  1806:       pe "";
  1807:       pe "//CSTRUCTS ";
  1808:       Hashtbl.iter
  1809:       (fun k flds ->
  1810:         pe ("cstruct " ^ k ^ " {");
  1811:         iter (fun (fld,typ) ->
  1812:           pe ("  " ^ fld ^": " ^ typ^ ";")
  1813:         )
  1814:         flds
  1815:         ;
  1816:         pe ("}")
  1817:       )
  1818:       stab.cstructs
  1819:     end
  1820:     ;
  1821: 
  1822:     if is_nonempty stab.registry then
  1823:     begin
  1824:       pe "";
  1825:       pe "//C FUNCTION POINTER TYPES";
  1826:       Hashtbl.iter
  1827:       (fun _ (name,tdef)->
  1828:         pe ("header '''" ^ tdef ^ "''';");
  1829:         pe ("type " ^ name ^ " = '" ^ name ^ "';")
  1830:       )
  1831:       stab.registry
  1832:     end
  1833:     ;
  1834: 
  1835:     if is_nonempty stab.xtyps then
  1836:     begin
  1837:       pe "";
  1838:       pe "//EXTERNALLY COMPLETED TYPES";
  1839:       Hashtbl.iter
  1840:       (fun k v->
  1841:         let m = module_of_cfilename v in
  1842:         pe ("//type " ^ k ^ " defined in "^m^"='" ^ v ^ "';")
  1843:       )
  1844:       stab.xtyps
  1845:     end
  1846:     ;
  1847: 
  1848:     if is_nonempty stab.ict then
  1849:     begin
  1850:       pe "";
  1851:       pe "//PURE INCOMPLETE TYPES";
  1852:       Hashtbl.iter
  1853:       (fun k v->
  1854:         match Hashtbl.find control.incomplete_types_cache k with
  1855:         | (_,[_]) ->
  1856:           pe ("type " ^ k ^ " = '" ^ v ^ "'; //local")
  1857:         | (_,ls) ->
  1858:           pe ("typedef " ^ k ^ " = _incomplete_types::" ^ k ^ ";//shared");
  1859:           iter (fun s->pe ("//shared by: " ^ s)) ls
  1860:       )
  1861:       stab.ict
  1862:     end
  1863:     ;
  1864: 
  1865:     if is_nonempty stab.udt then
  1866:     begin
  1867:       pe "";
  1868:       pe "//TYPES WE CAN'T FIND";
  1869:       Hashtbl.iter
  1870:       (fun k _ ->
  1871:         pe ("//type " ^ k ^ " ??")
  1872:       )
  1873:       stab.udt
  1874:     end
  1875:     ;
  1876: 
  1877:     if is_nonempty stab.struct_aliases then
  1878:     begin
  1879:       pe "";
  1880:       pe "//STRUCT or UNION TAG ALIASES";
  1881:       Hashtbl.iter
  1882:       (fun k v->
  1883:         (* va_list is already defined in the standard library *)
  1884:         if k <> "va_list" then
  1885:         (* hack to fiddle typedef X {} X *)
  1886:         if not (Hashtbl.mem stab.cstructs k) then
  1887:         pe ("typedef " ^ k ^ " = " ^ v ^ ";")
  1888:       )
  1889:       stab.struct_aliases
  1890:     end
  1891:     ;
  1892: 
  1893:     if is_nonempty stab.aliases then
  1894:     begin
  1895:       pe "";
  1896:       pe "//TYPE ALIASES";
  1897:       Hashtbl.iter
  1898:       (fun k v->
  1899:         (* va_list is already defined in the standard library *)
  1900:         if k <> "va_list" then
  1901:         pe ("typedef " ^ k ^ " = " ^ v ^ ";")
  1902:       )
  1903:       stab.aliases
  1904:     end
  1905:     ;
  1906: 
  1907:     if is_nonempty stab.variables then
  1908:     begin
  1909:       pe "";
  1910:       pe "//VARIABLES";
  1911:       Hashtbl.iter
  1912:       (fun k v->
  1913:         pe ("const " ^ k ^ ": " ^v^ " = '" ^ k ^ "';")
  1914:       )
  1915:       stab.variables
  1916:     end
  1917:     ;
  1918: 
  1919:     if is_nonempty stab.enums then
  1920:     begin
  1921:       pe "";
  1922:       pe "//ENUMERATION CONSTANTS";
  1923:       Hashtbl.iter
  1924:       (fun k v ->
  1925:         pe ("const " ^ k ^ ": int = '" ^ v ^ "';")
  1926:       )
  1927:       stab.enums
  1928:     end
  1929:     ;
  1930: 
  1931:     if is_nonempty stab.procedures then
  1932:     begin
  1933:       pe "";
  1934:       pe "//PROCEDURES";
  1935:       let ps = ref [] in
  1936:       Hashtbl.iter
  1937:       (fun (k,_,_) v -> ps := (k,v):: !ps)
  1938:       stab.procedures
  1939:       ;
  1940:       let ps = sort compare !ps in
  1941:       iter
  1942:       (fun (k, (v,b)) ->
  1943:         if b = "" then
  1944:          pe ("proc " ^ k ^ ": " ^v^ ";")
  1945:         else
  1946:          pe ("proc " ^ k ^ ": " ^v^ " = '"^b^"';")
  1947:       )
  1948:       ps
  1949:     end
  1950:     ;
  1951: 
  1952:     if is_nonempty stab.functions then
  1953:     begin
  1954:       pe "";
  1955:       pe "//FUNCTIONS";
  1956:       let ps = ref [] in
  1957:       Hashtbl.iter
  1958:       (fun (k,_,_) v -> ps := (k,v):: !ps)
  1959:       stab.functions
  1960:       ;
  1961:       let ps = sort compare !ps in
  1962:       iter
  1963:       (fun (k, (v,b))->
  1964:         if b = "" then
  1965:           pe ("fun " ^ k ^ ": " ^v^ ";")
  1966:         else
  1967:           pe ("fun " ^ k ^ ": " ^v^ " = '" ^ b ^ "';")
  1968:       )
  1969:       ps
  1970:     end
  1971:     ;
  1972: 
  1973:     if is_nonempty stab.callback_types then
  1974:     begin
  1975:       let sot t = sot stab t in
  1976:       let soa a = soa stab a in
  1977:       pe "";
  1978:       pe "//CALLBACK TYPE WRAPPERS";
  1979:       Hashtbl.iter
  1980:       (fun tname (t, cbi)->
  1981:         pe ("//callback type " ^ tname ^ ", client data at " ^ string_of_int cbi);
  1982:         let ccbt = "_ccbt_" ^ tname in
  1983:         let fcbt = "_fcbt_" ^ tname in
  1984:         let fcbat = "_fcbat_" ^ tname in
  1985:         let fcbw = "_fcbw_" ^ tname in
  1986:         match t with
  1987:         | TPtr (TFun (ret,Some ps, false,a),_) ->
  1988:           (* fix arg names *)
  1989:           let i = ref 0 in
  1990:           let ps =
  1991:             map
  1992:             (fun (_,t,a) ->
  1993:               incr i;
  1994:               let pn = "a"^ string_of_int !i in
  1995:               pn,t,a
  1996:             )
  1997:             ps
  1998:           in
  1999:           let t' = TFun (ret,Some ps, false,a) in
  2000:           (* get the non-client data arguments *)
  2001:           let ps' = ref [] in
  2002:           let i = ref 0 in
  2003:           iter
  2004:           (fun x -> if cbi = !i then () else ps' := x :: !ps'; incr i)
  2005:           ps
  2006:           ;
  2007:           let ps' = rev !ps' in
  2008:           (* make a typedef for the felix callback type
  2009:           mainly as documentation [since the client will
  2010:           declare a function of this type, the actual
  2011:           typedef isn't that useful]
  2012:           *)
  2013: 
  2014:           begin match ret with
  2015:           | TVoid _ ->
  2016:             let args =
  2017:              if length ps' = 0 then "1"
  2018:             else String.concat " * " (List.map soa ps')
  2019:             in
  2020:             pe ("typedef " ^ fcbat ^ " = " ^ args ^ "; ");
  2021:             pe ("export type (" ^ fcbat ^ ") as \""^fcbat^"\";");
  2022:             pe ("typedef " ^ fcbt ^ " = " ^ args ^ " -> void; ");
  2023:             pe ("export type (" ^ fcbt ^ ") as \""^fcbt^"\";");
  2024:             let sr = {line=0;file="";byte=0} in
  2025:             let vi =
  2026:               {
  2027:                 vname=fcbw; vtype=t'; vattr=[]; vglob=true;
  2028:                 vinline=false; vdecl=sr; vid=0; vaddrof=false;
  2029:                 vreferenced=true; vstorage=NoStorage
  2030:               }
  2031:             in
  2032:             let g =  GVarDecl (vi,sr) in
  2033:             let d = defaultCilPrinter#pGlobal () g in
  2034:             let s = Flx_cil_pretty.sprint 65 d in
  2035:             let s = reformatc s in
  2036:             pe ("header '''" ^ s ^ "''';\n");
  2037:             pe ("const "^fcbw^": " ^ tname ^ " = \"" ^ fcbw ^ "\";");
  2038: 
  2039:             (* hack: elide trailing semicolon *)
  2040:             let s = String.sub s 0 (String.length s - 1) in
  2041:             pe ("body '''\n  " ^ s ^ "{");
  2042:             let oargs = ref [] in
  2043:             iter
  2044:             (fun i -> if i <> cbi then
  2045:               oargs := ("a" ^ string_of_int (i+1)) :: !oargs
  2046:             )
  2047:             (nlist (length ps))
  2048:             ;
  2049:             pe (
  2050:               "  con_t *p  = (("^fcbt^")a" ^ string_of_int (cbi+1) ^
  2051:               ")->call(" ^
  2052:               if List.length !oargs > 1 then
  2053:                 "0, " ^fcbat^"(" ^ String.concat ", " (rev !oargs)^"));"
  2054:               else
  2055:                 String.concat ", " ("0" :: rev !oargs)^");"
  2056:             );
  2057:             pe ("  while(p) p=p->resume();");
  2058:             pe ("}''';\n");
  2059: 
  2060:           | _ ->
  2061:             let args =
  2062:              if length ps' = 0 then "1"
  2063:             else String.concat " * " (List.map soa ps')
  2064:             in
  2065:             let args =
  2066:              if length ps' = 0 then "1"
  2067:             else String.concat " * " (List.map soa ps')
  2068:             in
  2069:             pe ("typedef " ^ fcbat ^ " = "^ args ^ ";");
  2070:             pe ("export type (" ^ fcbat ^ ") as \""^fcbat^"\";");
  2071:             pe ("typedef " ^ fcbt ^ " = "^ args ^ " -> "^sot ret^"; ");
  2072:             pe ("export type (" ^ fcbt ^ ") as \""^fcbt^"\";");
  2073:             let sr = {line=0;file="";byte=0} in
  2074:             let vi =
  2075:               {
  2076:                 vname=fcbw; vtype=t'; vattr=[]; vglob=true;
  2077:                 vinline=false; vdecl=sr; vid=0; vaddrof=false;
  2078:                 vreferenced=true; vstorage=NoStorage
  2079:               }
  2080:             in
  2081:             let g =  GVarDecl (vi,sr) in
  2082:             let d = defaultCilPrinter#pGlobal () g in
  2083:             let s = Flx_cil_pretty.sprint 65 d in
  2084:             let s = reformatc s in
  2085:             pe ("header '''" ^ s ^ "''';\n");
  2086:             pe ("const "^fcbw^": " ^ tname ^ " = \"" ^ fcbw ^ "\";");
  2087: 
  2088:             (* hack: elide trailing semicolon *)
  2089:             let s = String.sub s 0 (String.length s - 1) in
  2090:             pe ("body '''\n  " ^ s ^ "{");
  2091:             let oargs = ref [] in
  2092:             iter
  2093:             (fun i -> if i <> cbi then
  2094:               oargs := ("a" ^ string_of_int (i+1)) :: !oargs
  2095:             )
  2096:             (nlist (length ps))
  2097:             ;
  2098:             pe (
  2099:               "  return (("^fcbt^")a" ^ string_of_int (cbi+1) ^
  2100:               ")->apply(" ^
  2101:               if List.length !oargs > 1 then
  2102:                 fcbat^"(" ^
  2103:                 String.concat ", " (rev !oargs)^"));"
  2104:               else
  2105:                 String.concat ", " (rev !oargs)^");"
  2106:             );
  2107:             pe ("}''';\n");
  2108: 
  2109:           end
  2110:           ;
  2111:         | _ -> assert false
  2112:       )
  2113:       stab.callback_types
  2114:     end
  2115:     ;
  2116: 
  2117:     if is_nonempty stab.callback_clients then
  2118:     begin
  2119:       let sot t = sot stab t in
  2120:       let soa a = soa stab a in
  2121:       pe "";
  2122:       pe "//CALLBACK CLIENT WRAPPERS";
  2123:       Hashtbl.iter
  2124:       (fun fname (t, cbt, cbi,adri)->
  2125:         pe ("//callback client " ^ fname ^ ", client data at " ^ string_of_int cbi ^ ", callback at " ^ string_of_int adri);
  2126:         match t with
  2127:         | TFun (ret,Some ps, false,a) ->
  2128:           (* fix arg names *)
  2129:           let i = ref 0 in
  2130:           let args = ref [] in
  2131:           iter
  2132:           (fun (_,t,a) ->
  2133:             if !i <> adri then begin
  2134:               let pn = "a"^ string_of_int (!i+1) in
  2135:               let t =
  2136:                 if !i = cbi then "_fcbt_" ^ sot t
  2137:                 else sot t
  2138:               in
  2139:               args := (pn,t) :: !args
  2140:             end
  2141:             ;
  2142:             incr i
  2143:           )
  2144:           ps
  2145:           ;
  2146:           let args = rev !args in
  2147:           let params =
  2148:             catmap ", "
  2149:             (fun (n,t) -> n ^ ": " ^ t)
  2150:             args
  2151:           in
  2152:           let call_args = ref [] in
  2153:           let i = ref 0 in
  2154:           for j = 0 to length ps - 1 do
  2155:             call_args :=
  2156:               begin
  2157:                 if j = adri then
  2158:                   ("C_hack::cast[address]a"^ string_of_int (cbi+1))
  2159:                 else if j = cbi then
  2160:                   ("_fcbw_" ^ cbt)
  2161:                 else begin
  2162:                   while !i=cbi || !i=adri do incr i done;
  2163:                   let a = "a"^ string_of_int (!i+1) in
  2164:                   incr i;
  2165:                   a
  2166:                 end
  2167:               end
  2168:             ::
  2169:             !call_args
  2170:           done
  2171:           ;
  2172:           begin match ret with
  2173:           | TVoid _ ->
  2174:             pe ("proc wrapper_" ^ fname ^ "(" ^ params ^ ") {");
  2175:             pe ("  " ^fname^"(" ^ String.concat ", " (rev !call_args) ^ ");");
  2176:             pe ("}")
  2177: 
  2178:           | ret ->
  2179:             let ret = sot ret in
  2180:             pe ("fun wrapper_" ^ fname ^ "(" ^ params ^ "): "^ret^"= {");
  2181:             pe ("  return " ^fname^"(" ^ String.concat ", " (rev !call_args) ^ ");");
  2182:             pe ("}")
  2183: 
  2184:           end
  2185: 
  2186:         | _ -> assert false
  2187:       )
  2188:       stab.callback_clients
  2189:     end
  2190:     ;
  2191: 
  2192:     if is_nonempty stab.fields then
  2193:     begin
  2194:       pe "";
  2195:       pe "//STRUCT and UNION FIELDS";
  2196:       Hashtbl.iter
  2197:       (fun k (v,b)->
  2198:         pe ("fun " ^ k ^ ": " ^v^ " = '" ^ b ^ "';")
  2199:       )
  2200:       stab.fields
  2201:     end
  2202:   end
  2203:   ;
  2204:   pe "}";
  2205:   close_out outf
  2206:   ;
  2207:   match mode with
  2208:   | `orig -> print_endline ("New file " ^ outname); ()
  2209:   | `tmp ->
  2210:     let f1 = force_open_in "new_file" "tmp.tmp" in
  2211:     let f2 = force_open_in "changed_file" outname in
  2212:     for i = 1 to 6 do (* skip timestamps when comparing *)
  2213:       ignore(input_line f1);
  2214:       ignore(input_line f2)
  2215:     done
  2216:     ;
  2217:     try
  2218:       while true do
  2219:         let in1 = try Some (input_line f1) with End_of_file -> None in
  2220:         let in2 = try Some (input_line f2) with End_of_file -> None in
  2221:         match in1,in2 with
  2222:         | None, None -> raise Equal
  2223:         | Some i, Some j when i = j -> ()
  2224:         | _ -> raise Not_equal
  2225:       done
  2226:     with
  2227:       | Not_equal ->
  2228:         begin
  2229:           print_endline ("Changed file .. " ^ outname);
  2230:           close_in f1; close_in f2;
  2231:           let f1 = force_open_in "changed_file" "tmp.tmp" in
  2232:           let f2 = force_open_out "change_file" outname in
  2233:           try while true do output_string f2 ((input_line f1) ^ "\n")
  2234:           done with End_of_file ->
  2235:           close_in f1; close_out f2
  2236:         end
  2237: 
  2238:       | Equal ->
  2239:         print_endline ("Unchanged file .. " ^ outname);
  2240:         close_in f2;
  2241:         close_in f1
  2242: end
  2243: fnames
  2244: ;;
  2245: 
  2246: if is_nonempty control.incomplete_types_cache then
  2247:   let outname =
  2248:     Filename.concat (control.outdir)
  2249:     ("_incomplete_types_cache.flx")
  2250:   in
  2251:   let outf = autocreate outname in
  2252:   let print_endline s = output_string outf (s ^ "\n") in
  2253:   print_endline "//incomplete type cache";
  2254:   print_endline "module _incomplete_types {";
  2255:   Hashtbl.iter
  2256:   (fun k (v,m) ->
  2257:     match m with
  2258:     | [_] -> ()
  2259:     | _ ->
  2260:       print_endline ("incomplete type " ^ k ^ " = '" ^v^ "';");
  2261:       List.iter
  2262:       (fun s -> print_endline ("  // used by " ^ s)
  2263:       )
  2264:       m
  2265:   )
  2266:   control.incomplete_types_cache
  2267:   ;
  2268:   print_endline "}";
  2269:   close_out outf
  2270: ;;
  2271: 
  2272: let flx f =
  2273:   if control.flxg_command <> "" then begin
  2274:     let cmd = control.flxg_command ^ " -I"^control.outdir^" -c " ^f in
  2275:     print_endline cmd;
  2276:     Unix.system(cmd)
  2277:   end
  2278:   else Unix.WEXITED 0 (* cheat *)
  2279: ;;
  2280: 
  2281: let fnames = ref []
  2282: ;;
  2283: 
  2284: let rec dflx dir =
  2285:   try
  2286:     let f = Unix.opendir dir in
  2287:     begin
  2288:       try
  2289:         while true do let m = Unix.readdir f in
  2290:           let path = Filename.concat dir m in
  2291:           let st =
  2292:             try Unix.lstat path
  2293:             with _ -> failwith ("Can't lstat " ^ path)
  2294:           in
  2295:           match st.Unix.st_kind with
  2296:           | Unix.S_REG ->
  2297:             if Filename.check_suffix path ".flx" then
  2298:             let fn = Filename.chop_suffix path ".flx" in
  2299:             fnames := fn :: !fnames
  2300: 
  2301:           | Unix.S_DIR ->
  2302:             if not (isprefix "." m) then dflx path
  2303:           | _ -> ()
  2304:         done
  2305:       with End_of_file -> Unix.closedir f
  2306:     end
  2307:   with Unix.Unix_error _ ->
  2308:     failwith ("Can't find directory " ^ dir)
  2309: ;;
  2310: 
  2311: dflx control.outdir
  2312: ;;
  2313: 
  2314: let fnames = List.sort compare !fnames
  2315: ;;
  2316: let faulty = ref [];;
  2317: let good = ref [];;
  2318: 
  2319: iter
  2320: begin fun fn ->
  2321:   let result = flx fn in
  2322:   match result with
  2323:   | Unix.WEXITED 0 -> good := fn :: !good
  2324:   | Unix.WEXITED i ->
  2325:     faulty := fn :: !faulty;
  2326:     print_endline ("***** Failed, error " ^ string_of_int i)
  2327:   | Unix.WSIGNALED i
  2328:   | Unix.WSTOPPED i ->
  2329:     failwith ("SIGNAL " ^ string_of_int i)
  2330: end
  2331: fnames
  2332: ;;
  2333: 
  2334: let f = open_out control.log_filename in
  2335:   iter
  2336:   (fun fn ->
  2337:     output_string f ("FAILED   : " ^ fn ^ "\n")
  2338:   )
  2339:   (rev !faulty)
  2340:   ;
  2341:   iter
  2342:   (fun fn ->
  2343:     output_string f ("SUCCEEDED: " ^ fn ^ "\n")
  2344:   )
  2345:   (rev !good)
  2346:   ;
  2347:   close_out f
  2348: ;;
  2349: 
End ocaml section to src/flxcc.ml[1]
Start data section to config/felix.flxcc[1 /1 ]
     1: // Felix: language and core library wrapper control
     2: //
     3: // rename Felix keywords
     4: rename all all_
     5: rename assert assert_
     6: rename axiom axiom_
     7: rename body body_
     8: rename call call_
     9: rename case case_
    10: rename caseno caseno_
    11: rename class class_
    12: rename comment comment_
    13: rename compound compound_
    14: rename const const_
    15: rename cclass cclass_
    16: rename cstruct cstruct_
    17: rename ctor ctor_
    18: rename ctypes ctypes_
    19: rename def def_
    20: rename do do_
    21: rename done done_
    22: rename elif elif_
    23: rename else else_
    24: rename endif endif_
    25: rename endmatch endmatch_
    26: rename enum enum_
    27: rename expect expect_
    28: rename export export_
    29: rename for for_
    30: rename forget forget_
    31: rename fork fork_
    32: rename functor functor_
    33: rename fun fun_
    34: rename goto goto_
    35: rename header header_
    36: rename ident ident_
    37: rename include include_
    38: rename incomplete incomplete_
    39: rename inf inf_
    40: rename in in_
    41: rename is is_
    42: rename inherit inherit_
    43: rename inline inline_
    44: rename jump jump_
    45: rename let let_
    46: rename loop loop_
    47: rename lval lval_
    48: rename macro macro_
    49: rename module module_
    50: rename NaN NaN_
    51: rename new new_
    52: rename noinline noinline_
    53: rename nonterm nonterm_
    54: rename noreturn noreturn_
    55: rename not not_
    56: rename obj obj_
    57: rename open open_
    58: rename package package_
    59: rename pod pod_
    60: rename private private_
    61: rename proc proc_
    62: rename property property_
    63: rename reduce reduce_
    64: rename rename rename_
    65: rename requires requires_
    66: rename return return_
    67: rename struct struct_
    68: rename then then_
    69: rename todo todo_
    70: rename to to_
    71: rename typedef typedef_
    72: rename type type_
    73: rename union union_
    74: rename use use_
    75: rename val val_
    76: rename var var_
    77: rename when when_
    78: rename with with_
    79: rename _ __
    80: rename _gc_pointer _gc_pointer_
    81: rename _gc_type _gc_type_
    82: rename _svc _svc_
    83: rename _deref _deref_
    84: rename and and_
    85: rename as as_
    86: rename callback callback_
    87: rename code code_
    88: rename if if_
    89: rename isin isin_
    90: rename match match_
    91: rename noexpand noexpand_
    92: rename of of_
    93: rename or or_
    94: rename parse parse_
    95: rename regexp regexp_
    96: rename reglex reglex_
    97: rename regmatch regmatch_
    98: rename the the_
    99: rename typematch typematch_
   100: //
   101: // We need to rename any C++ keywords too
   102: rename namespace namespace_
   103: rename namespace namespace_
   104: //
   105: // remap C types to Felix standard library types
   106: rename size_t size
   107: rename wchar_t wchar
   108: 
   109: // ignore definitions of Felix standard library types
   110: ignore vlong
   111: ignore int
   112: ignore float
   113: ignore char
   114: ignore uvlong
   115: ignore tiny
   116: ignore byte
   117: ignore size
   118: ignore uchar
   119: ignore wchar
   120: ignore long
   121: ignore int8
   122: ignore uint16
   123: ignore complex
   124: ignore limaginary
   125: ignore dcomplex
   126: ignore uint32
   127: ignore lcomplex
   128: ignore int32
   129: ignore int16
   130: ignore ulong
   131: ignore uint8
   132: ignore uint64
   133: ignore uint
   134: ignore offset
   135: ignore imaginary
   136: ignore dimaginary
   137: ignore cvaddress
   138: ignore utiny
   139: ignore short
   140: ignore double
   141: ignore ushort
   142: ignore int64
   143: ignore caddress
   144: ignore vaddress
   145: ignore ldouble
   146: ignore address
   147: ignore wchar
   148: 
End data section to config/felix.flxcc[1]
Start data section to tmp/gnu_c_search_path.flxcc.default[1 /1 ]
     1: path /usr/local/include
     2: path /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/include
     3: path /usr/include
     4: 
End data section to tmp/gnu_c_search_path.flxcc.default[1]
Start data section to tmp/gnu_cxx_search_path.flxcc.default[1 /1 ]
     1: path /usr/include/c++/4.0.0
     2: path /usr/include/c++/4.0.0/backward
     3: path /usr/include/c++/3.2.2
     4: path /usr/include/c++/3.2.2/backward
     5: path /usr/local/include
     6: path /usr/include/c++/4.0.0/i386-redhat-linux
     7: path /usr/include/c++/3.2.2/i386-redhat-linux
     8: path /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/include
     9: path /usr/include
    10: 
End data section to tmp/gnu_cxx_search_path.flxcc.default[1]
Start data section to tmp/gnu_headers.flxcc.default[1 /1 ]
     1: // This file contains annotations to control
     2: // use of GNU system header files, and some other
     3: // essential system resources
     4: 
     5: // Some files say:
     6: //
     7: // extern struct X X(..
     8: //
     9: // which defines a function of the same name as
    10: // a struct tag -- this is OK in C, problematic
    11: // in C++, and definitely out for Felix
    12: //
    13: // Such functions are renamed by appending a trailin underscore
    14: // without changing the name of the type
    15: //
    16: // NOTE: this is a serious pain because Felix cstructs
    17: // automatically get constructors of the same name
    18: // so the client using such a name may get an overload
    19: // error (or even worse, a program that has the wrong semantics)
    20: 
    21: rename_nontype sigaltstack sigaltstack_
    22: rename_nontype sigstack sigstack_
    23: rename_nontype sigvec sigvec_
    24: rename_nontype mallinfo mallinfo_
    25: rename_nontype vtimes vtimes_
    26: rename_nontype statfs statfs_
    27: rename_nontype timezone timezone_
    28: 
    29: #include config/gnu_linux_macosx_headers.flxcc
End data section to tmp/gnu_headers.flxcc.default[1]
Start data section to tmp/gnu_macosx_headers.flxcc.default[1 /1 ]
     1: 
End data section to tmp/gnu_macosx_headers.flxcc.default[1]
Start data section to tmp/gnu_linux_headers.flxcc.default[1 /1 ]
     1: // Some files are designed as implementation details
     2: // and not intended to be used directly
     3: // We therefore prevent C level #includes like
     4: //
     5: // header '#include <file>';
     6: //
     7: // from being generated
     8: //
     9: // This related to the merge specifications below,
    10: // but the two facilities are independent
    11: 
    12: noheader /usr/include/bits/byteswap.h
    13: noheader /usr/include/bits/cmathcalls.h
    14: noheader /usr/include/bits/confname.h
    15: noheader /usr/include/bits/dirent.h
    16: noheader /usr/include/bits/dlfcn.h
    17: noheader /usr/include/bits/elfclass.h
    18: noheader /usr/include/bits/endian.h
    19: noheader /usr/include/bits/environments.h
    20: noheader /usr/include/bits/fcntl.h
    21: noheader /usr/include/bits/fenv.h
    22: noheader /usr/include/bits/huge_val.h
    23: noheader /usr/include/bits/in.h
    24: noheader /usr/include/bits/ioctls.h
    25: noheader /usr/include/bits/ioctl-types.h
    26: noheader /usr/include/bits/ipc.h
    27: noheader /usr/include/bits/ipctypes.h
    28: noheader /usr/include/bits/locale.h
    29: noheader /usr/include/bits/mathcalls.h
    30: noheader /usr/include/bits/mathdef.h
    31: noheader /usr/include/bits/mathinline.h
    32: noheader /usr/include/bits/mman.h
    33: noheader /usr/include/bits/msq.h
    34: noheader /usr/include/bits/nan.h
    35: noheader /usr/include/bits/netdb.h
    36: noheader /usr/include/bits/poll.h
    37: noheader /usr/include/bits/posix1_lim.h
    38: noheader /usr/include/bits/posix2_lim.h
    39: noheader /usr/include/bits/pthreadtypes.h
    40: noheader /usr/include/bits/resource.h
    41: noheader /usr/include/bits/sched.h
    42: noheader /usr/include/bits/select.h
    43: noheader /usr/include/bits/sem.h
    44: noheader /usr/include/bits/setjmp.h
    45: noheader /usr/include/bits/shm.h
    46: //noheader /usr/include/bits/sigset.h
    47: //noheader /usr/include/bits/sigaction.h
    48: //noheader /usr/include/bits/sigcontext.h
    49: //noheader /usr/include/bits/siginfo.h
    50: //noheader /usr/include/bits/sigstack.h
    51: //noheader /usr/include/bits/sigthread.h
    52: noheader /usr/include/bits/sockaddr.h
    53: noheader /usr/include/bits/socket.h
    54: noheader /usr/include/bits/statfs.h
    55: noheader /usr/include/bits/stat.h
    56: noheader /usr/include/bits/statvfs.h
    57: noheader /usr/include/bits/stdio.h
    58: noheader /usr/include/bits/stdio_lim.h
    59: noheader /usr/include/bits/string2.h
    60: noheader /usr/include/bits/string.h
    61: noheader /usr/include/bits/stropts.h
    62: noheader /usr/include/bits/syscall.h
    63: noheader /usr/include/bits/sys_errlist.h
    64: noheader /usr/include/bits/termios.h
    65: noheader /usr/include/bits/time.h
    66: noheader /usr/include/bits/types.h
    67: noheader /usr/include/bits/typesizes.h
    68: noheader /usr/include/bits/uio.h
    69: noheader /usr/include/bits/ustat.h
    70: noheader /usr/include/bits/utmp.h
    71: noheader /usr/include/bits/utmpx.h
    72: noheader /usr/include/bits/utsname.h
    73: noheader /usr/include/bits/waitflags.h
    74: noheader /usr/include/bits/waitstatus.h
    75: noheader /usr/include/bits/xopen_lim.h
    76: noheader /usr/include/bits/xtitypes.h
    77: 
    78: // Some files have aliases created by
    79: // symlinks and others include details
    80: // that should really be treated as if they're
    81: // physically included in the file, rather than
    82: // a separate module -- see above comments on
    83: // the related noheader command
    84: //
    85: // We use merge specification to say that any
    86: // text found in the first file is treated as
    87: // if it were physically part of the second one
    88: 
    89: merge /usr/include/bits/sigset.h /usr/include/signal.h
    90: merge /usr/include/bits/sigaction.h /usr/include/signal.h
    91: merge /usr/include/bits/sigcontext.h /usr/include/signal.h
    92: merge /usr/include/bits/siginfo.h /usr/include/signal.h
    93: merge /usr/include/bits/sigstack.h /usr/include/signal.h
    94: merge /usr/include/bits/sigthread.h /usr/include/pthread.h
    95: merge /usr/include/bits/sched.h /usr/include/sched.h
    96: merge /usr/include/bits/pthreadtypes.h /usr/include/sys/types.h
    97: merge /usr/include/bits/confname.h /usr/include/unistd.h
    98: merge /usr/include/bits/time.h /usr/include/time.h
    99: 
   100: merge /usr/include/bits/byteswap.h /usr/include/byteswap.h
   101: merge /usr/include/bits/cmathcalls.h /usr/include/complex.h
   102: merge /usr/include/bits/dirent.h /usr/include/dirent.h
   103: merge /usr/include/bits/dlfcn.h /usr/include/dlfcn.h
   104: merge /usr/include/bits/elfclass.h /usr/include/link.h
   105: merge /usr/include/bits/endian.h /usr/include/endian.h
   106: merge /usr/include/bits/errno.h /usr/include/errno.h
   107: merge /usr/include/bits/environments.h /usr/include/unistd.h
   108: merge /usr/include/bits/fcntl.h /usr/include/fcntl.h
   109: merge /usr/include/bits/fenv.h /usr/include/fenv.h
   110: merge /usr/include/bits/huge_val.h /usr/include/math.h
   111: merge /usr/include/bits/in.h /usr/include/netinet/in.h
   112: merge /usr/include/bits/ioctls.h /usr/include/sys/ioctl.h
   113: merge /usr/include/bits/ioctl-types.h /usr/include/sys/ioctl.h
   114: merge /usr/include/bits/ipc.h /usr/include/sys/ipc.h
   115: merge /usr/include/bits/ipctypes.h /usr/include/sys/ipc.h
   116: merge /usr/include/bits/locale.h /usr/include/locale.h
   117: merge /usr/include/bits/mathcalls.h /usr/include/math.h
   118: merge /usr/include/bits/mathdef.h /usr/include/math.h
   119: merge /usr/include/bits/mathinline.h /usr/include/math.h
   120: merge /usr/include/bits/mman.h /usr/include/sys/mman.h
   121: merge /usr/include/bits/msq.h /usr/include/sys/msg.h
   122: merge /usr/include/bits/nan.h /usr/include/math.h
   123: merge /usr/include/bits/netdb.h /usr/include/netdb.h
   124: merge /usr/include/bits/poll.h /usr/include/sys/poll.h
   125: merge /usr/include/bits/posix1_lim.h /usr/include/limits.h
   126: merge /usr/include/bits/posix2_lim.h /usr/include/limits.h
   127: merge /usr/include/bits/resource.h /usr/include/sys/resource.h
   128: merge /usr/include/bits/select.h /usr/include/sys/select.h
   129: merge /usr/include/bits/sem.h /usr/include/sys/sem.h
   130: merge /usr/include/bits/setjmp.h /usr/include/setjmp.h
   131: merge /usr/include/bits/shm.h /usr/include/sys/shm.h
   132: merge /usr/include/bits/sockaddr.h /usr/include/sys/socket.h
   133: merge /usr/include/bits/socket.h /usr/include/sys/socket.h
   134: merge /usr/include/bits/statfs.h /usr/include/sys/statfs.h
   135: merge /usr/include/bits/stat.h /usr/include/sys/stat.h
   136: merge /usr/include/bits/statvfs.h /usr/include/sys/statvfs.h
   137: merge /usr/include/bits/stdio.h /usr/include/stdio.h
   138: merge /usr/include/bits/stdio_lim.h /usr/include/stdio.h
   139: merge /usr/include/bits/string2.h /usr/include/string.h
   140: merge /usr/include/bits/string.h /usr/include/string.h
   141: merge /usr/include/bits/stropts.h /usr/include/stropts.h
   142: merge /usr/include/bits/syscall.h /usr/include/sys/syscall.h
   143: merge /usr/include/bits/sys_errlist.h /usr/include/stdio.h
   144: merge /usr/include/bits/termios.h /usr/include/termios.h
   145: merge /usr/include/bits/types.h /usr/include/sys/types.h
   146: merge /usr/include/bits/typesizes.h /usr/include/sys/types.h
   147: merge /usr/include/bits/uio.h /usr/include/sys/uio.h
   148: merge /usr/include/bits/ustat.h /usr/include/sys/ustat.h
   149: merge /usr/include/bits/utmp.h /usr/include/utmp.h
   150: merge /usr/include/bits/utmpx.h /usr/include/utmpx.h
   151: merge /usr/include/bits/utsname.h /usr/include/sys/utsname.h
   152: merge /usr/include/bits/waitflags.h /usr/include/sys/wait.h
   153: merge /usr/include/bits/waitstatus.h /usr/include/sys/wait.h
   154: merge /usr/include/bits/xopen_lim.h /usr/include/limits.h
   155: merge /usr/include/bits/xtitypes.h /usr/include/stropts.h
   156: 
End data section to tmp/gnu_linux_headers.flxcc.default[1]
Start data section to tmp/c89.flxcc.default[1 /1 ]
     1: #include config/felix.flxcc
     2: #include config/gnu_headers.flxcc
     3: #include config/gnu_c_search_path.flxcc
     4: flx_compiler bin/flxg -Ilib
     5: 
     6: outdir c89
     7: prefix /usr/include
     8: prefix /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/include
     9: preprocessor gcc -E -std=c89
    10: language C
    11: 
    12: //-pthread -D_REENTRANT -DNEED_GNOMESUPPORT_H -DGTKHTML_HAVE_GCONF -DORBIT2=1
    13: 
    14: incfile assert.h
    15: incfile ctype.h
    16: incfile errno.h
    17: incfile fenv.h
    18: incfile float.h
    19: //incfile iso646.h: c99 only
    20: incfile limits.h
    21: incfile locale.h
    22: incfile math.h
    23: incfile setjmp.h
    24: incfile signal.h
    25: incfile stdarg.h
    26: incfile stddef.h
    27: incfile stdio.h
    28: incfile stdlib.h
    29: incfile string.h
    30: incfile time.h
    31: incfile wchar.h
    32: incfile wctype.h
    33: 
    34: rename String String_
    35: 
End data section to tmp/c89.flxcc.default[1]
Start data section to tmp/gnu89.flxcc.default[1 /1 ]
     1: #include config/felix.flxcc
     2: #include config/gnu_headers.flxcc
     3: #include config/gnu_c_search_path.flxcc
     4: flx_compiler bin/flxg -Ilib
     5: 
     6: outdir gnu89
     7: prefix /usr/include
     8: prefix /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/include
     9: preprocessor gcc -E -std=gnu89
    10: language C
    11: //-pthread -D_REENTRANT -DNEED_GNOMESUPPORT_H -DGTKHTML_HAVE_GCONF -DORBIT2=1
    12: flx_compiler bin/flxg -Ilib
    13: 
    14: incfile assert.h
    15: incfile ctype.h
    16: incfile errno.h
    17: incfile fenv.h
    18: incfile float.h
    19: //incfile inttypes.h: c99 only
    20: //incfile iso646.h: c99 only
    21: incfile limits.h
    22: incfile locale.h
    23: incfile math.h
    24: incfile setjmp.h
    25: incfile signal.h
    26: incfile stdarg.h
    27: //incfile stdbool.h: c99 only
    28: incfile stddef.h
    29: //incfile stdint.h: c99 only
    30: incfile stdio.h
    31: incfile stdlib.h
    32: incfile string.h
    33: //incfile tgmath.h: c99 only
    34: incfile time.h
    35: incfile wchar.h
    36: incfile wctype.h
    37: 
    38: rename String String_
    39: 
End data section to tmp/gnu89.flxcc.default[1]
Start data section to tmp/c99.flxcc.default[1 /1 ]
     1: #include config/felix.flxcc
     2: #include config/gnu_headers.flxcc
     3: #include config/gnu_c_search_path.flxcc
     4: flx_compiler bin/flxg -Ilib
     5: 
     6: outdir c99
     7: prefix /usr/include
     8: prefix /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/include
     9: preprocessor gcc -E -std=c99
    10: language C
    11: 
    12: incfile assert.h
    13: incfile ctype.h
    14: incfile complex.h
    15: incfile errno.h
    16: incfile fenv.h
    17: incfile float.h
    18: incfile inttypes.h
    19: //incfile iso646.h: just macros
    20: incfile limits.h
    21: incfile locale.h
    22: incfile math.h
    23: incfile setjmp.h
    24: incfile signal.h
    25: incfile stdarg.h
    26: incfile stdbool.h
    27: incfile stddef.h
    28: incfile stdint.h
    29: incfile stdio.h
    30: incfile stdlib.h
    31: incfile string.h
    32: incfile tgmath.h
    33: incfile time.h
    34: incfile wchar.h
    35: incfile wctype.h
    36: 
    37: rename String String_
    38: 
End data section to tmp/c99.flxcc.default[1]
Start data section to tmp/gnu99.flxcc.default[1 /1 ]
     1: #include config/felix.flxcc
     2: #include config/gnu_headers.flxcc
     3: #include config/gnu_c_search_path.flxcc
     4: flx_compiler bin/flxg -Ilib
     5: 
     6: outdir gnu99
     7: prefix /usr/include
     8: prefix /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/include
     9: preprocessor gcc -E -std=gnu99
    10: language C
    11: //-pthread -D_REENTRANT -DNEED_GNOMESUPPORT_H -DGTKHTML_HAVE_GCONF -DORBIT2=1
    12: 
    13: incfile assert.h
    14: incfile ctype.h
    15: incfile complex.h
    16: incfile errno.h
    17: incfile fenv.h
    18: incfile float.h
    19: incfile inttypes.h
    20: //incfile iso646.h: just macros
    21: incfile limits.h
    22: incfile locale.h
    23: incfile math.h
    24: incfile setjmp.h
    25: incfile signal.h
    26: incfile stdarg.h
    27: incfile stdbool.h
    28: incfile stddef.h
    29: incfile stdint.h
    30: incfile stdio.h
    31: incfile stdlib.h
    32: incfile string.h
    33: incfile tgmath.h
    34: incfile time.h
    35: incfile wchar.h
    36: incfile wctype.h
    37: 
    38: rename String String_
    39: 
End data section to tmp/gnu99.flxcc.default[1]
Start data section to tmp/cxx.flxcc.default[1 /1 ]
     1: #include config/felix.flxcc
     2: #include config/gnu_headers.flxcc
     3: #include config/gnu_cxx_search_path.flxcc
     4: flx_compiler bin/flxg -Ilib
     5: 
     6: outdir cxx
     7: prefix /usr/include
     8: prefix /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/include
     9: preprocessor g++ -E -I/usr/include/g++-3
    10: language C++
    11: 
    12: //-pthread -D_REENTRANT -DNEED_GNOMESUPPORT_H -DGTKHTML_HAVE_GCONF -DORBIT2=1
    13: 
    14: incfile cctype
    15: incfile cerrno
    16: //incfile cfenv: cfenv.h is c99, we expect this to come to C++
    17: incfile cfloat
    18: incfile climits
    19: incfile clocale
    20: incfile cmath
    21: incfile csetjmp
    22: incfile csignal
    23: incfile cstdarg
    24: incfile cstddef
    25: //incfile cstdint
    26: incfile cstdio
    27: incfile cstdlib
    28: incfile cstring
    29: incfile ctime
    30: incfile cwchar
    31: incfile cwctype
    32: 
    33: rename String String_
    34: 
End data section to tmp/cxx.flxcc.default[1]
Start data section to tmp/cxx_sys.flxcc.default[1 /1 ]
     1: #include config/felix.flxcc
     2: #include config/gnu_headers.flxcc
     3: #include config/gnu_cxx_search_path.flxcc
     4: flx_compiler bin/flxg -Ilib
     5: 
     6: outdir cxx_sys
     7: prefix /usr/include
     8: prefix /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/include
     9: preprocessor g++ -E -I/usr/include/g++-3
    10: language C++
    11: 
    12: //-pthread -D_REENTRANT -DNEED_GNOMESUPPORT_H -DGTKHTML_HAVE_GCONF -DORBIT2=1
    13: 
    14: incfile cctype
    15: incfile cerrno
    16: //incfile cfenv: cfenv.h is c99, we expect this to come to C++
    17: incfile cfloat
    18: incfile climits
    19: incfile clocale
    20: incfile cmath
    21: incfile csetjmp
    22: incfile csignal
    23: incfile cstdarg
    24: incfile cstddef
    25: //incfile cstdint
    26: incfile cstdio
    27: incfile cstdlib
    28: incfile cstring
    29: incfile ctime
    30: incfile cwchar
    31: incfile cwctype
    32: incdir /usr/include/sys
    33: 
    34: rename String String_
    35: 
End data section to tmp/cxx_sys.flxcc.default[1]
Start data section to tmp/gnucxx.flxcc.default[1 /1 ]
     1: #include config/felix.flxcc
     2: #include config/gnu_headers.flxcc
     3: #include config/gnu_cxx_search_path.flxcc
     4: flx_compiler bin/flxg -Ilib
     5: 
     6: outdir gnucxx
     7: prefix /usr/include
     8: prefix /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/include
     9: preprocessor g++ -E -I/usr/include/g++-3
    10: language C++
    11: 
    12: //-pthread -D_REENTRANT -DNEED_GNOMESUPPORT_H -DGTKHTML_HAVE_GCONF -DORBIT2=1
    13: 
    14: incfile cctype
    15: incfile cerrno
    16: incfile cfloat
    17: incfile climits
    18: incfile clocale
    19: incfile cmath
    20: incfile csetjmp
    21: incfile csignal
    22: incfile cstdarg
    23: incfile cstddef
    24: //incfile cstdint
    25: incfile cstdio
    26: incfile cstdlib
    27: incfile cstring
    28: incfile ctime
    29: incfile cwchar
    30: incfile cwctype
    31: 
    32: rename String String_
    33: 
End data section to tmp/gnucxx.flxcc.default[1]
Start data section to tmp/usr_include.flxcc.default[1 /1 ]
     1: #include config/felix.flxcc
     2: #include config/gnu_headers.flxcc
     3: #include config/gnu_cxx_search_path.flxcc
     4: flx_compiler bin/flxg -Ilib
     5: 
     6: outdir flxcc_out
     7: prefix /usr/include
     8: prefix /usr/local/include
     9: prefix /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/include
    10: prefix /usr/lib/glib/include/ glib
    11: preprocessor g++ -E
    12: language C
    13: 
    14: //-pthread -D_REENTRANT -DNEED_GNOMESUPPORT_H -DGTKHTML_HAVE_GCONF -DORBIT2=1
    15: 
    16: path /usr/include/atk-1.0
    17: path /usr/include/bonobo-activation-2.0
    18: path /usr/include/eel-2
    19: path /usr/include/gail-1.0
    20: path /usr/include/gal-1.0
    21: path /usr/include/gconf/2
    22: path /usr/include/gtk-2.0
    23: path /usr/lib/gtk-2.0/include
    24: path /usr/include/X11
    25: path /usr/include/glib-2.0
    26: path /usr/lib/glib-2.0/include
    27: path /usr/lib/glib/include
    28: path /usr/include/gnome-vfs-2.0
    29: path /usr/lib/gnome-vfs-2.0/include
    30: path /usr/include/gnome-vfs-module-2.0
    31: path /usr/include/gtkhtml-1.1
    32: path /usr/include/gdk-pixbuf-1.0
    33: path /usr/include/gnome-1.0
    34: path /usr/include/freetype2
    35: path /usr/lib/gnome-libs/include
    36: path /usr/include/gnome-xml
    37: path /usr/include/libglade-1.0
    38: path /usr/include/libart-2.0
    39: path /usr/include/libbonobo-2.0
    40: path /usr/include/libbonoboui-2.0
    41: path /usr/include/libglade-2.0
    42: path /usr/include/libgnome-2.0
    43: path /usr/include/libgnomecanvas-2.0
    44: path /usr/include/libgnomeui-2.0
    45: path /usr/include/libgsf-1
    46: path /usr/include/libIDL-2.0
    47: path /usr/include/metacity-1
    48: path /usr/include/panel-2.0
    49: path /usr/include/libpng12
    50: path /usr/include/librsvg-2
    51: path /usr/include/libxml2
    52: path /usr/include/linc-1.0
    53: path /usr/kerberos/include
    54: path /usr/include/orbit-2.0
    55: path /usr/include/orbit-2.0/orbit-idl
    56: path /usr/include/pango-1.0
    57: 
    58: incdir /usr/include
    59: incdir /usr/include/sys
    60: incdir /usr/include/gtk-2.0/gdk
    61: incdir /usr/include/gtk-2.0/gdk-pixbuf
    62: incdir /usr/include/gtkhtml-1.1
    63: recincdir /usr/include/libIDL-2.0
    64: incfile /usr/include/gtk-2.0/gtk/gtk.h
    65: recincdir /usr/local/include/python2.3
    66: 
    67: exclude /usr/include/af_vfs.h
    68: exclude /usr/include/disptmpl.h
    69: exclude /usr/include/bits
    70: exclude /usr/include/asm
    71: exclude /usr/include/linux
    72: exclude /usr/include/glib-1.2
    73: exclude /usr/include/orbit-1.0
    74: exclude /usr/include/c++
    75: exclude /usr/include/g++-3
    76: exclude /usr/include/libglade-1.0
    77: exclude /usr/include/gtk-1.2
    78: exclude /usr/include/glib-2.0/gobject
    79: exclude /usr/include/FlexLexer.h
    80: exclude /usr/include/swig.h
    81: exclude /usr/include/Imlib.h
    82: exclude /usr/include/Imlib_private.h
    83: exclude /usr/include/Imlib_types.h
    84: exclude /usr/include/rle_config.h
    85: exclude /usr/include/md5.h
    86: exclude /usr/include/pcap-namedb.h
    87: exclude /usr/include/regexp.h
    88: exclude /usr/include/hmac-md5.h
    89: exclude /usr/include/jmorecfg.h
    90: exclude /usr/include/jconfig.h
    91: exclude /usr/local/include/python2.3/pymactoolbox.h
    92: exclude /usr/include/libmng.h
    93: exclude /usr/include/mp.h
    94: exclude /usr/include/pammap.h
    95: 
    96: rename String String_
    97: 
    98: rename_nontype _ns_flagdata _ns_flagdata_
    99: rename_nontype usb_device usb_device_
   100: rename_nontype tcpd_context tcpd_context_
   101: 
   102: merge /usr/X11R6/include/X11 /usr/include/X11
   103: 
   104: 
End data section to tmp/usr_include.flxcc.default[1]