From 93d89c2b5e8497365be152fb53cb6cd4c5764d34 Mon Sep 17 00:00:00 2001 From: xleroy Date: Wed, 3 Mar 2010 10:25:25 +0000 Subject: Getting rid of CIL git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@1270 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e --- cil/src/frontc/cabs.ml | 396 --- cil/src/frontc/cabs2cil.ml | 6238 ------------------------------------------ cil/src/frontc/cabs2cil.mli | 49 - cil/src/frontc/cabsvisit.ml | 577 ---- cil/src/frontc/cabsvisit.mli | 115 - cil/src/frontc/clexer.mli | 55 - cil/src/frontc/clexer.mll | 666 ----- cil/src/frontc/cparser.mly | 1521 ---------- cil/src/frontc/cprint.ml | 1014 ------- cil/src/frontc/frontc.ml | 256 -- cil/src/frontc/frontc.mli | 55 - cil/src/frontc/lexerhack.ml | 22 - cil/src/frontc/patch.ml | 837 ------ cil/src/frontc/patch.mli | 42 - 14 files changed, 11843 deletions(-) delete mode 100644 cil/src/frontc/cabs.ml delete mode 100644 cil/src/frontc/cabs2cil.ml delete mode 100644 cil/src/frontc/cabs2cil.mli delete mode 100644 cil/src/frontc/cabsvisit.ml delete mode 100644 cil/src/frontc/cabsvisit.mli delete mode 100644 cil/src/frontc/clexer.mli delete mode 100644 cil/src/frontc/clexer.mll delete mode 100644 cil/src/frontc/cparser.mly delete mode 100644 cil/src/frontc/cprint.ml delete mode 100644 cil/src/frontc/frontc.ml delete mode 100644 cil/src/frontc/frontc.mli delete mode 100755 cil/src/frontc/lexerhack.ml delete mode 100644 cil/src/frontc/patch.ml delete mode 100644 cil/src/frontc/patch.mli (limited to 'cil/src/frontc') diff --git a/cil/src/frontc/cabs.ml b/cil/src/frontc/cabs.ml deleted file mode 100644 index 78ac02f4..00000000 --- a/cil/src/frontc/cabs.ml +++ /dev/null @@ -1,396 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(** This file was originally part of Hugues Casee's frontc 2.0, and has been - * extensively changed since. -** -** 1.0 3.22.99 Hugues Cassé First version. -** 2.0 George Necula 12/12/00: Many extensions - **) - -(* -** Types -*) - -type cabsloc = { - lineno : int; - filename: string; - byteno: int; -} - -let cabslu = {lineno = -10; - filename = "cabs loc unknown"; - byteno = -10;} - -(* clexer puts comments here *) -let commentsGA = GrowArray.make 100 (GrowArray.Elem(cabslu,"",false)) - -type typeSpecifier = (* Merge all specifiers into one type *) - Tvoid (* Type specifier ISO 6.7.2 *) - | Tchar - | Tshort - | Tint - | Tlong - | Tint64 - | Tfloat - | Tdouble - | Tsigned - | Tunsigned - | Tnamed of string - (* each of the following three kinds of specifiers contains a field - * or item list iff it corresponds to a definition (as opposed to - * a forward declaration or simple reference to the type); they - * also have a list of __attribute__s that appeared between the - * keyword and the type name (definitions only) *) - | Tstruct of string * field_group list option * attribute list - | Tunion of string * field_group list option * attribute list - | Tenum of string * enum_item list option * attribute list - | TtypeofE of expression (* GCC __typeof__ *) - | TtypeofT of specifier * decl_type (* GCC __typeof__ *) - -and storage = - NO_STORAGE | AUTO | STATIC | EXTERN | REGISTER - -and funspec = - INLINE | VIRTUAL | EXPLICIT - -and cvspec = - CV_CONST | CV_VOLATILE | CV_RESTRICT - -(* Type specifier elements. These appear at the start of a declaration *) -(* Everywhere they appear in this file, they appear as a 'spec_elem list', *) -(* which is not interpreted by cabs -- rather, this "word soup" is passed *) -(* on to the compiler. Thus, we can represent e.g. 'int long float x' even *) -(* though the compiler will of course choke. *) -and spec_elem = - SpecTypedef - | SpecCV of cvspec (* const/volatile *) - | SpecAttr of attribute (* __attribute__ *) - | SpecStorage of storage - | SpecInline - | SpecType of typeSpecifier - | SpecPattern of string (* specifier pattern variable *) - -(* decided to go ahead and replace 'spec_elem list' with specifier *) -and specifier = spec_elem list - - -(* Declarator type. They modify the base type given in the specifier. Keep - * them in the order as they are printed (this means that the top level - * constructor for ARRAY and PTR is the inner-level in the meaning of the - * declared type) *) -and decl_type = - | JUSTBASE (* Prints the declared name *) - | PARENTYPE of attribute list * decl_type * attribute list - (* Prints "(attrs1 decl attrs2)". - * attrs2 are attributes of the - * declared identifier and it is as - * if they appeared at the very end - * of the declarator. attrs1 can - * contain attributes for the - * identifier or attributes for the - * enclosing type. *) - | ARRAY of decl_type * attribute list * expression - (* Prints "decl [ attrs exp ]". - * decl is never a PTR. *) - | PTR of attribute list * decl_type (* Prints "* attrs decl" *) - | PROTO of decl_type * single_name list * bool - (* Prints "decl (args[, ...])". - * decl is never a PTR.*) - -(* The base type and the storage are common to all names. Each name might - * contain type or storage modifiers *) -(* e.g.: int x, y; *) -and name_group = specifier * name list - -(* The optional expression is the bitfield *) -and field_group = specifier * (name * expression option) list - -(* like name_group, except the declared variables are allowed to have initializers *) -(* e.g.: int x=1, y=2; *) -and init_name_group = specifier * init_name list - -(* The decl_type is in the order in which they are printed. Only the name of - * the declared identifier is pulled out. The attributes are those that are - * printed after the declarator *) -(* e.g: in "int *x", "*x" is the declarator; "x" will be pulled out as *) -(* the string, and decl_type will be PTR([], JUSTBASE) *) -and name = string * decl_type * attribute list * cabsloc - -(* A variable declarator ("name") with an initializer *) -and init_name = name * init_expression - -(* Single names are for declarations that cannot come in groups, like - * function parameters and functions *) -and single_name = specifier * name - - -and enum_item = string * expression * cabsloc - -(* -** Declaration definition (at toplevel) -*) -and definition = - FUNDEF of single_name * block * cabsloc * cabsloc - | DECDEF of init_name_group * cabsloc (* global variable(s), or function prototype *) - | TYPEDEF of name_group * cabsloc - | ONLYTYPEDEF of specifier * cabsloc - | GLOBASM of string * cabsloc - | PRAGMA of expression * cabsloc - | LINKAGE of string * cabsloc * definition list (* extern "C" { ... } *) - (* toplevel form transformer, from the first definition to the *) - (* second group of definitions *) - | TRANSFORMER of definition * definition list * cabsloc - (* expression transformer: source and destination *) - | EXPRTRANSFORMER of expression * expression * cabsloc - - -(* the string is a file name, and then the list of toplevel forms *) -and file = string * definition list - - -(* -** statements -*) - -(* A block contains a list of local label declarations ( GCC's ({ __label__ - * l1, l2; ... }) ) , a list of definitions and a list of statements *) -and block = - { blabels: string list; - battrs: attribute list; - bstmts: statement list - } - -(* GCC asm directives have lots of extra information to guide the optimizer *) -and asm_details = - { aoutputs: (string * expression) list; (* constraints and expressions for outputs *) - ainputs: (string * expression) list; (* constraints and expressions for inputs *) - aclobbers: string list (* clobbered registers *) - } - -and statement = - NOP of cabsloc - | COMPUTATION of expression * cabsloc - | BLOCK of block * cabsloc - | SEQUENCE of statement * statement * cabsloc - | IF of expression * statement * statement * cabsloc - | WHILE of expression * statement * cabsloc - | DOWHILE of expression * statement * cabsloc - | FOR of for_clause * expression * expression * statement * cabsloc - | BREAK of cabsloc - | CONTINUE of cabsloc - | RETURN of expression * cabsloc - | SWITCH of expression * statement * cabsloc - | CASE of expression * statement * cabsloc - | CASERANGE of expression * expression * statement * cabsloc - | DEFAULT of statement * cabsloc - | LABEL of string * statement * cabsloc - | GOTO of string * cabsloc - | COMPGOTO of expression * cabsloc (* GCC's "goto *exp" *) - | DEFINITION of definition (*definition or declaration of a variable or type*) - - | ASM of attribute list * (* typically only volatile and const *) - string list * (* template *) - asm_details option * (* extra details to guide GCC's optimizer *) - cabsloc - - (** MS SEH *) - | TRY_EXCEPT of block * expression * block * cabsloc - | TRY_FINALLY of block * block * cabsloc - -and for_clause = - FC_EXP of expression - | FC_DECL of definition - -(* -** Expressions -*) -and binary_operator = - ADD | SUB | MUL | DIV | MOD - | AND | OR - | BAND | BOR | XOR | SHL | SHR - | EQ | NE | LT | GT | LE | GE - | ASSIGN - | ADD_ASSIGN | SUB_ASSIGN | MUL_ASSIGN | DIV_ASSIGN | MOD_ASSIGN - | BAND_ASSIGN | BOR_ASSIGN | XOR_ASSIGN | SHL_ASSIGN | SHR_ASSIGN - -and unary_operator = - MINUS | PLUS | NOT | BNOT | MEMOF | ADDROF - | PREINCR | PREDECR | POSINCR | POSDECR - -and expression = - NOTHING - | UNARY of unary_operator * expression - | LABELADDR of string (* GCC's && Label *) - | BINARY of binary_operator * expression * expression - | QUESTION of expression * expression * expression - - (* A CAST can actually be a constructor expression *) - | CAST of (specifier * decl_type) * init_expression - - (* There is a special form of CALL in which the function called is - __builtin_va_arg and the second argument is sizeof(T). This - should be printed as just T *) - | CALL of expression * expression list - | COMMA of expression list - | CONSTANT of constant - | VARIABLE of string - | EXPR_SIZEOF of expression - | TYPE_SIZEOF of specifier * decl_type - | EXPR_ALIGNOF of expression - | TYPE_ALIGNOF of specifier * decl_type - | INDEX of expression * expression - | MEMBEROF of expression * string - | MEMBEROFPTR of expression * string - | GNU_BODY of block - | EXPR_PATTERN of string (* pattern variable, and name *) - -and constant = - | CONST_INT of string (* the textual representation *) - | CONST_FLOAT of string (* the textual representaton *) - | CONST_CHAR of int64 list - | CONST_WCHAR of int64 list - | CONST_STRING of string - | CONST_WSTRING of int64 list - (* ww: wstrings are stored as an int64 list at this point because - * we might need to feed the wide characters piece-wise into an - * array initializer (e.g., wchar_t foo[] = L"E\xabcd";). If that - * doesn't happen we will convert it to an (escaped) string before - * passing it to Cil. *) - -and init_expression = - | NO_INIT - | SINGLE_INIT of expression - | COMPOUND_INIT of (initwhat * init_expression) list - -and initwhat = - NEXT_INIT - | INFIELD_INIT of string * initwhat - | ATINDEX_INIT of expression * initwhat - | ATINDEXRANGE_INIT of expression * expression - - - (* Each attribute has a name and some - * optional arguments *) -and attribute = string * expression list - - -(*********** HELPER FUNCTIONS **********) - -let missingFieldDecl = ("___missing_field_name", JUSTBASE, [], cabslu) - -let rec isStatic = function - [] -> false - | (SpecStorage STATIC) :: _ -> true - | _ :: rest -> isStatic rest - -let rec isExtern = function - [] -> false - | (SpecStorage EXTERN) :: _ -> true - | _ :: rest -> isExtern rest - -let rec isInline = function - [] -> false - | SpecInline :: _ -> true - | _ :: rest -> isInline rest - -let rec isTypedef = function - [] -> false - | SpecTypedef :: _ -> true - | _ :: rest -> isTypedef rest - - -let get_definitionloc (d : definition) : cabsloc = - match d with - | FUNDEF(_, _, l, _) -> l - | DECDEF(_, l) -> l - | TYPEDEF(_, l) -> l - | ONLYTYPEDEF(_, l) -> l - | GLOBASM(_, l) -> l - | PRAGMA(_, l) -> l - | TRANSFORMER(_, _, l) -> l - | EXPRTRANSFORMER(_, _, l) -> l - | LINKAGE (_, l, _) -> l - -let get_statementloc (s : statement) : cabsloc = -begin - match s with - | NOP(loc) -> loc - | COMPUTATION(_,loc) -> loc - | BLOCK(_,loc) -> loc - | SEQUENCE(_,_,loc) -> loc - | IF(_,_,_,loc) -> loc - | WHILE(_,_,loc) -> loc - | DOWHILE(_,_,loc) -> loc - | FOR(_,_,_,_,loc) -> loc - | BREAK(loc) -> loc - | CONTINUE(loc) -> loc - | RETURN(_,loc) -> loc - | SWITCH(_,_,loc) -> loc - | CASE(_,_,loc) -> loc - | CASERANGE(_,_,_,loc) -> loc - | DEFAULT(_,loc) -> loc - | LABEL(_,_,loc) -> loc - | GOTO(_,loc) -> loc - | COMPGOTO (_, loc) -> loc - | DEFINITION d -> get_definitionloc d - | ASM(_,_,_,loc) -> loc - | TRY_EXCEPT(_, _, _, loc) -> loc - | TRY_FINALLY(_, _, loc) -> loc -end - - -let explodeStringToInts (s: string) : int64 list = - let rec allChars i acc = - if i < 0 then acc - else allChars (i - 1) (Int64.of_int (Char.code (String.get s i)) :: acc) - in - allChars (-1 + String.length s) [] - -let valueOfDigit chr = - let int_value = - match chr with - '0'..'9' -> (Char.code chr) - (Char.code '0') - | 'a'..'z' -> (Char.code chr) - (Char.code 'a') + 10 - | 'A'..'Z' -> (Char.code chr) - (Char.code 'A') + 10 - | _ -> Errormsg.s (Errormsg.bug "not a digit") in - Int64.of_int int_value - - -open Pretty -let d_cabsloc () cl = - text cl.filename ++ text ":" ++ num cl.lineno diff --git a/cil/src/frontc/cabs2cil.ml b/cil/src/frontc/cabs2cil.ml deleted file mode 100644 index 31b65b5b..00000000 --- a/cil/src/frontc/cabs2cil.ml +++ /dev/null @@ -1,6238 +0,0 @@ -(* MODIF: allow E.Error to propagate *) - -(* MODIF: for pointer comparison, avoid systematic cast to unsigned int *) - -(* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) -(* MODIF: Return statement no longer added when the body of the function - falls-through. *) - -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(* Type check and elaborate ABS to CIL *) - -(* The references to ISO means ANSI/ISO 9899-1999 *) -module A = Cabs -module E = Errormsg -module H = Hashtbl -module IH = Inthash -module AL = Alpha - -open Cabs -open Pretty -open Cil -open Trace - - -let mydebugfunction () = - E.s (error "mydebugfunction") - -let debugGlobal = false - -(** NDC added command line parameter **) -(* Turn on tranformation that forces correct parameter evaluation order *) -let forceRLArgEval = ref false - -(* Leave a certain global alone. Use a negative number to disable. *) -let nocil: int ref = ref (-1) - -(* Indicates whether we're allowed to duplicate small chunks. *) -let allowDuplication: bool ref = ref true - -(* ---------- source error message handling ------------- *) -let lu = locUnknown -let cabslu = {lineno = -10; - filename = "cabs lu"; - byteno = -10;} - - -(** Interface to the Cprint printer *) -let withCprint (f: 'a -> unit) (x: 'a) : unit = - Cprint.commit (); Cprint.flush (); - let old = !Cprint.out in - Cprint.out := !E.logChannel; - f x; - Cprint.commit (); Cprint.flush (); - flush !Cprint.out; - Cprint.out := old - - -(** Keep a list of the variable ID for the variables that were created to - * hold the result of function calls *) -let callTempVars: unit IH.t = IH.create 13 - -(* Keep a list of functions that were called without a prototype. *) -let noProtoFunctions : bool IH.t = IH.create 13 - -(* Check that s starts with the prefix p *) -let prefix p s = - let lp = String.length p in - let ls = String.length s in - lp <= ls && String.sub s 0 lp = p - -(***** COMPUTED GOTO ************) - -(* The address of labels are small integers (starting from 0). A computed - * goto is replaced with a switch on the address of the label. We generate - * only one such switch and we'll jump to it from all computed gotos. To - * accomplish this we'll add a local variable to store the target of the - * goto. *) - -(* The local variable in which to put the detination of the goto and the - * statement where to jump *) -let gotoTargetData: (varinfo * stmt) option ref = ref None - -(* The "addresses" of labels *) -let gotoTargetHash: (string, int) H.t = H.create 13 -let gotoTargetNextAddr: int ref = ref 0 - - -(********** TRANSPARENT UNION ******) -(* Check if a type is a transparent union, and return the first field if it - * is *) -let isTransparentUnion (t: typ) : fieldinfo option = - match unrollType t with - TComp (comp, _) when not comp.cstruct -> - (* Turn transparent unions into the type of their first field *) - if hasAttribute "transparent_union" (typeAttrs t) then begin - match comp.cfields with - f :: _ -> Some f - | _ -> E.s (unimp "Empty transparent union: %s" (compFullName comp)) - end else - None - | _ -> None - -(* When we process an argument list, remember the argument index which has a - * transparent union type, along with the original type. We need this to - * process function definitions *) -let transparentUnionArgs : (int * typ) list ref = ref [] - -let debugLoc = false -let convLoc (l : cabsloc) = - if debugLoc then - ignore (E.log "convLoc at %s: line %d, btye %d\n" l.filename l.lineno l.byteno); - {line = l.lineno; file = l.filename; byte = l.byteno;} - - -let isOldStyleVarArgName n = - if !msvcMode then n = "va_alist" - else n = "__builtin_va_alist" - -let isOldStyleVarArgTypeName n = - if !msvcMode then n = "va_list" || n = "__ccured_va_list" - else n = "__builtin_va_alist_t" - -(* Weimer - * multi-character character constants - * In MSCV, this code works: - * - * long l1 = 'abcd'; // note single quotes - * char * s = "dcba"; - * long * lptr = ( long * )s; - * long l2 = *lptr; - * assert(l1 == l2); - * - * We need to change a multi-character character literal into the - * appropriate integer constant. However, the plot sickens: we - * must also be able to handle things like 'ab\nd' (value = * "d\nba") - * and 'abc' (vale = *"cba"). - * - * First we convert 'AB\nD' into the list [ 65 ; 66 ; 10 ; 68 ], then we - * multiply and add to get the desired value. - *) - -(* Given a character constant (like 'a' or 'abc') as a list of 64-bit - * values, turn it into a CIL constant. Multi-character constants are - * treated as multi-digit numbers with radix given by the bit width of - * the specified type (either char or wchar_t). *) -let reduce_multichar typ : int64 list -> int64 = - let radix = bitsSizeOf typ in - List.fold_left - (fun acc -> Int64.add (Int64.shift_left acc radix)) - Int64.zero - -let interpret_character_constant char_list = - let value = reduce_multichar charType char_list in - if value < (Int64.of_int 256) then - (* ISO C 6.4.4.4.10: single-character constants have type int *) - (CChr(Char.chr (Int64.to_int value))), intType - else begin - let orig_rep = None (* Some("'" ^ (String.escaped str) ^ "'") *) in - if value <= (Int64.of_int32 Int32.max_int) then - (CInt64(value,IULong,orig_rep)),(TInt(IULong,[])) - else - (CInt64(value,IULongLong,orig_rep)),(TInt(IULongLong,[])) - end - -(*** EXPRESSIONS *************) - - (* We collect here the program *) -let theFile : global list ref = ref [] -let theFileTypes : global list ref = ref [] - -let initGlobals () = theFile := []; theFileTypes := [] - - -let cabsPushGlobal (g: global) = - pushGlobal g ~types:theFileTypes ~variables:theFile - -(* Keep track of some variable ids that must be turned into definitions. We - * do this when we encounter what appears a definition of a global but - * without initializer. We leave it a declaration because maybe down the road - * we see another definition with an initializer. But if we don't see any - * then we turn the last such declaration into a definition without - * initializer *) -let mustTurnIntoDef: bool IH.t = IH.create 117 - -(* Globals that have already been defined. Indexed by the variable name. *) -let alreadyDefined: (string, location) H.t = H.create 117 - -(* Globals that were created due to static local variables. We chose their - * names to be distinct from any global encountered at the time. But we might - * see a global with conflicting name later in the file. *) -let staticLocals: (string, varinfo) H.t = H.create 13 - - -(* Typedefs. We chose their names to be distinct from any global encounterd - * at the time. But we might see a global with conflicting name later in the - * file *) -let typedefs: (string, typeinfo) H.t = H.create 13 - -let popGlobals () = - let rec revonto (tail: global list) = function - [] -> tail - - | GVarDecl (vi, l) :: rest - when vi.vstorage != Extern && IH.mem mustTurnIntoDef vi.vid -> - IH.remove mustTurnIntoDef vi.vid; - revonto (GVar (vi, {init = None}, l) :: tail) rest - - | x :: rest -> revonto (x :: tail) rest - in - revonto (revonto [] !theFile) !theFileTypes - - -(********* ENVIRONMENTS ***************) - -(* The environment is kept in two distinct data structures. A hash table maps - * each original variable name into a varinfo (for variables, or an - * enumeration tag, or a type). (Note that the varinfo might contain an - * alpha-converted name different from that of the lookup name.) The Ocaml - * hash tables can keep multiple mappings for a single key. Each time the - * last mapping is returned and upon deletion the old mapping is restored. To - * keep track of local scopes we also maintain a list of scopes (represented - * as lists). *) -type envdata = - EnvVar of varinfo (* The name refers to a variable - * (which could also be a function) *) - | EnvEnum of exp * typ (* The name refers to an enumeration - * tag for which we know the value - * and the host type *) - | EnvTyp of typ (* The name is of the form "struct - * foo", or "union foo" or "enum foo" - * and refers to a type. Note that - * the name of the actual type might - * be different from foo due to alpha - * conversion *) - | EnvLabel of string (* The name refers to a label. This - * is useful for GCC's locally - * declared labels. The lookup name - * for this category is "label foo" *) - -let env : (string, envdata * location) H.t = H.create 307 -(* We also keep a global environment. This is always a subset of the env *) -let genv : (string, envdata * location) H.t = H.create 307 - - (* In the scope we keep the original name, so we can remove them from the - * hash table easily *) -type undoScope = - UndoRemoveFromEnv of string - | UndoResetAlphaCounter of location AL.alphaTableData ref * - location AL.alphaTableData - | UndoRemoveFromAlphaTable of string - -let scopes : undoScope list ref list ref = ref [] - -let isAtTopLevel () = - !scopes = [] - - -(* When you add to env, you also add it to the current scope *) -let addLocalToEnv (n: string) (d: envdata) = -(* ignore (E.log "%a: adding local %s to env\n" d_loc !currentLoc n); *) - H.add env n (d, !currentLoc); - (* If we are in a scope, then it means we are not at top level. Add the - * name to the scope *) - (match !scopes with - [] -> begin - match d with - EnvVar _ -> - E.s (E.bug "addLocalToEnv: not in a scope when adding %s!" n) - | _ -> () (* We might add types *) - end - | s :: _ -> - s := (UndoRemoveFromEnv n) :: !s) - - -let addGlobalToEnv (k: string) (d: envdata) : unit = -(* ignore (E.log "%a: adding global %s to env\n" d_loc !currentLoc k); *) - H.add env k (d, !currentLoc); - (* Also add it to the global environment *) - H.add genv k (d, !currentLoc) - - - -(* Create a new name based on a given name. The new name is formed from a - * prefix (obtained from the given name as the longest prefix that ends with - * a non-digit), followed by a '_' and then by a positive integer suffix. The - * first argument is a table mapping name prefixes with the largest suffix - * used so far for that prefix. The largest suffix is one when only the - * version without suffix has been used. *) -let alphaTable : (string, location AL.alphaTableData ref) H.t = H.create 307 - (* vars and enum tags. For composite types we have names like "struct - * foo" or "union bar" *) - -(* To keep different name scopes different, we add prefixes to names - * specifying the kind of name: the kind can be one of "" for variables or - * enum tags, "struct" for structures and unions (they share the name space), - * "enum" for enumerations, or "type" for types *) -let kindPlusName (kind: string) - (origname: string) : string = - if kind = "" then origname else - kind ^ " " ^ origname - - -let stripKind (kind: string) (kindplusname: string) : string = - let l = 1 + String.length kind in - if l > 1 then - String.sub kindplusname l (String.length kindplusname - l) - else - kindplusname - -let newAlphaName (globalscope: bool) (* The name should have global scope *) - (kind: string) - (origname: string) : string * location = - let lookupname = kindPlusName kind origname in - (* If we are in a scope then it means that we are alpha-converting a local - * name. Go and add stuff to reset the state of the alpha table but only to - * the top-most scope (that of the enclosing function) *) - let rec findEnclosingFun = function - [] -> (* At global scope *)() - | [s] -> begin - let prefix = AL.getAlphaPrefix lookupname in - try - let countref = H.find alphaTable prefix in - s := (UndoResetAlphaCounter (countref, !countref)) :: !s - with Not_found -> - s := (UndoRemoveFromAlphaTable prefix) :: !s - end - | _ :: rest -> findEnclosingFun rest - in - if not globalscope then - findEnclosingFun !scopes; - let newname, oldloc = - AL.newAlphaName alphaTable None lookupname !currentLoc in - stripKind kind newname, oldloc - - - - -let explodeString (nullterm: bool) (s: string) : char list = - let rec allChars i acc = - if i < 0 then acc - else allChars (i - 1) ((String.get s i) :: acc) - in - allChars (-1 + String.length s) - (if nullterm then [Char.chr 0] else []) - -(*** In order to process GNU_BODY expressions we must record that a given - *** COMPUTATION is interesting *) -let gnu_body_result : (A.statement * ((exp * typ) option ref)) ref - = ref (A.NOP cabslu, ref None) - -(*** When we do statements we need to know the current return type *) -let currentReturnType : typ ref = ref (TVoid([])) -let currentFunctionFDEC: fundec ref = ref dummyFunDec - - -let lastStructId = ref 0 -let anonStructName (k: string) (suggested: string) = - incr lastStructId; - "__anon" ^ k ^ (if suggested <> "" then "_" ^ suggested else "") - ^ "_" ^ (string_of_int (!lastStructId)) - - -let constrExprId = ref 0 - - -let startFile () = - H.clear env; - H.clear genv; - H.clear alphaTable; - lastStructId := 0 - - - -let enterScope () = - scopes := (ref []) :: !scopes - - (* Exit a scope and clean the environment. We do not yet delete from - * the name table *) -let exitScope () = - let this, rest = - match !scopes with - car :: cdr -> car, cdr - | [] -> E.s (error "Not in a scope") - in - scopes := rest; - let rec loop = function - [] -> () - | UndoRemoveFromEnv n :: t -> - H.remove env n; loop t - | UndoRemoveFromAlphaTable n :: t -> H.remove alphaTable n; loop t - | UndoResetAlphaCounter (vref, oldv) :: t -> - vref := oldv; - loop t - in - loop !this - -(* Lookup a variable name. Return also the location of the definition. Might - * raise Not_found *) -let lookupVar (n: string) : varinfo * location = - match H.find env n with - (EnvVar vi), loc -> vi, loc - | _ -> raise Not_found - -let lookupGlobalVar (n: string) : varinfo * location = - match H.find genv n with - (EnvVar vi), loc -> vi, loc - | _ -> raise Not_found - -let docEnv () = - let acc : (string * (envdata * location)) list ref = ref [] in - let doone () = function - EnvVar vi, l -> - dprintf "Var(%s,global=%b) (at %a)" vi.vname vi.vglob d_loc l - | EnvEnum (tag, typ), l -> dprintf "Enum (at %a)" d_loc l - | EnvTyp t, l -> text "typ" - | EnvLabel l, _ -> text ("label " ^ l) - in - H.iter (fun k d -> acc := (k, d) :: !acc) env; - docList ~sep:line (fun (k, d) -> dprintf " %s -> %a" k doone d) () !acc - - - -(* Add a new variable. Do alpha-conversion if necessary *) -let alphaConvertVarAndAddToEnv (addtoenv: bool) (vi: varinfo) : varinfo = -(* - ignore (E.log "%t: alphaConvert(addtoenv=%b) %s" d_thisloc addtoenv vi.vname); -*) - (* Announce the name to the alpha conversion table *) - let newname, oldloc = newAlphaName (addtoenv && vi.vglob) "" vi.vname in - (* Make a copy of the vi if the name has changed. Never change the name for - * global variables *) - let newvi = - if vi.vname = newname then - vi - else begin - if vi.vglob then begin - (* Perhaps this is because we have seen a static local which happened - * to get the name that we later want to use for a global. *) - try - let static_local_vi = H.find staticLocals vi.vname in - H.remove staticLocals vi.vname; - (* Use the new name for the static local *) - static_local_vi.vname <- newname; - (* And continue using the last one *) - vi - with Not_found -> begin - (* Or perhaps we have seen a typedef which stole our name. This is - possible because typedefs use the same name space *) - try - let typedef_ti = H.find typedefs vi.vname in - H.remove typedefs vi.vname; - (* Use the new name for the typedef instead *) - typedef_ti.tname <- newname; - (* And continue using the last name *) - vi - with Not_found -> - E.s (E.error "It seems that we would need to rename global %s (to %s) because of previous occurrence at %a" - vi.vname newname d_loc oldloc); - end - end else begin - (* We have changed the name of a local variable. Can we try to detect - * if the other variable was also local in the same scope? Not for - * now. *) - copyVarinfo vi newname - end - end - in - (* Store all locals in the slocals (in reversed order). We'll reverse them - * and take out the formals at the end of the function *) - if not vi.vglob then - !currentFunctionFDEC.slocals <- newvi :: !currentFunctionFDEC.slocals; - - (if addtoenv then - if vi.vglob then - addGlobalToEnv vi.vname (EnvVar newvi) - else - addLocalToEnv vi.vname (EnvVar newvi)); -(* - ignore (E.log " new=%s\n" newvi.vname); -*) -(* ignore (E.log "After adding %s alpha table is: %a\n" - newvi.vname docAlphaTable alphaTable); *) - newvi - - -(* Strip the "const" from the type. It is unfortunate that const variables - * can only be set in initialization. Once we decided to move all - * declarations to the top of the functions, we have no way of setting a - * "const" variable. Furthermore, if the type of the variable is an array or - * a struct we must recursively strip the "const" from fields and array - * elements. *) -let rec stripConstLocalType (t: typ) : typ = - let dc a = - if hasAttribute "const" a then - dropAttribute "const" a - else a - in - match t with - | TPtr (bt, a) -> - (* We want to be able to detect by pointer equality if the type has - * changed. So, don't realloc the type unless necessary. *) - let a' = dc a in if a != a' then TPtr(bt, a') else t - | TInt (ik, a) -> - let a' = dc a in if a != a' then TInt(ik, a') else t - | TFloat(fk, a) -> - let a' = dc a in if a != a' then TFloat(fk, a') else t - | TNamed (ti, a) -> - (* We must go and drop the consts from the typeinfo as well ! *) - let t' = stripConstLocalType ti.ttype in - if t != t' then begin - (* ignore (warn "Stripping \"const\" from typedef %s\n" ti.tname); *) - ti.ttype <- t' - end; - let a' = dc a in if a != a' then TNamed(ti, a') else t - - | TEnum (ei, a) -> - let a' = dc a in if a != a' then TEnum(ei, a') else t - - | TArray(bt, leno, a) -> - (* We never assign to the array. So, no need to change the const. But - * we must change it on the base type *) - let bt' = stripConstLocalType bt in - if bt' != bt then TArray(bt', leno, a) else t - - | TComp(ci, a) -> - (* Must change both this structure as well as its fields *) - List.iter - (fun f -> - let t' = stripConstLocalType f.ftype in - if t' != f.ftype then begin - ignore (warnOpt "Stripping \"const\" from field %s of %s\n" - f.fname (compFullName ci)); - f.ftype <- t' - end) - ci.cfields; - let a' = dc a in if a != a' then TComp(ci, a') else t - - (* We never assign functions either *) - | TFun(rt, args, va, a) -> t - | TVoid _ -> E.s (bug "cabs2cil: stripConstLocalType: void") - | TBuiltin_va_list a -> - let a' = dc a in if a != a' then TBuiltin_va_list a' else t - - -let constFoldTypeVisitor = object (self) - inherit nopCilVisitor - method vtype t: typ visitAction = - match t with - TArray(bt, Some len, a) -> - let len' = constFold true len in - ChangeDoChildrenPost ( - TArray(bt, Some len', a), - (fun x -> x) - ) - | _ -> DoChildren -end - -(* Const-fold any expressions that appear as array lengths in this type *) -let constFoldType (t:typ) : typ = - visitCilType constFoldTypeVisitor t - - - -(* Create a new temporary variable *) -let newTempVar typ = - if !currentFunctionFDEC == dummyFunDec then - E.s (bug "newTempVar called outside a function"); -(* ignore (E.log "stripConstLocalType(%a) for temporary\n" d_type typ); *) - let t' = stripConstLocalType typ in - (* Start with the name "tmp". The alpha converter will fix it *) - let vi = makeVarinfo false "tmp" t' in - alphaConvertVarAndAddToEnv false vi (* Do not add to the environment *) -(* - { vname = "tmp"; (* addNewVar will make the name fresh *) - vid = newVarId "tmp" false; - vglob = false; - vtype = t'; - vdecl = locUnknown; - vinline = false; - vattr = []; - vaddrof = false; - vreferenced = false; (* sm *) - vstorage = NoStorage; - } -*) - -let mkAddrOfAndMark ((b, off) as lval) : exp = - (* Mark the vaddrof flag if b is a variable *) - (match b with - Var vi -> vi.vaddrof <- true - | _ -> ()); - mkAddrOf lval - -(* Call only on arrays *) -let mkStartOfAndMark ((b, off) as lval) : exp = - (* Mark the vaddrof flag if b is a variable *) - (match b with - Var vi -> vi.vaddrof <- true - | _ -> ()); - let res = StartOf lval in - res - - - - (* Keep a set of self compinfo for composite types *) -let compInfoNameEnv : (string, compinfo) H.t = H.create 113 -let enumInfoNameEnv : (string, enuminfo) H.t = H.create 113 - - -let lookupTypeNoError (kind: string) - (n: string) : typ * location = - let kn = kindPlusName kind n in - match H.find env kn with - EnvTyp t, l -> t, l - | _ -> raise Not_found - -let lookupType (kind: string) - (n: string) : typ * location = - try - lookupTypeNoError kind n - with Not_found -> - E.s (error "Cannot find type %s (kind:%s)\n" n kind) - -(* Create the self ref cell and add it to the map. Return also an indication - * if this is a new one. *) -let createCompInfo (iss: bool) (n: string) : compinfo * bool = - (* Add to the self cell set *) - let key = (if iss then "struct " else "union ") ^ n in - try - H.find compInfoNameEnv key, false (* Only if not already in *) - with Not_found -> begin - (* Create a compinfo. This will have "cdefined" false. *) - let res = mkCompInfo iss n (fun _ -> []) [] in - H.add compInfoNameEnv key res; - res, true - end - -(* Create the self ref cell and add it to the map. Return an indication - * whether this is a new one. *) -let createEnumInfo (n: string) : enuminfo * bool = - (* Add to the self cell set *) - try - H.find enumInfoNameEnv n, false (* Only if not already in *) - with Not_found -> begin - (* Create a enuminfo *) - let enum = { ename = n; eitems = []; - eattr = []; ereferenced = false; } in - H.add enumInfoNameEnv n enum; - enum, true - end - - - (* kind is either "struct" or "union" or "enum" and n is a name *) -let findCompType (kind: string) (n: string) (a: attributes) = - let makeForward () = - (* This is a forward reference, either because we have not seen this - * struct already or because we want to create a version with different - * attributes *) - if kind = "enum" then - let enum, isnew = createEnumInfo n in - if isnew then - cabsPushGlobal (GEnumTagDecl (enum, !currentLoc)); - TEnum (enum, a) - else - let iss = if kind = "struct" then true else false in - let self, isnew = createCompInfo iss n in - if isnew then - cabsPushGlobal (GCompTagDecl (self, !currentLoc)); - TComp (self, a) - in - try - let old, _ = lookupTypeNoError kind n in (* already defined *) - let olda = typeAttrs old in - if Util.equals olda a then old else makeForward () - with Not_found -> makeForward () - - -(* A simple visitor that searchs a statement for labels *) -class canDropStmtClass pRes = object - inherit nopCilVisitor - - method vstmt s = - if s.labels != [] then - (pRes := false; SkipChildren) - else - if !pRes then DoChildren else SkipChildren - - method vinst _ = SkipChildren - method vexpr _ = SkipChildren - -end -let canDropStatement (s: stmt) : bool = - let pRes = ref true in - let vis = new canDropStmtClass pRes in - ignore (visitCilStmt vis s); - !pRes - -(**** Occasionally we see structs with no name and no fields *) - - -module BlockChunk = - struct - type chunk = { - stmts: stmt list; - postins: instr list; (* Some instructions to append at - * the ends of statements (in - * reverse order) *) - (* A list of case statements visible at the - * outer level *) - cases: (label * stmt) list - } - - let d_chunk () (c: chunk) = - dprintf "@[{ @[%a@] };@?%a@]" - (docList ~sep:(chr ';') (d_stmt ())) c.stmts - (docList ~sep:(chr ';') (d_instr ())) (List.rev c.postins) - - let empty = - { stmts = []; postins = []; cases = []; } - - let isEmpty (c: chunk) = - c.postins == [] && c.stmts == [] - - let isNotEmpty (c: chunk) = not (isEmpty c) - - let i2c (i: instr) = - { empty with postins = [i] } - - (* Occasionally, we'll have to push postins into the statements *) - let pushPostIns (c: chunk) : stmt list = - if c.postins = [] then c.stmts - else - let rec toLast = function - [{skind=Instr il} as s] as stmts -> - s.skind <- Instr (il @ (List.rev c.postins)); - stmts - - | [] -> [mkStmt (Instr (List.rev c.postins))] - - | a :: rest -> a :: toLast rest - in - compactStmts (toLast c.stmts) - - - let c2block (c: chunk) : block = - { battrs = []; - bstmts = pushPostIns c; - } - - (* Add an instruction at the end. Never refer to this instruction again - * after you call this *) - let (+++) (c: chunk) (i : instr) = - {c with postins = i :: c.postins} - - (* Append two chunks. Never refer to the original chunks after you call - * this. And especially never share c2 with somebody else *) - let (@@) (c1: chunk) (c2: chunk) = - { stmts = compactStmts (pushPostIns c1 @ c2.stmts); - postins = c2.postins; - cases = c1.cases @ c2.cases; - } - - let skipChunk = empty - - let returnChunk (e: exp option) (l: location) : chunk = - { stmts = [ mkStmt (Return(e, l)) ]; - postins = []; - cases = [] - } - - let ifChunk (be: exp) (l: location) (t: chunk) (e: chunk) : chunk = - - { stmts = [ mkStmt(If(be, c2block t, c2block e, l))]; - postins = []; - cases = t.cases @ e.cases; - } - - (* We can duplicate a chunk if it has a few simple statements, and if - * it does not have cases *) - let duplicateChunk (c: chunk) = (* raises Failure if you should not - * duplicate this chunk *) - if not !allowDuplication then - raise (Failure "cannot duplicate: disallowed by user"); - if c.cases != [] then raise (Failure "cannot duplicate: has cases") else - let pCount = ref (List.length c.postins) in - { stmts = - List.map - (fun s -> - if s.labels != [] then - raise (Failure "cannot duplicate: has labels"); -(* - (match s.skind with - If _ | Switch _ | (*Loop _*) - While _ | DoWhile _ | For _ | Block _ -> - raise (Failure "cannot duplicate: complex stmt") - | Instr il -> - pCount := !pCount + List.length il - | _ -> incr pCount); - if !pCount > 5 then raise (Failure ("cannot duplicate: too many instr")); -*) - (* We can just copy it because there is nothing to share here. - * Except maybe for the ref cell in Goto but it is Ok to share - * that, I think *) - { s with sid = s.sid}) c.stmts; - postins = c.postins; (* There is no shared stuff in instructions *) - cases = [] - } -(* - let duplicateChunk (c: chunk) = - if isEmpty c then c else raise (Failure ("cannot duplicate: isNotEmpty")) -*) - (* We can drop a chunk if it does not have labels inside *) - let canDrop (c: chunk) = - List.for_all canDropStatement c.stmts - -(* - let loopChunk (body: chunk) : chunk = - (* Make the statement *) - let loop = mkStmt (Loop (c2block body, !currentLoc, None, None)) in - { stmts = [ loop (* ; n *) ]; - postins = []; - cases = body.cases; - } -*) - - let whileChunk (e: exp) (body: chunk) : chunk = - let loop = mkStmt (While (e, c2block body, !currentLoc)) in - - { stmts = [ loop ]; - postins = []; - cases = body.cases; - } - - let doWhileChunk (e: exp) (body: chunk) : chunk = - let loop = mkStmt (DoWhile (e, c2block body, !currentLoc)) in - - { stmts = [ loop ]; - postins = []; - cases = body.cases; - } - - let forChunk (bInit: chunk) (e: exp) (bIter: chunk) - (body: chunk) : chunk = - let loop = mkStmt (For (c2block bInit, e, c2block bIter, - c2block body, !currentLoc)) in - - { stmts = [ loop ]; - postins = []; - cases = body.cases; - } - - let breakChunk (l: location) : chunk = - { stmts = [ mkStmt (Break l) ]; - postins = []; - cases = []; - } - - let continueChunk (l: location) : chunk = - { stmts = [ mkStmt (Continue l) ]; - postins = []; - cases = [] - } - - (* Keep track of the gotos *) - let backPatchGotos : (string, stmt ref list ref) H.t = H.create 17 - let addGoto (lname: string) (bref: stmt ref) : unit = - let gotos = - try - H.find backPatchGotos lname - with Not_found -> begin - let gotos = ref [] in - H.add backPatchGotos lname gotos; - gotos - end - in - gotos := bref :: !gotos - - (* Keep track of the labels *) - let labelStmt : (string, stmt) H.t = H.create 17 - let initLabels () = - H.clear backPatchGotos; - H.clear labelStmt - - let resolveGotos () = - H.iter - (fun lname gotos -> - try - let dest = H.find labelStmt lname in - List.iter (fun gref -> gref := dest) !gotos - with Not_found -> begin - E.s (error "Label %s not found\n" lname) - end) - backPatchGotos - - (* Get the first statement in a chunk. Might need to change the - * statements in the chunk *) - let getFirstInChunk (c: chunk) : stmt * stmt list = - (* Get the first statement and add the label to it *) - match c.stmts with - s :: _ -> s, c.stmts - | [] -> (* Add a statement *) - let n = mkEmptyStmt () in - n, n :: c.stmts - - let consLabel (l: string) (c: chunk) (loc: location) - (in_original_program_text : bool) : chunk = - (* Get the first statement and add the label to it *) - let labstmt, stmts' = getFirstInChunk c in - (* Add the label *) - labstmt.labels <- Label (l, loc, in_original_program_text) :: - labstmt.labels; - H.add labelStmt l labstmt; - if c.stmts == stmts' then c else {c with stmts = stmts'} - - let s2c (s:stmt) : chunk = - { stmts = [ s ]; - postins = []; - cases = []; - } - - let gotoChunk (ln: string) (l: location) : chunk = - let gref = ref dummyStmt in - addGoto ln gref; - { stmts = [ mkStmt (Goto (gref, l)) ]; - postins = []; - cases = []; - } - - let caseRangeChunk (el: exp list) (l: location) (next: chunk) = - let fst, stmts' = getFirstInChunk next in - let labels = List.map (fun e -> Case (e, l)) el in - let cases = List.map (fun l -> (l, fst)) labels in - fst.labels <- labels @ fst.labels; - { next with stmts = stmts'; cases = cases @ next.cases} - - let defaultChunk (l: location) (next: chunk) = - let fst, stmts' = getFirstInChunk next in - let lb = Default l in - fst.labels <- lb :: fst.labels; - { next with stmts = stmts'; cases = (lb, fst) :: next.cases} - - - let switchChunk (e: exp) (body: chunk) (l: location) = - (* Make the statement *) - let switch = mkStmt (Switch (e, c2block body, - List.map (fun (_, s) -> s) body.cases, - l)) in - { stmts = [ switch (* ; n *) ]; - postins = []; - cases = []; - } - - let mkFunctionBody (c: chunk) : block = - resolveGotos (); initLabels (); - if c.cases <> [] then - E.s (error "Switch cases not inside a switch statement\n"); - c2block c - - end - -open BlockChunk - - -(************ Labels ***********) -(* -(* Since we turn dowhile and for loops into while we need to take care in - * processing the continue statement. For each loop that we enter we place a - * marker in a list saying what kinds of loop it is. When we see a continue - * for a Non-while loop we must generate a label for the continue *) -type loopstate = - While - | NotWhile of string ref - -let continues : loopstate list ref = ref [] - -let startLoop iswhile = - continues := (if iswhile then While else NotWhile (ref "")) :: !continues -*) - -(* We need to take care while processing the continue statement... - * For each loop that we enter we place a marker in a list saying what - * chunk of code we must duplicate before each continue statement - * in order to preserve the semantics. *) -type loopMarker = - | DuplicateBeforeContinue of chunk - | ContinueUnchanged - -let continues : loopMarker list ref = ref [] - -let startLoop lstate = - continues := lstate :: !continues - -let continueDuplicateChunk (l: location) : chunk = - match !continues with - | [] -> E.s (error "continue not in a loop") - | DuplicateBeforeContinue c :: _ -> c @@ continueChunk l - | ContinueUnchanged :: _ -> continueChunk l - -(* Sometimes we need to create new label names *) -let newLabelName (base: string) = fst (newAlphaName false "label" base) - -(* -let continueOrLabelChunk (l: location) : chunk = - match !continues with - [] -> E.s (error "continue not in a loop") - | While :: _ -> continueChunk l - | NotWhile lr :: _ -> - if !lr = "" then begin - lr := newLabelName "__Cont" - end; - gotoChunk !lr l - -let consLabContinue (c: chunk) = - match !continues with - [] -> E.s (error "labContinue not in a loop") - | While :: rest -> c - | NotWhile lr :: rest -> if !lr = "" then c else consLabel !lr c !currentLoc false -*) - -let exitLoop () = - match !continues with - [] -> E.s (error "exit Loop not in a loop") - | _ :: rest -> continues := rest - - -(* In GCC we can have locally declared labels. *) -let genNewLocalLabel (l: string) = - (* Call the newLabelName to register the label name in the alpha conversion - * table. *) - let l' = newLabelName l in - (* Add it to the environment *) - addLocalToEnv (kindPlusName "label" l) (EnvLabel l'); - l' - -let lookupLabel (l: string) = - try - match H.find env (kindPlusName "label" l) with - EnvLabel l', _ -> l' - | _ -> raise Not_found - with Not_found -> - l - - -(** ALLOCA ***) -let allocaFun () = - let name = - if !msvcMode then "alloca" - (* Use __builtin_alloca where possible, because this can be used - even when gcc is invoked with -fno-builtin *) - else "__builtin_alloca" - in - let fdec = emptyFunction name in - fdec.svar.vtype <- - TFun(voidPtrType, Some [ ("len", !typeOfSizeOf, []) ], false, []); - fdec.svar - -(* Maps local variables that are variable sized arrays to the expression that - * denotes their length *) -let varSizeArrays : exp IH.t = IH.create 17 - -(**** EXP actions ***) -type expAction = - ADrop (* Drop the result. Only the - * side-effect is interesting *) - | ASet of lval * typ (* Put the result in a given lval, - * provided it matches the type. The - * type is the type of the lval. *) - | AExp of typ option (* Return the exp as usual. - * Optionally we can specify an - * expected type. This is useful for - * constants. The expected type is - * informational only, we do not - * guarantee that the converted - * expression has that type.You must - * use a doCast afterwards to make - * sure. *) - | AExpLeaveArrayFun (* Do it like an expression, but do - * not convert arrays of functions - * into pointers *) - - -(*** Result of compiling conditional expressions *) -type condExpRes = - CEExp of chunk * exp (* Do a chunk and then an expression *) - | CEAnd of condExpRes * condExpRes - | CEOr of condExpRes * condExpRes - | CENot of condExpRes - -(******** CASTS *********) -let integralPromotion (t : typ) : typ = (* c.f. ISO 6.3.1.1 *) - match unrollType t with - (* We assume that an IInt can hold even an IUShort *) - TInt ((IShort|IUShort|IChar|ISChar|IUChar), a) -> TInt(IInt, a) - | TInt _ -> t - | TEnum (_, a) -> TInt(IInt, a) - | t -> E.s (error "integralPromotion: not expecting %a" d_type t) - - -let arithmeticConversion (* c.f. ISO 6.3.1.8 *) - (t1: typ) - (t2: typ) : typ = - let checkToInt _ = () in (* dummies for now *) - let checkToFloat _ = () in - match unrollType t1, unrollType t2 with - TFloat(FLongDouble, _), _ -> checkToFloat t2; t1 - | _, TFloat(FLongDouble, _) -> checkToFloat t1; t2 - | TFloat(FDouble, _), _ -> checkToFloat t2; t1 - | _, TFloat (FDouble, _) -> checkToFloat t1; t2 - | TFloat(FFloat, _), _ -> checkToFloat t2; t1 - | _, TFloat (FFloat, _) -> checkToFloat t1; t2 - | _, _ -> begin - let t1' = integralPromotion t1 in - let t2' = integralPromotion t2 in - match unrollType t1', unrollType t2' with - TInt(IULongLong, _), _ -> checkToInt t2'; t1' - | _, TInt(IULongLong, _) -> checkToInt t1'; t2' - - (* We assume a long long is always larger than a long *) - | TInt(ILongLong, _), _ -> checkToInt t2'; t1' - | _, TInt(ILongLong, _) -> checkToInt t1'; t2' - - | TInt(IULong, _), _ -> checkToInt t2'; t1' - | _, TInt(IULong, _) -> checkToInt t1'; t2' - - - | TInt(ILong,_), TInt(IUInt,_) - when bitsSizeOf t1' <= bitsSizeOf t2' -> TInt(IULong,[]) - | TInt(IUInt,_), TInt(ILong,_) - when bitsSizeOf t2' <= bitsSizeOf t1' -> TInt(IULong,[]) - - | TInt(ILong, _), _ -> checkToInt t2'; t1' - | _, TInt(ILong, _) -> checkToInt t1'; t2' - - | TInt(IUInt, _), _ -> checkToInt t2'; t1' - | _, TInt(IUInt, _) -> checkToInt t1'; t2' - - | TInt(IInt, _), TInt (IInt, _) -> t1' - - | _, _ -> E.s (error "arithmeticConversion") - end - - -(* Specify whether the cast is from the source code *) -let rec castTo ?(fromsource=false) - (ot : typ) (nt : typ) (e : exp) : (typ * exp ) = -(* - ignore (E.log "%t: castTo:%s %a->%a\n" - d_thisloc - (if fromsource then "(source)" else "") - d_type ot d_type nt); -*) - if not fromsource && Util.equals (typeSig ot) (typeSig nt) then - (* Do not put the cast if it is not necessary, unless it is from the - * source. *) - (ot, e) - else begin - let result = (nt, - if !insertImplicitCasts || fromsource then mkCastT e ot nt else e) in -(* - ignore (E.log "castTo: ot=%a nt=%a\n result is %a\n" - d_type ot d_type nt - d_plainexp (snd result)); -*) - (* Now see if we can have a cast here *) - match ot, nt with - TNamed(r, _), _ -> castTo ~fromsource:fromsource r.ttype nt e - | _, TNamed(r, _) -> castTo ~fromsource:fromsource ot r.ttype e - | TInt(ikindo,_), TInt(ikindn,_) -> - (* We used to ignore attributes on integer-integer casts. Not anymore *) - (* if ikindo = ikindn then (nt, e) else *) - result - - | TPtr (told, _), TPtr(tnew, _) -> result - - | TInt _, TPtr _ -> result - - | TPtr _, TInt _ -> result - - | TArray _, TPtr _ -> result - - | TArray(t1,_,_), TArray(t2,None,_) when Util.equals (typeSig t1) (typeSig t2) -> (nt, e) - - | TPtr _, TArray(_,_,_) -> (nt, e) - - | TEnum _, TInt _ -> result - | TFloat _, (TInt _|TEnum _) -> result - | (TInt _|TEnum _), TFloat _ -> result - | TFloat _, TFloat _ -> result - | TInt _, TEnum _ -> result - | TEnum _, TEnum _ -> result - - | TEnum _, TPtr _ -> result - | TBuiltin_va_list _, (TInt _ | TPtr _) -> - result - - | (TInt _ | TPtr _), TBuiltin_va_list _ -> - ignore (warnOpt "Casting %a to __builtin_va_list" d_type ot); - result - - | TPtr _, TEnum _ -> - ignore (warnOpt "Casting a pointer into an enumeration type"); - result - - (* The expression is evaluated for its side-effects *) - | (TInt _ | TEnum _ | TPtr _ ), TVoid _ -> - (ot, e) - - (* Even casts between structs are allowed when we are only - * modifying some attributes *) - | TComp (comp1, a1), TComp (comp2, a2) when comp1.ckey = comp2.ckey -> - (nt, e) - - (** If we try to pass a transparent union value to a function - * expecting a transparent union argument, the argument type would - * have been changed to the type of the first argument, and we'll - * see a cast from a union to the type of the first argument. Turn - * that into a field access *) - | TComp(tunion, a1), nt -> begin - match isTransparentUnion ot with - None -> E.s (error "castTo %a -> %a@!" d_type ot d_type nt) - | Some fstfield -> begin - (* We do it now only if the expression is an lval *) - let e' = - match e with - Lval lv -> - Lval (addOffsetLval (Field(fstfield, NoOffset)) lv) - | _ -> E.s (unimp "castTo: transparent union expression is not an lval: %a\n" d_exp e) - in - (* Continue casting *) - castTo ~fromsource:fromsource fstfield.ftype nt e' - end - end - | _ -> E.s (error "cabs2cil: castTo %a -> %a@!" d_type ot d_type nt) - end - - -(* A cast that is used for conditional expressions. Pointers are Ok *) -let checkBool (ot : typ) (e : exp) : bool = - match unrollType ot with - TInt _ -> true - | TPtr _ -> true - | TEnum _ -> true - | TFloat _ -> true - | _ -> E.s (error "castToBool %a" d_type ot) - -(* Given an expression that is being coerced to bool, - is it a nonzero constant? *) -let rec isConstTrue (e:exp): bool = - match e with - | Const(CInt64 (n,_,_)) -> n <> Int64.zero - | Const(CChr c) -> 0 <> Char.code c - | Const(CStr _ | CWStr _) -> true - | Const(CReal(f, _, _)) -> f <> 0.0; - | CastE(_, e) -> isConstTrue e - | _ -> false - -(* Given an expression that is being coerced to bool, is it zero? - This is a more general version of Cil.isZero, which only handles integers. - On constant expressions, either isConstTrue or isConstFalse will hold. *) -let rec isConstFalse (e:exp): bool = - match e with - | Const(CInt64 (n,_,_)) -> n = Int64.zero - | Const(CChr c) -> 0 = Char.code c - | Const(CReal(f, _, _)) -> f = 0.0; - | CastE(_, e) -> isConstFalse e - | _ -> false - - - -(* We have our own version of addAttributes that does not allow duplicates *) -let cabsAddAttributes al0 (al: attributes) : attributes = - if al0 == [] then al else - List.fold_left - (fun acc (Attr(an, _) as a) -> - (* See if the attribute is already in there *) - match filterAttributes an acc with - [] -> addAttribute a acc (* Nothing with that name *) - | a' :: _ -> - if Util.equals a a' then - acc (* Already in *) - else begin - ignore (warnOpt - "Duplicate attribute %a along with %a" - d_attr a d_attr a'); - (* let acc' = dropAttribute an acc in *) - (** Keep both attributes *) - addAttribute a acc - end) - al - al0 - -let cabsTypeAddAttributes a0 t = - begin - match a0 with - | [] -> - (* no attributes, keep same type *) - t - | _ -> - (* anything else: add a0 to existing attributes *) - let add (a: attributes) = cabsAddAttributes a0 a in - match t with - TVoid a -> TVoid (add a) - | TInt (ik, a) -> - (* Here we have to watch for the mode attribute *) -(* sm: This stuff is to handle a GCC extension where you can request integers*) -(* of specific widths using the "mode" attribute syntax; for example: *) -(* typedef int int8_t __attribute__ ((__mode__ ( __QI__ ))) ; *) -(* The cryptic "__QI__" defines int8_t to be 8 bits wide, instead of the *) -(* 32 bits you'd guess if you didn't know about "mode". The relevant *) -(* testcase is test/small2/mode_sizes.c, and it was inspired by my *) -(* /usr/include/sys/types.h. *) -(* *) -(* A consequence of this handling is that we throw away the mode *) -(* attribute, which we used to go out of our way to avoid printing anyway.*) - let ik', a0' = - (* Go over the list of new attributes and come back with a - * filtered list and a new integer kind *) - List.fold_left - (fun (ik', a0') a0one -> - match a0one with - Attr("mode", [ACons(mode,[])]) -> begin - (trace "gccwidth" (dprintf "I see mode %s applied to an int type\n" - mode (* #$@!#@ ML! d_type t *) )); - (* the cases below encode the 32-bit assumption.. *) - match (ik', mode) with - | (IInt, "__QI__") -> (IChar, a0') - | (IInt, "__byte__") -> (IChar, a0') - | (IInt, "__HI__") -> (IShort, a0') - | (IInt, "__SI__") -> (IInt, a0') (* same as t *) - | (IInt, "__word__") -> (IInt, a0') - | (IInt, "__pointer__") -> (IInt, a0') - | (IInt, "__DI__") -> (ILongLong, a0') - - | (IUInt, "__QI__") -> (IUChar, a0') - | (IUInt, "__byte__") -> (IUChar, a0') - | (IUInt, "__HI__") -> (IUShort, a0') - | (IUInt, "__SI__") -> (IUInt, a0') - | (IUInt, "__word__") -> (IUInt, a0') - | (IUInt, "__pointer__")-> (IUInt, a0') - | (IUInt, "__DI__") -> (IULongLong, a0') - - | _ -> - (ignore (error "GCC width mode %s applied to unexpected type, or unexpected mode" - mode)); - (ik', a0one :: a0') - - end - | _ -> (ik', a0one :: a0')) - (ik, []) - a0 - in - TInt (ik', cabsAddAttributes a0' a) - - | TFloat (fk, a) -> TFloat (fk, add a) - | TEnum (enum, a) -> TEnum (enum, add a) - | TPtr (t, a) -> TPtr (t, add a) - | TArray (t, l, a) -> TArray (t, l, add a) - | TFun (t, args, isva, a) -> TFun(t, args, isva, add a) - | TComp (comp, a) -> TComp (comp, add a) - | TNamed (t, a) -> TNamed (t, add a) - | TBuiltin_va_list a -> TBuiltin_va_list (add a) - end - - -(* Do types *) - (* Combine the types. Raises the Failure exception with an error message. - * isdef says whether the new type is for a definition *) -type combineWhat = - CombineFundef (* The new definition is for a function definition. The old - * is for a prototype *) - | CombineFunarg (* Comparing a function argument type with an old prototype - * arg *) - | CombineFunret (* Comparing the return of a function with that from an old - * prototype *) - | CombineOther - -(* We sometimes want to succeed in combining two structure types that are - * identical except for the names of the structs. We keep a list of types - * that are known to be equal *) -let isomorphicStructs : (string * string, bool) H.t = H.create 15 - -let rec combineTypes (what: combineWhat) (oldt: typ) (t: typ) : typ = - match oldt, t with - | TVoid olda, TVoid a -> TVoid (cabsAddAttributes olda a) - | TInt (oldik, olda), TInt (ik, a) -> - let combineIK oldk k = - if oldk = k then oldk else - (* GCC allows a function definition to have a more precise integer - * type than a prototype that says "int" *) - if not !msvcMode && oldk = IInt && bitsSizeOf t <= 32 - && (what = CombineFunarg || what = CombineFunret) then - k - else - raise (Failure "different integer types") - in - TInt (combineIK oldik ik, cabsAddAttributes olda a) - | TFloat (oldfk, olda), TFloat (fk, a) -> - let combineFK oldk k = - if oldk = k then oldk else - (* GCC allows a function definition to have a more precise integer - * type than a prototype that says "double" *) - if not !msvcMode && oldk = FDouble && k = FFloat - && (what = CombineFunarg || what = CombineFunret) then - k - else - raise (Failure "different floating point types") - in - TFloat (combineFK oldfk fk, cabsAddAttributes olda a) - | TEnum (_, olda), TEnum (ei, a) -> - TEnum (ei, cabsAddAttributes olda a) - - (* Strange one. But seems to be handled by GCC *) - | TEnum (oldei, olda) , TInt(IInt, a) -> TEnum(oldei, - cabsAddAttributes olda a) - (* Strange one. But seems to be handled by GCC *) - | TInt(IInt, olda), TEnum (ei, a) -> TEnum(ei, cabsAddAttributes olda a) - - - | TComp (oldci, olda) , TComp (ci, a) -> - if oldci.cstruct <> ci.cstruct then - raise (Failure "different struct/union types"); - let comb_a = cabsAddAttributes olda a in - if oldci.cname = ci.cname then - TComp (oldci, comb_a) - else - (* Now maybe they are actually the same *) - if H.mem isomorphicStructs (oldci.cname, ci.cname) then - (* We know they are the same *) - TComp (oldci, comb_a) - else begin - (* If one has 0 fields (undefined) while the other has some fields - * we accept it *) - let oldci_nrfields = List.length oldci.cfields in - let ci_nrfields = List.length ci.cfields in - if oldci_nrfields = 0 then - TComp (ci, comb_a) - else if ci_nrfields = 0 then - TComp (oldci, comb_a) - else begin - (* Make sure that at least they have the same number of fields *) - if oldci_nrfields <> ci_nrfields then begin -(* - ignore (E.log "different number of fields: %s had %d and %s had %d\n" - oldci.cname oldci_nrfields - ci.cname ci_nrfields); -*) - raise (Failure "different structs(number of fields)"); - end; - (* Assume they are the same *) - H.add isomorphicStructs (oldci.cname, ci.cname) true; - H.add isomorphicStructs (ci.cname, oldci.cname) true; - (* Check that the fields are isomorphic and watch for Failure *) - (try - List.iter2 (fun oldf f -> - if oldf.fbitfield <> f.fbitfield then - raise (Failure "different structs(bitfield info)"); - if oldf.fattr <> f.fattr then - raise (Failure "different structs(field attributes)"); - (* Make sure the types are compatible *) - ignore (combineTypes CombineOther oldf.ftype f.ftype); - ) oldci.cfields ci.cfields - with Failure _ as e -> begin - (* Our assumption was wrong. Forget the isomorphism *) - ignore (E.log "\tFailed in our assumption that %s and %s are isomorphic\n" - oldci.cname ci.cname); - H.remove isomorphicStructs (oldci.cname, ci.cname); - H.remove isomorphicStructs (ci.cname, oldci.cname); - raise e - end); - (* We get here if we succeeded *) - TComp (oldci, comb_a) - end - end - - | TArray (oldbt, oldsz, olda), TArray (bt, sz, a) -> - let newbt = combineTypes CombineOther oldbt bt in - let newsz = - match oldsz, sz with - None, Some _ -> sz - | Some _, None -> oldsz - | None, None -> sz - | Some oldsz', Some sz' -> - (* They are not structurally equal. But perhaps they are equal if - * we evaluate them. Check first machine independent comparison *) - let checkEqualSize (machdep: bool) = - Util.equals (constFold machdep oldsz') - (constFold machdep sz') - in - if checkEqualSize false then - oldsz - else if checkEqualSize true then begin - ignore (warn "Array type comparison succeeds only based on machine-dependent constant evaluation: %a and %a\n" - d_exp oldsz' d_exp sz'); - oldsz - end else - raise (Failure "different array lengths") - - in - TArray (newbt, newsz, cabsAddAttributes olda a) - - | TPtr (oldbt, olda), TPtr (bt, a) -> - TPtr (combineTypes CombineOther oldbt bt, cabsAddAttributes olda a) - - | TFun (_, _, _, [Attr("missingproto",_)]), TFun _ -> t - - | TFun (oldrt, oldargs, oldva, olda), TFun (rt, args, va, a) -> - let newrt = combineTypes - (if what = CombineFundef then CombineFunret else CombineOther) - oldrt rt - in - if oldva != va then - raise (Failure "diferent vararg specifiers"); - (* If one does not have arguments, believe the one with the - * arguments *) - let newargs = - if oldargs = None then args else - if args = None then oldargs else - let oldargslist = argsToList oldargs in - let argslist = argsToList args in - if List.length oldargslist <> List.length argslist then - raise (Failure "different number of arguments") - else begin - (* Go over the arguments and update the old ones with the - * adjusted types *) - Some - (List.map2 - (fun (on, ot, oa) (an, at, aa) -> - (* Update the names. Always prefer the new name. This is - * very important if the prototype uses different names than - * the function definition. *) - let n = if an <> "" then an else on in - let t = - combineTypes - (if what = CombineFundef then - CombineFunarg else CombineOther) - ot at - in - let a = addAttributes oa aa in - (n, t, a)) - oldargslist argslist) - end - in - TFun (newrt, newargs, oldva, cabsAddAttributes olda a) - - | TNamed (oldt, olda), TNamed (t, a) when oldt.tname = t.tname -> - TNamed (oldt, cabsAddAttributes olda a) - - | TBuiltin_va_list olda, TBuiltin_va_list a -> - TBuiltin_va_list (cabsAddAttributes olda a) - - (* Unroll first the new type *) - | _, TNamed (t, a) -> - let res = combineTypes what oldt t.ttype in - cabsTypeAddAttributes a res - - (* And unroll the old type as well if necessary *) - | TNamed (oldt, a), _ -> - let res = combineTypes what oldt.ttype t in - cabsTypeAddAttributes a res - - | _ -> raise (Failure "different type constructors") - - -(* Create and cache varinfo's for globals. Starts with a varinfo but if the - * global has been declared already it might come back with another varinfo. - * Returns the varinfo to use (might be the old one), and an indication - * whether the variable exists already in the environment *) -let makeGlobalVarinfo (isadef: bool) (vi: varinfo) : varinfo * bool = - try (* See if already defined, in the global environment. We could also - * look it up in the whole environment but in that case we might see a - * local. This can happen when we declare an extern variable with - * global scope but we are in a local scope. *) - let oldvi, oldloc = lookupGlobalVar vi.vname in - (* It was already defined. We must reuse the varinfo. But clean up the - * storage. *) - let newstorage = (** See 6.2.2 *) - match oldvi.vstorage, vi.vstorage with - (* Extern and something else is that thing *) - | Extern, other - | other, Extern -> other - - | NoStorage, other - | other, NoStorage -> other - - - | _ -> - if vi.vstorage != oldvi.vstorage then - ignore (warn - "Inconsistent storage specification for %s. Previous declaration: %a" - vi.vname d_loc oldloc); - vi.vstorage - in - oldvi.vinline <- oldvi.vinline || vi.vinline; - oldvi.vstorage <- newstorage; - (* Union the attributes *) - oldvi.vattr <- cabsAddAttributes oldvi.vattr vi.vattr; - begin - try - oldvi.vtype <- - combineTypes - (if isadef then CombineFundef else CombineOther) - oldvi.vtype vi.vtype; - with Failure reason -> - ignore (E.log "old type = %a\n" d_plaintype oldvi.vtype); - ignore (E.log "new type = %a\n" d_plaintype vi.vtype); - E.s (error "Declaration of %s does not match previous declaration from %a (%s)." - vi.vname d_loc oldloc reason) - end; - - (* Found an old one. Keep the location always from the definition *) - if isadef then begin - oldvi.vdecl <- vi.vdecl; - end; - oldvi, true - - with Not_found -> begin (* A new one. *) - (* Announce the name to the alpha conversion table. This will not - * actually change the name of the vi. See the definition of - * alphaConvertVarAndAddToEnv *) - alphaConvertVarAndAddToEnv true vi, false - end - -let conditionalConversion (t2: typ) (t3: typ) : typ = - let tresult = (* ISO 6.5.15 *) - match unrollType t2, unrollType t3 with - (TInt _ | TEnum _ | TFloat _), - (TInt _ | TEnum _ | TFloat _) -> - arithmeticConversion t2 t3 - | TComp (comp2,_), TComp (comp3,_) - when comp2.ckey = comp3.ckey -> t2 - | TPtr(_, _), TPtr(TVoid _, _) -> t2 - | TPtr(TVoid _, _), TPtr(_, _) -> t3 - | TPtr _, TPtr _ when Util.equals (typeSig t2) (typeSig t3) -> t2 - | TPtr _, TInt _ -> t2 (* most likely comparison with 0 *) - | TInt _, TPtr _ -> t3 (* most likely comparison with 0 *) - - (* When we compare two pointers of diffent type, we combine them - * using the same algorithm when combining multiple declarations of - * a global *) - | (TPtr _) as t2', (TPtr _ as t3') -> begin - try combineTypes CombineOther t2' t3' - with Failure msg -> begin - ignore (warn "A.QUESTION: %a does not match %a (%s)" - d_type (unrollType t2) d_type (unrollType t3) msg); - t2 (* Just pick one *) - end - end - | _, _ -> E.s (error "A.QUESTION for invalid combination of types") - in - tresult - -(* Some utilitites for doing initializers *) - -let debugInit = false - -type preInit = - | NoInitPre - | SinglePre of exp - | CompoundPre of int ref (* the maximum used index *) - * preInit array ref (* an array with initializers *) - -(* Instructions on how to handle designators *) -type handleDesignators = - | Handle (* Handle them yourself *) - | DoNotHandle (* Do not handle them your self *) - | HandleAsNext (* First behave as if you have a NEXT_INIT. Useful for going - * into nested designators *) - | HandleFirst (* Handle only the first designator *) - -(* Set an initializer *) -let rec setOneInit (this: preInit) - (o: offset) (e: exp) : preInit = - match o with - NoOffset -> SinglePre e - | _ -> - let idx, (* Index in the current comp *) - restoff (* Rest offset *) = - match o with - | Index(Const(CInt64(i,_,_)), off) -> Int64.to_int i, off - | Field (f, off) -> - (* Find the index of the field *) - let rec loop (idx: int) = function - [] -> E.s (bug "Cannot find field %s" f.fname) - | f' :: _ when f'.fname = f.fname -> idx - | _ :: restf -> loop (idx + 1) restf - in - loop 0 f.fcomp.cfields, off - | _ -> E.s (bug "setOneInit: non-constant index") - in - let pMaxIdx, pArray = - match this with - NoInitPre -> (* No initializer so far here *) - ref idx, ref (Array.create (max 32 (idx + 1)) NoInitPre) - - | CompoundPre (pMaxIdx, pArray) -> - if !pMaxIdx < idx then begin - pMaxIdx := idx; - (* Maybe we also need to grow the array *) - let l = Array.length !pArray in - if l <= idx then begin - let growBy = max (max 32 (idx + 1 - l)) (l / 2) in - let newarray = Array.make (growBy + idx) NoInitPre in - Array.blit !pArray 0 newarray 0 l; - pArray := newarray - end - end; - pMaxIdx, pArray - | SinglePre e -> - E.s (unimp "Index %d is already initialized" idx) - in - assert (idx >= 0 && idx < Array.length !pArray); - let this' = setOneInit !pArray.(idx) restoff e in - !pArray.(idx) <- this'; - CompoundPre (pMaxIdx, pArray) - - -(* collect a CIL initializer, given the original syntactic initializer - * 'preInit'; this returns a type too, since initialization of an array - * with unspecified size actually changes the array's type - * (ANSI C, 6.7.8, para 22) *) -let rec collectInitializer - (this: preInit) - (thistype: typ) : (init * typ) = - if this = NoInitPre then (makeZeroInit thistype), thistype - else - match unrollType thistype, this with - | _ , SinglePre e -> SingleInit e, thistype - | TArray (bt, leno, at), CompoundPre (pMaxIdx, pArray) -> - let (len: int), newtype = - (* normal case: use array's declared length, newtype=thistype *) - match leno with - Some len -> begin - match constFold true len with - Const(CInt64(ni, _, _)) when ni >= 0L -> - (Int64.to_int ni), TArray(bt,leno,at) - - | _ -> E.s (error "Array length is not a constant expression %a" - d_exp len) - end - | _ -> - (* unsized array case, length comes from initializers *) - (!pMaxIdx + 1, - TArray (bt, Some (integer (!pMaxIdx + 1)), at)) - in - if !pMaxIdx >= len then - E.s (E.bug "collectInitializer: too many initializers(%d >= %d)\n" - !pMaxIdx len); - (* len could be extremely big. So omit the last initializers, if they - * are many (more than 16) *) -(* - ignore (E.log "collectInitializer: len = %d, pMaxIdx= %d\n" - len !pMaxIdx); *) - let endAt = - if len - 1 > !pMaxIdx + 16 then - !pMaxIdx - else - len - 1 - in - (* Make one zero initializer to be used next *) - let oneZeroInit = makeZeroInit bt in - let rec collect (acc: (offset * init) list) (idx: int) = - if idx = -1 then acc - else - let thisi = - if idx > !pMaxIdx then oneZeroInit - else (fst (collectInitializer !pArray.(idx) bt)) - in - collect ((Index(integer idx, NoOffset), thisi) :: acc) (idx - 1) - in - - CompoundInit (newtype, collect [] endAt), newtype - - | TComp (comp, _), CompoundPre (pMaxIdx, pArray) when comp.cstruct -> - let rec collect (idx: int) = function - [] -> [] - | f :: restf -> - if f.fname = missingFieldName then - collect (idx + 1) restf - else - let thisi = - if idx > !pMaxIdx then - makeZeroInit f.ftype - else - collectFieldInitializer !pArray.(idx) f - in - (Field(f, NoOffset), thisi) :: collect (idx + 1) restf - in - CompoundInit (thistype, collect 0 comp.cfields), thistype - - | TComp (comp, _), CompoundPre (pMaxIdx, pArray) when not comp.cstruct -> - (* Find the field to initialize *) - let rec findField (idx: int) = function - [] -> E.s (bug "collectInitializer: union") - | _ :: rest when idx < !pMaxIdx && !pArray.(idx) = NoInitPre -> - findField (idx + 1) rest - | f :: _ when idx = !pMaxIdx -> - Field(f, NoOffset), - collectFieldInitializer !pArray.(idx) f - | _ -> E.s (error "Can initialize only one field for union") - in - if !msvcMode && !pMaxIdx != 0 then - ignore (warn "On MSVC we can initialize only the first field of a union"); - CompoundInit (thistype, [ findField 0 comp.cfields ]), thistype - - | _ -> E.s (unimp "collectInitializer") - -and collectFieldInitializer - (this: preInit) - (f: fieldinfo) : init = - (* collect, and rewrite type *) - let init,newtype = (collectInitializer this f.ftype) in - f.ftype <- newtype; - init - - -type stackElem = - InArray of offset * typ * int * int ref (* offset of parent, base type, - * length, current index. If the - * array length is unspecified we - * use Int.max_int *) - | InComp of offset * compinfo * fieldinfo list (* offset of parent, - base comp, current fields *) - - -(* A subobject is given by its address. The address is read from the end of - * the list (the bottom of the stack), starting with the current object *) -type subobj = { mutable stack: stackElem list; (* With each stack element we - * store the offset of its - * PARENT *) - mutable eof: bool; (* The stack is empty and we reached the - * end *) - mutable soTyp: typ; (* The type of the subobject. Set using - * normalSubobj after setting stack. *) - mutable soOff: offset; (* The offset of the subobject. Set - * using normalSubobj after setting - * stack. *) - curTyp: typ; (* Type of current object. See ISO for - * the definition of the current object *) - curOff: offset; (* The offset of the current obj *) - host: varinfo; (* The host that we are initializing. - * For error messages *) - } - - -(* Make a subobject iterator *) -let rec makeSubobj - (host: varinfo) - (curTyp: typ) - (curOff: offset) = - let so = - { host = host; curTyp = curTyp; curOff = curOff; - stack = []; eof = false; - (* The next are fixed by normalSubobj *) - soTyp = voidType; soOff = NoOffset } in - normalSubobj so; - so - - (* Normalize a stack so the we always point to a valid subobject. Do not - * descend into type *) -and normalSubobj (so: subobj) : unit = - match so.stack with - [] -> so.soOff <- so.curOff; so.soTyp <- so.curTyp - (* The array is over *) - | InArray (parOff, bt, leno, current) :: rest -> - if leno = !current then begin (* The array is over *) - if debugInit then ignore (E.log "Past the end of array\n"); - so.stack <- rest; - advanceSubobj so - end else begin - so.soTyp <- bt; - so.soOff <- addOffset (Index(integer !current, NoOffset)) parOff - end - - (* The fields are over *) - | InComp (parOff, comp, nextflds) :: rest -> - if nextflds == [] then begin (* No more fields here *) - if debugInit then ignore (E.log "Past the end of structure\n"); - so.stack <- rest; - advanceSubobj so - end else begin - let fst = List.hd nextflds in - so.soTyp <- fst.ftype; - so.soOff <- addOffset (Field(fst, NoOffset)) parOff - end - - (* Advance to the next subobject. Always apply to a normalized object *) -and advanceSubobj (so: subobj) : unit = - if so.eof then E.s (bug "advanceSubobj past end"); - match so.stack with - | [] -> if debugInit then ignore (E.log "Setting eof to true\n"); - so.eof <- true - | InArray (parOff, bt, leno, current) :: rest -> - if debugInit then ignore (E.log " Advancing to [%d]\n" (!current + 1)); - (* so.stack <- InArray (parOff, bt, leno, current + 1) :: rest; *) - incr current; - normalSubobj so - - (* The fields are over *) - | InComp (parOff, comp, nextflds) :: rest -> - if debugInit then - ignore (E.log "Advancing past .%s\n" (List.hd nextflds).fname); - let flds' = try List.tl nextflds with _ -> E.s (bug "advanceSubobj") in - so.stack <- InComp(parOff, comp, flds') :: rest; - normalSubobj so - - - -(* Find the fields to initialize in a composite. *) -let fieldsToInit - (comp: compinfo) - (designator: string option) - : fieldinfo list = - (* Never look at anonymous fields *) - let flds1 = - List.filter (fun f -> f.fname <> missingFieldName) comp.cfields in - let flds2 = - match designator with - None -> flds1 - | Some fn -> - let rec loop = function - [] -> E.s (error "Cannot find designated field %s" fn) - | (f :: _) as nextflds when f.fname = fn -> nextflds - | _ :: rest -> loop rest - in - loop flds1 - in - (* If it is a union we only initialize one field *) - match flds2 with - [] -> [] - | (f :: rest) as toinit -> - if comp.cstruct then toinit else [f] - - -let integerArrayLength (leno: exp option) : int = - match leno with - None -> max_int - | Some len -> begin - try lenOfArray leno - with LenOfArray -> - E.s (error "Initializing non-constant-length array\n length=%a\n" - d_exp len) - end - -(* sm: I'm sure something like this already exists, but ... *) -let isNone (o : 'a option) : bool = - match o with - | None -> true - | Some _ -> false - - -let annonCompFieldNameId = ref 0 -let annonCompFieldName = "__annonCompField" - - - -(* Utility ***) -let rec replaceLastInList - (lst: A.expression list) - (how: A.expression -> A.expression) : A.expression list= - match lst with - [] -> [] - | [e] -> [how e] - | h :: t -> h :: replaceLastInList t how - - - - - -let convBinOp (bop: A.binary_operator) : binop = - match bop with - A.ADD -> PlusA - | A.SUB -> MinusA - | A.MUL -> Mult - | A.DIV -> Div - | A.MOD -> Mod - | A.BAND -> BAnd - | A.BOR -> BOr - | A.XOR -> BXor - | A.SHL -> Shiftlt - | A.SHR -> Shiftrt - | A.EQ -> Eq - | A.NE -> Ne - | A.LT -> Lt - | A.LE -> Le - | A.GT -> Gt - | A.GE -> Ge - | _ -> E.s (error "convBinOp") - -(**** PEEP-HOLE optimizations ***) -let afterConversion (c: chunk) : chunk = - (* Now scan the statements and find Instr blocks *) - - (** We want to collapse sequences of the form "tmp = f(); v = tmp". This - * will help significantly with the handling of calls to malloc, where it - * is important to have the cast at the same place as the call *) - let collapseCallCast = function - Call(Some(Var vi, NoOffset), f, args, l), - Set(destlv, CastE (newt, Lval(Var vi', NoOffset)), _) - when (not vi.vglob && - String.length vi.vname >= 3 && - (* Watch out for the possibility that we have an implied cast in - * the call *) - (let tcallres = - match unrollType (typeOf f) with - TFun (rt, _, _, _) -> rt - | _ -> E.s (E.bug "Function call to a non-function") - in - Util.equals (typeSig tcallres) (typeSig vi.vtype) && - Util.equals (typeSig newt) (typeSig (typeOfLval destlv))) && - IH.mem callTempVars vi.vid && - vi' == vi) - -> Some [Call(Some destlv, f, args, l)] - | i1,i2 -> None - in - (* First add in the postins *) - let sl = pushPostIns c in - peepHole2 collapseCallCast sl; - { c with stmts = sl; postins = [] } - -(***** Try to suggest a name for the anonymous structures *) -let suggestAnonName (nl: A.name list) = - match nl with - [] -> "" - | (n, _, _, _) :: _ -> n - - -(** Optional constant folding of binary operations *) -let optConstFoldBinOp (machdep: bool) (bop: binop) - (e1: exp) (e2:exp) (t: typ) = - if !lowerConstants then - constFoldBinOp machdep bop e1 e2 t - else - BinOp(bop, e1, e2, t) - -(****** TYPE SPECIFIERS *******) -let rec doSpecList (suggestedAnonName: string) (* This string will be part of - * the names for anonymous - * structures and enums *) - (specs: A.spec_elem list) - (* Returns the base type, the storage, whether it is inline and the - * (unprocessed) attributes *) - : typ * storage * bool * A.attribute list = - (* Do one element and collect the type specifiers *) - let isinline = ref false in (* If inline appears *) - (* The storage is placed here *) - let storage : storage ref = ref NoStorage in - - (* Collect the attributes. Unfortunately, we cannot treat GCC - * __attributes__ and ANSI C const/volatile the same way, since they - * associate with structures differently. Specifically, ANSI - * qualifiers never apply to structures (ISO 6.7.3), whereas GCC - * attributes always do (GCC manual 4.30). Therefore, they are - * collected and processed separately. *) - let attrs : A.attribute list ref = ref [] in (* __attribute__, etc. *) - let cvattrs : A.cvspec list ref = ref [] in (* const/volatile *) - - let doSpecElem (se: A.spec_elem) - (acc: A.typeSpecifier list) - : A.typeSpecifier list = - match se with - A.SpecTypedef -> acc - | A.SpecInline -> isinline := true; acc - | A.SpecStorage st -> - if !storage <> NoStorage then - E.s (error "Multiple storage specifiers"); - let sto' = - match st with - A.NO_STORAGE -> NoStorage - | A.AUTO -> NoStorage - | A.REGISTER -> Register - | A.STATIC -> Static - | A.EXTERN -> Extern - in - storage := sto'; - acc - - | A.SpecCV cv -> cvattrs := cv :: !cvattrs; acc - | A.SpecAttr a -> attrs := a :: !attrs; acc - | A.SpecType ts -> ts :: acc - | A.SpecPattern _ -> E.s (E.bug "SpecPattern in cabs2cil input") - in - (* Now scan the list and collect the type specifiers. Preserve the order *) - let tspecs = List.fold_right doSpecElem specs [] in - - let tspecs' = - (* GCC allows a named type that appears first to be followed by things - * like "short", "signed", "unsigned" or "long". *) - match tspecs with - A.Tnamed n :: (_ :: _ as rest) when not !msvcMode -> - (* If rest contains "short" or "long" then drop the Tnamed *) - if List.exists (function A.Tshort -> true - | A.Tlong -> true | _ -> false) rest then - rest - else - tspecs - - | _ -> tspecs - in - (* Sort the type specifiers *) - let sortedspecs = - let order = function (* Don't change this *) - | A.Tvoid -> 0 - | A.Tsigned -> 1 - | A.Tunsigned -> 2 - | A.Tchar -> 3 - | A.Tshort -> 4 - | A.Tlong -> 5 - | A.Tint -> 6 - | A.Tint64 -> 7 - | A.Tfloat -> 8 - | A.Tdouble -> 9 - | _ -> 10 (* There should be at most one of the others *) - in - List.stable_sort (fun ts1 ts2 -> compare (order ts1) (order ts2)) tspecs' - in - let getTypeAttrs () : A.attribute list = - (* Partitions the attributes in !attrs. - Type attributes are removed from attrs and returned, so that they - can go into the type definition. Name attributes are left in attrs, - so they will be returned by doSpecAttr and used in the variable - declaration. - Testcase: small1/attr9.c *) - let an, af, at = cabsPartitionAttributes ~default:AttrType !attrs in - attrs := an; (* Save the name attributes for later *) - if af <> [] then - E.s (error "Invalid position for function type attributes."); - at - in - - (* And now try to make sense of it. See ISO 6.7.2 *) - let bt = - match sortedspecs with - [A.Tvoid] -> TVoid [] - | [A.Tchar] -> TInt(IChar, []) - | [A.Tsigned; A.Tchar] -> TInt(ISChar, []) - | [A.Tunsigned; A.Tchar] -> TInt(IUChar, []) - - | [A.Tshort] -> TInt(IShort, []) - | [A.Tsigned; A.Tshort] -> TInt(IShort, []) - | [A.Tshort; A.Tint] -> TInt(IShort, []) - | [A.Tsigned; A.Tshort; A.Tint] -> TInt(IShort, []) - - | [A.Tunsigned; A.Tshort] -> TInt(IUShort, []) - | [A.Tunsigned; A.Tshort; A.Tint] -> TInt(IUShort, []) - - | [] -> TInt(IInt, []) - | [A.Tint] -> TInt(IInt, []) - | [A.Tsigned] -> TInt(IInt, []) - | [A.Tsigned; A.Tint] -> TInt(IInt, []) - - | [A.Tunsigned] -> TInt(IUInt, []) - | [A.Tunsigned; A.Tint] -> TInt(IUInt, []) - - | [A.Tlong] -> TInt(ILong, []) - | [A.Tsigned; A.Tlong] -> TInt(ILong, []) - | [A.Tlong; A.Tint] -> TInt(ILong, []) - | [A.Tsigned; A.Tlong; A.Tint] -> TInt(ILong, []) - - | [A.Tunsigned; A.Tlong] -> TInt(IULong, []) - | [A.Tunsigned; A.Tlong; A.Tint] -> TInt(IULong, []) - - | [A.Tlong; A.Tlong] -> TInt(ILongLong, []) - | [A.Tsigned; A.Tlong; A.Tlong] -> TInt(ILongLong, []) - | [A.Tlong; A.Tlong; A.Tint] -> TInt(ILongLong, []) - | [A.Tsigned; A.Tlong; A.Tlong; A.Tint] -> TInt(ILongLong, []) - - | [A.Tunsigned; A.Tlong; A.Tlong] -> TInt(IULongLong, []) - | [A.Tunsigned; A.Tlong; A.Tlong; A.Tint] -> TInt(IULongLong, []) - - (* int64 is to support MSVC *) - | [A.Tint64] -> TInt(ILongLong, []) - | [A.Tsigned; A.Tint64] -> TInt(ILongLong, []) - - | [A.Tunsigned; A.Tint64] -> TInt(IULongLong, []) - - | [A.Tfloat] -> TFloat(FFloat, []) - | [A.Tdouble] -> TFloat(FDouble, []) - - | [A.Tlong; A.Tdouble] -> TFloat(FLongDouble, []) - - (* Now the other type specifiers *) - | [A.Tnamed n] -> begin - if n = "__builtin_va_list" && - Machdep.gccHas__builtin_va_list then begin - TBuiltin_va_list [] - end else - let t = - match lookupType "type" n with - (TNamed _) as x, _ -> x - | typ -> E.s (error "Named type %s is not mapped correctly\n" n) - in - t - end - - | [A.Tstruct (n, None, _)] -> (* A reference to a struct *) - if n = "" then E.s (error "Missing struct tag on incomplete struct"); - findCompType "struct" n [] - | [A.Tstruct (n, Some nglist, extraAttrs)] -> (* A definition of a struct *) - let n' = - if n <> "" then n else anonStructName "struct" suggestedAnonName in - (* Use the (non-cv, non-name) attributes in !attrs now *) - let a = extraAttrs @ (getTypeAttrs ()) in - makeCompType true n' nglist (doAttributes a) - - | [A.Tunion (n, None, _)] -> (* A reference to a union *) - if n = "" then E.s (error "Missing union tag on incomplete union"); - findCompType "union" n [] - | [A.Tunion (n, Some nglist, extraAttrs)] -> (* A definition of a union *) - let n' = - if n <> "" then n else anonStructName "union" suggestedAnonName in - (* Use the attributes now *) - let a = extraAttrs @ (getTypeAttrs ()) in - makeCompType false n' nglist (doAttributes a) - - | [A.Tenum (n, None, _)] -> (* Just a reference to an enum *) - if n = "" then E.s (error "Missing enum tag on incomplete enum"); - findCompType "enum" n [] - - | [A.Tenum (n, Some eil, extraAttrs)] -> (* A definition of an enum *) - let n' = - if n <> "" then n else anonStructName "enum" suggestedAnonName in - (* make a new name for this enumeration *) - let n'', _ = newAlphaName true "enum" n' in - - (* Create the enuminfo, or use one that was created already for a - * forward reference *) - let enum, _ = createEnumInfo n'' in - let a = extraAttrs @ (getTypeAttrs ()) in - enum.eattr <- doAttributes a; - let res = TEnum (enum, []) in - - (* sm: start a scope for the enum tag values, since they * - * can refer to earlier tags *) - enterScope (); - - (* as each name,value pair is determined, this is called *) - let rec processName kname (i: exp) loc rest = begin - (* add the name to the environment, but with a faked 'typ' field; - * we don't know the full type yet (since that includes all of the - * tag values), but we won't need them in here *) - addLocalToEnv kname (EnvEnum (i, res)); - - (* add this tag to the list so that it ends up in the real - * environment when we're finished *) - let newname, _ = newAlphaName true "" kname in - - (kname, (newname, i, loc)) :: loop (increm i 1) rest - end - - and loop i = function - [] -> [] - | (kname, A.NOTHING, cloc) :: rest -> - (* use the passed-in 'i' as the value, since none specified *) - processName kname i (convLoc cloc) rest - - | (kname, e, cloc) :: rest -> - (* constant-eval 'e' to determine tag value *) - let e' = getIntConstExp e in - let e' = - match isInteger (constFold true e') with - Some i -> if !lowerConstants then kinteger64 IInt i else e' - | _ -> E.s (error "Constant initializer %a not an integer" d_exp e') - in - processName kname e' (convLoc cloc) rest - in - - (* sm: now throw away the environment we built for eval'ing the enum - * tags, so we can add to the new one properly *) - exitScope (); - - let fields = loop zero eil in - (* Now set the right set of items *) - enum.eitems <- List.map (fun (_, x) -> x) fields; - (* Record the enum name in the environment *) - addLocalToEnv (kindPlusName "enum" n'') (EnvTyp res); - (* And define the tag *) - cabsPushGlobal (GEnumTag (enum, !currentLoc)); - res - - - | [A.TtypeofE e] -> - let (c, e', t) = doExp false e AExpLeaveArrayFun in - let t' = - match e' with - StartOf(lv) -> typeOfLval lv - (* If this is a string literal, then we treat it as in sizeof*) - | Const (CStr s) -> begin - match typeOf e' with - TPtr(bt, _) -> (* This is the type of array elements *) - TArray(bt, Some (SizeOfStr s), []) - | _ -> E.s (bug "The typeOf a string is not a pointer type") - end - | _ -> t - in -(* - ignore (E.log "typeof(%a) = %a\n" d_exp e' d_plaintype t'); -*) - t' - - | [A.TtypeofT (specs, dt)] -> - let typ = doOnlyType specs dt in - typ - - | _ -> - E.s (error "Invalid combination of type specifiers") - in - bt,!storage,!isinline,List.rev (!attrs @ (convertCVtoAttr !cvattrs)) - -(* given some cv attributes, convert them into named attributes for - * uniform processing *) -and convertCVtoAttr (src: A.cvspec list) : A.attribute list = - match src with - | [] -> [] - | CV_CONST :: tl -> ("const",[]) :: (convertCVtoAttr tl) - | CV_VOLATILE :: tl -> ("volatile",[]) :: (convertCVtoAttr tl) - | CV_RESTRICT :: tl -> ("restrict",[]) :: (convertCVtoAttr tl) - - -and makeVarInfoCabs - ~(isformal: bool) - ~(isglobal: bool) - (ldecl : location) - (bt, sto, inline, attrs) - (n,ndt,a) - : varinfo = - let vtype, nattr = - doType (AttrName false) bt (A.PARENTYPE(attrs, ndt, a)) in - if inline && not (isFunctionType vtype) then - ignore (error "inline for a non-function: %s" n); - let t = - if not isglobal && not isformal then begin - (* Sometimes we call this on the formal argument of a function with no - * arguments. Don't call stripConstLocalType in that case *) -(* ignore (E.log "stripConstLocalType(%a) for %s\n" d_type vtype n); *) - stripConstLocalType vtype - end else - vtype - in - let vi = makeVarinfo isglobal n t in - vi.vstorage <- sto; - vi.vattr <- nattr; - vi.vdecl <- ldecl; - - if false then - ignore (E.log "Created varinfo %s : %a\n" vi.vname d_type vi.vtype); - - vi - -(* Process a local variable declaration and allow variable-sized arrays *) -and makeVarSizeVarInfo (ldecl : location) - spec_res - (n,ndt,a) - : varinfo * chunk * exp * bool = - if not !msvcMode then - match isVariableSizedArray ndt with - None -> - makeVarInfoCabs ~isformal:false - ~isglobal:false - ldecl spec_res (n,ndt,a), empty, zero, false - | Some (ndt', se, len) -> - makeVarInfoCabs ~isformal:false - ~isglobal:false - ldecl spec_res (n,ndt',a), se, len, true - else - makeVarInfoCabs ~isformal:false - ~isglobal:false - ldecl spec_res (n,ndt,a), empty, zero, false - -and doAttr (a: A.attribute) : attribute list = - (* Strip the leading and trailing underscore *) - let stripUnderscore (n: string) : string = - let l = String.length n in - let rec start i = - if i >= l then - E.s (error "Invalid attribute name %s" n); - if String.get n i = '_' then start (i + 1) else i - in - let st = start 0 in - let rec finish i = - (* We know that we will stop at >= st >= 0 *) - if String.get n i = '_' then finish (i - 1) else i - in - let fin = finish (l - 1) in - String.sub n st (fin - st + 1) - in - match a with - | (s, []) -> [Attr (stripUnderscore s, [])] - | (s, el) -> - - let rec attrOfExp (strip: bool) - ?(foldenum=true) - (a: A.expression) : attrparam = - match a with - A.VARIABLE n -> begin - let n' = if strip then stripUnderscore n else n in - (** See if this is an enumeration *) - try - if not foldenum then raise Not_found; - - match H.find env n' with - EnvEnum (tag, _), _ -> begin - match isInteger (constFold true tag) with - Some i64 when !lowerConstants -> AInt (Int64.to_int i64) - | _ -> ACons(n', []) - end - | _ -> ACons (n', []) - with Not_found -> ACons(n', []) - end - | A.CONSTANT (A.CONST_STRING s) -> AStr s - | A.CONSTANT (A.CONST_INT str) -> AInt (int_of_string str) - | A.CALL(A.VARIABLE n, args) -> begin - let n' = if strip then stripUnderscore n else n in - let ae' = List.map ae args in - ACons(n', ae') - end - | A.EXPR_SIZEOF e -> ASizeOfE (ae e) - | A.TYPE_SIZEOF (bt, dt) -> ASizeOf (doOnlyType bt dt) - | A.EXPR_ALIGNOF e -> AAlignOfE (ae e) - | A.TYPE_ALIGNOF (bt, dt) -> AAlignOf (doOnlyType bt dt) - | A.BINARY(A.AND, aa1, aa2) -> - ABinOp(LAnd, ae aa1, ae aa2) - | A.BINARY(A.OR, aa1, aa2) -> - ABinOp(LOr, ae aa1, ae aa2) - | A.BINARY(abop, aa1, aa2) -> - ABinOp (convBinOp abop, ae aa1, ae aa2) - | A.UNARY(A.PLUS, aa) -> ae aa - | A.UNARY(A.MINUS, aa) -> AUnOp (Neg, ae aa) - | A.UNARY(A.BNOT, aa) -> AUnOp(BNot, ae aa) - | A.UNARY(A.NOT, aa) -> AUnOp(LNot, ae aa) - | A.MEMBEROF (e, s) -> ADot (ae e, s) - | _ -> - ignore (E.log "Invalid expression in attribute: "); - withCprint Cprint.print_expression a; - E.s (error "cabs2cil: invalid expression") - - and ae (e: A.expression) = attrOfExp false e in - - (* Sometimes we need to convert attrarg into attr *) - let arg2attr = function - | ACons (s, args) -> Attr (s, args) - | a -> - E.s (error "Invalid form of attribute: %a" - d_attrparam a); - in - if s = "__attribute__" then (* Just a wrapper for many attributes*) - List.map (fun e -> arg2attr (attrOfExp true ~foldenum:false e)) el - else if s = "__blockattribute__" then (* Another wrapper *) - List.map (fun e -> arg2attr (attrOfExp true ~foldenum:false e)) el - else if s = "__declspec" then - List.map (fun e -> arg2attr (attrOfExp false ~foldenum:false e)) el - else - [Attr(stripUnderscore s, List.map (attrOfExp ~foldenum:false false) el)] - -and doAttributes (al: A.attribute list) : attribute list = - List.fold_left (fun acc a -> cabsAddAttributes (doAttr a) acc) [] al - -(* A version of Cil.partitionAttributes that works on CABS attributes. - It would be better to use Cil.partitionAttributes instead to avoid - the extra doAttr conversions here, but that's hard to do in doSpecList.*) -and cabsPartitionAttributes - ~(default:attributeClass) - (attrs: A.attribute list) : - A.attribute list * A.attribute list * A.attribute list = - let rec loop (n,f,t) = function - [] -> n, f, t - | a :: rest -> - let kind = match doAttr a with - [] -> default - | Attr(an, _)::_ -> - (try H.find attributeHash an with Not_found -> default) - in - match kind with - AttrName _ -> loop (a::n, f, t) rest - | AttrFunType _ -> - loop (n, a::f, t) rest - | AttrType -> loop (n, f, a::t) rest - in - loop ([], [], []) attrs - - - -and doType (nameortype: attributeClass) (* This is AttrName if we are doing - * the type for a name, or AttrType - * if we are doing this type in a - * typedef *) - (bt: typ) (* The base type *) - (dt: A.decl_type) - (* Returns the new type and the accumulated name (or type attribute - if nameoftype = AttrType) attributes *) - : typ * attribute list = - - (* Now do the declarator type. But remember that the structure of the - * declarator type is as printed, meaning that it is the reverse of the - * right one *) - let rec doDeclType (bt: typ) (acc: attribute list) = function - A.JUSTBASE -> bt, acc - | A.PARENTYPE (a1, d, a2) -> - let a1' = doAttributes a1 in - let a1n, a1f, a1t = partitionAttributes AttrType a1' in - let a2' = doAttributes a2 in - let a2n, a2f, a2t = partitionAttributes nameortype a2' in -(* - ignore (E.log "doType: %a @[a1n=%a@!a1f=%a@!a1t=%a@!a2n=%a@!a2f=%a@!a2t=%a@]@!" d_loc !currentLoc d_attrlist a1n d_attrlist a1f d_attrlist a1t d_attrlist a2n d_attrlist a2f d_attrlist a2t); -*) - let bt' = cabsTypeAddAttributes a1t bt in -(* - ignore (E.log "bt' = %a\n" d_type bt'); -*) - let bt'', a1fadded = - match unrollType bt with - TFun _ -> cabsTypeAddAttributes a1f bt', true - | _ -> bt', false - in - (* Now recurse *) - let restyp, nattr = doDeclType bt'' acc d in - (* Add some more type attributes *) - let restyp = cabsTypeAddAttributes a2t restyp in - (* See if we can add some more type attributes *) - let restyp' = - match unrollType restyp with - TFun _ -> - if a1fadded then - cabsTypeAddAttributes a2f restyp - else - cabsTypeAddAttributes a2f - (cabsTypeAddAttributes a1f restyp) - | TPtr ((TFun _ as tf), ap) when not !msvcMode -> - if a1fadded then - TPtr(cabsTypeAddAttributes a2f tf, ap) - else - TPtr(cabsTypeAddAttributes a2f - (cabsTypeAddAttributes a1f tf), ap) - | _ -> - if a1f <> [] && not a1fadded then - E.s (error "Invalid position for (prefix) function type attributes:%a" - d_attrlist a1f); - if a2f <> [] then - E.s (error "Invalid position for (post) function type attributes:%a" - d_attrlist a2f); - restyp - in -(* - ignore (E.log "restyp' = %a\n" d_type restyp'); -*) - (* Now add the name attributes and return *) - restyp', cabsAddAttributes a1n (cabsAddAttributes a2n nattr) - - | A.PTR (al, d) -> - let al' = doAttributes al in - let an, af, at = partitionAttributes AttrType al' in - (* Now recurse *) - let restyp, nattr = doDeclType (TPtr(bt, at)) acc d in - (* See if we can do anything with function type attributes *) - let restyp' = - match unrollType restyp with - TFun _ -> cabsTypeAddAttributes af restyp - | TPtr((TFun _ as tf), ap) -> - TPtr(cabsTypeAddAttributes af tf, ap) - | _ -> - if af <> [] then - E.s (error "Invalid position for function type attributes:%a" - d_attrlist af); - restyp - in - (* Now add the name attributes and return *) - restyp', cabsAddAttributes an nattr - - - | A.ARRAY (d, al, len) -> - let lo = - match len with - A.NOTHING -> None - | _ -> - let len' = doPureExp len in - let _, len'' = castTo (typeOf len') intType len' in - let elsz = - try (bitsSizeOf bt + 7) / 8 - with _ -> 1 (** We get this if we cannot compute the size of - * one element. This can happen, when we define - * an extern, for example. We use 1 for now *) - in - (match constFold true len' with - Const(CInt64(i, _, _)) -> - if i < 0L then - E.s (error "Length of array is negative\n"); - if Int64.mul i (Int64.of_int elsz) >= 0x80000000L then - E.s (error "Length of array is too large\n") - - - | l -> - if isConstant l then - (* e.g., there may be a float constant involved. - * We'll leave it to the user to ensure the length is - * non-negative, etc.*) - ignore(warn "Unable to do constant-folding on array length %a. Some CIL operations on this array may fail." - d_exp l) - else - E.s (error "Length of array is not a constant: %a\n" - d_exp l)); - Some len'' - in - let al' = doAttributes al in - doDeclType (TArray(bt, lo, al')) acc d - - | A.PROTO (d, args, isva) -> - (* Start a scope for the parameter names *) - enterScope (); - (* Intercept the old-style use of varargs.h. On GCC this means that - * we have ellipsis and a last argument "builtin_va_alist: - * builtin_va_alist_t". On MSVC we do not have the ellipsis and we - * have a last argument "va_alist: va_list" *) - let args', isva' = - if args != [] && !msvcMode = not isva then begin - let newisva = ref isva in - let rec doLast = function - [([A.SpecType (A.Tnamed atn)], (an, A.JUSTBASE, [], _))] - when isOldStyleVarArgTypeName atn && - isOldStyleVarArgName an -> begin - (* Turn it into a vararg *) - newisva := true; - (* And forget about this argument *) - [] - end - - | a :: rest -> a :: doLast rest - | [] -> [] - in - let args' = doLast args in - (args', !newisva) - end else (args, isva) - in - (* Make the argument as for a formal *) - let doOneArg (s, (n, ndt, a, cloc)) : varinfo = - let s' = doSpecList n s in - let ndt' = match isVariableSizedArray ndt with - None -> ndt - | Some (ndt', se, len) -> - (* If this is a variable-sized array, we replace the array - type with a pointer type. This is the defined behavior - for array parameters, so we do not need to add this to - varSizeArrays, fix sizeofs, etc. *) - if isNotEmpty se then - E.s (error "array parameter: length not pure"); - ndt' - in - let vi = makeVarInfoCabs ~isformal:true ~isglobal:false - (convLoc cloc) s' (n,ndt',a) in - (* Add the formal to the environment, so it can be referenced by - other formals (e.g. in an array type, although that will be - changed to a pointer later, or though typeof). *) - addLocalToEnv vi.vname (EnvVar vi); - vi - in - let targs : varinfo list option = - match List.map doOneArg args' with - | [] -> None (* No argument list *) - | [t] when isVoidType t.vtype -> - Some [] - | l -> Some l - in - exitScope (); - (* Turn [] types into pointers in the arguments and the result type. - * Turn function types into pointers to respective. This simplifies - * our life a lot, and is what the standard requires. *) - let rec fixupArgumentTypes (argidx: int) (args: varinfo list) : unit = - match args with - [] -> () - | a :: args' -> - (match unrollType a.vtype with - TArray(t,_,attr) -> a.vtype <- TPtr(t, attr) - | TFun _ -> a.vtype <- TPtr(a.vtype, []) - | TComp (comp, _) -> begin - match isTransparentUnion a.vtype with - None -> () - | Some fstfield -> - transparentUnionArgs := - (argidx, a.vtype) :: !transparentUnionArgs; - a.vtype <- fstfield.ftype; - end - | _ -> ()); - fixupArgumentTypes (argidx + 1) args' - in - let args = - match targs with - None -> None - | Some argl -> - fixupArgumentTypes 0 argl; - Some (List.map (fun a -> (a.vname, a.vtype, a.vattr)) argl) - in - let tres = - match unrollType bt with - TArray(t,_,attr) -> TPtr(t, attr) - | _ -> bt - in - doDeclType (TFun (tres, args, isva', [])) acc d - - in - doDeclType bt [] dt - -(* If this is a declarator for a variable size array then turn it into a - pointer type and a length *) -and isVariableSizedArray (dt: A.decl_type) - : (A.decl_type * chunk * exp) option = - let res = ref None in - let rec findArray = function - ARRAY (JUSTBASE, al, lo) when lo != A.NOTHING -> - (* Try to compile the expression to a constant *) - let (se, e', _) = doExp true lo (AExp (Some intType)) in - if isNotEmpty se || not (isConstant e') then begin - res := Some (se, e'); - PTR (al, JUSTBASE) - end else - ARRAY (JUSTBASE, al, lo) - | ARRAY (dt, al, lo) -> ARRAY (findArray dt, al, lo) - | PTR (al, dt) -> PTR (al, findArray dt) - | JUSTBASE -> JUSTBASE - | PARENTYPE (prea, dt, posta) -> PARENTYPE (prea, findArray dt, posta) - | PROTO (dt, f, a) -> PROTO (findArray dt, f, a) - in - let dt' = findArray dt in - match !res with - None -> None - | Some (se, e) -> Some (dt', se, e) - -and doOnlyType (specs: A.spec_elem list) (dt: A.decl_type) : typ = - let bt',sto,inl,attrs = doSpecList "" specs in - if sto <> NoStorage || inl then - E.s (error "Storage or inline specifier in type only"); - let tres, nattr = doType AttrType bt' (A.PARENTYPE(attrs, dt, [])) in - if nattr <> [] then - E.s (error "Name attributes in only_type: %a" - d_attrlist nattr); - tres - - -and makeCompType (isstruct: bool) - (n: string) - (nglist: A.field_group list) - (a: attribute list) = - (* Make a new name for the structure *) - let kind = if isstruct then "struct" else "union" in - let n', _ = newAlphaName true kind n in - (* Create the self cell for use in fields and forward references. Or maybe - * one exists already from a forward reference *) - let comp, _ = createCompInfo isstruct n' in - let doFieldGroup ((s: A.spec_elem list), - (nl: (A.name * A.expression option) list)) : 'a list = - (* Do the specifiers exactly once *) - let sugg = match nl with - [] -> "" - | ((n, _, _, _), _) :: _ -> n - in - let bt, sto, inl, attrs = doSpecList sugg s in - (* Do the fields *) - let makeFieldInfo - (((n,ndt,a,cloc) : A.name), (widtho : A.expression option)) - : fieldinfo = - if sto <> NoStorage || inl then - E.s (error "Storage or inline not allowed for fields"); - let ftype, nattr = - doType (AttrName false) bt (A.PARENTYPE(attrs, ndt, a)) in - (* check for fields whose type is an undefined struct. This rules - out circularity: - struct C1 { struct C2 c2; }; //This line is now an error. - struct C2 { struct C1 c1; int dummy; }; - *) - (match unrollType ftype with - TComp (ci',_) when not ci'.cdefined -> - E.s (error "Type of field %s is an undefined struct.\n" n) - | _ -> ()); - let width = - match widtho with - None -> None - | Some w -> begin - (match unrollType ftype with - TInt (ikind, a) -> () - | TEnum _ -> () - | _ -> E.s (error "Base type for bitfield is not an integer type")); - match isIntegerConstant w with - Some n -> Some n - | None -> E.s (error "bitfield width is not an integer constant") - end - in - (* If the field is unnamed and its type is a structure of union type - * then give it a distinguished name *) - let n' = - if n = missingFieldName then begin - match unrollType ftype with - TComp _ -> begin - incr annonCompFieldNameId; - annonCompFieldName ^ (string_of_int !annonCompFieldNameId) - end - | _ -> n - end else - n - in - { fcomp = comp; - fname = n'; - ftype = ftype; - fbitfield = width; - fattr = nattr; - floc = convLoc cloc - } - in - List.map makeFieldInfo nl - in - - - let flds = List.concat (List.map doFieldGroup nglist) in - if comp.cfields <> [] then begin - (* This appears to be a multiply defined structure. This can happen from - * a construct like "typedef struct foo { ... } A, B;". This is dangerous - * because at the time B is processed some forward references in { ... } - * appear as backward references, which coild lead to circularity in - * the type structure. We do a thourough check and then we reuse the type - * for A *) - let fieldsSig fs = List.map (fun f -> typeSig f.ftype) fs in - if not (Util.equals (fieldsSig comp.cfields) (fieldsSig flds)) then - ignore (error "%s seems to be multiply defined" (compFullName comp)) - end else - comp.cfields <- flds; - -(* ignore (E.log "makeComp: %s: %a\n" comp.cname d_attrlist a); *) - comp.cattr <- a; - let res = TComp (comp, []) in - (* This compinfo is defined, even if there are no fields *) - comp.cdefined <- true; - (* Create a typedef for this one *) - cabsPushGlobal (GCompTag (comp, !currentLoc)); - - (* There must be a self cell created for this already *) - addLocalToEnv (kindPlusName kind n) (EnvTyp res); - (* Now create a typedef with just this type *) - res - -and preprocessCast (specs: A.specifier) - (dt: A.decl_type) - (ie: A.init_expression) - : A.specifier * A.decl_type * A.init_expression = - let typ = doOnlyType specs dt in - (* If we are casting to a union type then we have to treat this as a - * constructor expression. This is to handle the gcc extension that allows - * cast from a type of a field to the type of the union *) - let ie' = - match unrollType typ, ie with - TComp (c, _), A.SINGLE_INIT _ when not c.cstruct -> - A.COMPOUND_INIT [(A.INFIELD_INIT ("___matching_field", - A.NEXT_INIT), - ie)] - | _, _ -> ie - in - (* Maybe specs contains an unnamed composite. Replace with the name so that - * when we do again the specs we get the right name *) - let specs1 = - match typ with - TComp (ci, _) -> - List.map - (function - A.SpecType (A.Tstruct ("", flds, [])) -> - A.SpecType (A.Tstruct (ci.cname, None, [])) - | A.SpecType (A.Tunion ("", flds, [])) -> - A.SpecType (A.Tunion (ci.cname, None, [])) - | s -> s) specs - | _ -> specs - in - specs1, dt, ie' - -and getIntConstExp (aexp) : exp = - let c, e, _ = doExp true aexp (AExp None) in - if not (isEmpty c) then - E.s (error "Constant expression %a has effects" d_exp e); - match e with - (* first, filter for those Const exps that are integers *) - | Const (CInt64 _ ) -> e - | Const (CEnum _) -> e - | Const (CChr i) -> Const(charConstToInt i) - - (* other Const expressions are not ok *) - | Const _ -> E.s (error "Expected integer constant and got %a" d_exp e) - - (* now, anything else that 'doExp true' returned is ok (provided - that it didn't yield side effects); this includes, in particular, - the various sizeof and alignof expression kinds *) - | _ -> e - -(* this is like 'isIntConstExp', but retrieves the actual integer - * the expression denotes; I have not extended it to work with - * sizeof/alignof since (for CCured) we can't const-eval those, - * and it's not clear whether they can be bitfield width specifiers - * anyway (since that's where this function is used) *) -and isIntegerConstant (aexp) : int option = - match doExp true aexp (AExp None) with - (c, e, _) when isEmpty c -> begin - match isInteger e with - Some i64 -> Some (Int64.to_int i64) - | _ -> None - end - | _ -> None - - (* Process an expression and in the process do some type checking, - * extract the effects as separate statements *) -and doExp (asconst: bool) (* This expression is used as a constant *) - (e: A.expression) - (what: expAction) : (chunk * exp * typ) = - (* A subexpression of array type is automatically turned into StartOf(e). - * Similarly an expression of function type is turned into AddrOf. So - * essentially doExp should never return things of type TFun or TArray *) - let processArrayFun e t = - match e, unrollType t with - (Lval(lv) | CastE(_, Lval lv)), TArray(tbase, _, a) -> - mkStartOfAndMark lv, TPtr(tbase, a) - | (Lval(lv) | CastE(_, Lval lv)), TFun _ -> - mkAddrOfAndMark lv, TPtr(t, []) - | _, (TArray _ | TFun _) -> - E.s (error "Array or function expression is not lval: %a@!" - d_plainexp e) - | _ -> e, t - in - (* Before we return we call finishExp *) - let finishExp ?(newWhat=what) - (se: chunk) (e: exp) (t: typ) : chunk * exp * typ = - match newWhat with - ADrop -> (se, e, t) - | AExpLeaveArrayFun -> - (se, e, t) (* It is important that we do not do "processArrayFun" in - * this case. We exploit this when we process the typeOf - * construct *) - | AExp _ -> - let (e', t') = processArrayFun e t in -(* - ignore (E.log "finishExp: e'=%a, t'=%a\n" - d_exp e' d_type t'); -*) - (se, e', t') - - | ASet (lv, lvt) -> begin - (* See if the set was done already *) - match e with - Lval(lv') when lv == lv' -> - (se, e, t) - | _ -> - let (e', t') = processArrayFun e t in - let (t'', e'') = castTo t' lvt e' in -(* - ignore (E.log "finishExp: e = %a\n e'' = %a\n" d_plainexp e d_plainexp e''); -*) - (se +++ (Set(lv, e'', !currentLoc)), e'', t'') - end - in - let rec findField (n: string) (fidlist: fieldinfo list) : offset = - (* Depth first search for the field. This appears to be what GCC does. - * MSVC checks that there are no ambiguous field names, so it does not - * matter how we search *) - let rec search = function - [] -> NoOffset (* Did not find *) - | fid :: rest when fid.fname = n -> Field(fid, NoOffset) - | fid :: rest when prefix annonCompFieldName fid.fname -> begin - match unrollType fid.ftype with - TComp (ci, _) -> - let off = search ci.cfields in - if off = NoOffset then - search rest (* Continue searching *) - else - Field (fid, off) - | _ -> E.s (bug "unnamed field type is not a struct/union") - end - | _ :: rest -> search rest - in - let off = search fidlist in - if off = NoOffset then - E.s (error "Cannot find field %s" n); - off - in - try - match e with - | A.NOTHING when what = ADrop -> finishExp empty (integer 0) intType - | A.NOTHING -> - let res = Const(CStr "exp_nothing") in - finishExp empty res (typeOf res) - - (* Do the potential lvalues first *) - | A.VARIABLE n -> begin - (* Look up in the environment *) - try - let envdata = H.find env n in - match envdata with - EnvVar vi, _ -> - (* if isconst && - not (isFunctionType vi.vtype) && - not (isArrayType vi.vtype)then - E.s (error "variable appears in constant"); *) - finishExp empty (Lval(var vi)) vi.vtype - | EnvEnum (tag, typ), _ -> - if !Cil.lowerConstants then - finishExp empty tag typ - else begin - let ei = - match unrollType typ with - TEnum(ei, _) -> ei - | _ -> assert false - in - finishExp empty (Const (CEnum(tag, n, ei))) typ - end - - | _ -> raise Not_found - with Not_found -> begin - if isOldStyleVarArgName n then - 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) - else - E.s (error "Cannot resolve variable %s.\n" n) - end - end - | A.INDEX (e1, e2) -> begin - (* Recall that doExp turns arrays into StartOf pointers *) - let (se1, e1', t1) = doExp false e1 (AExp None) in - let (se2, e2', t2) = doExp false e2 (AExp None) in - let se = se1 @@ se2 in - let (e1'', t1, e2'', tresult) = - (* Either e1 or e2 can be the pointer *) - match unrollType t1, unrollType t2 with - TPtr(t1e,_), (TInt _|TEnum _) -> e1', t1, e2', t1e - | (TInt _|TEnum _), TPtr(t2e,_) -> e2', t2, e1', t2e - | _ -> - E.s (error - "Expecting a pointer type in index:@! t1=%a@!t2=%a@!" - d_plaintype t1 d_plaintype t2) - in - (* We have to distinguish the construction based on the type of e1'' *) - let res = - match e1'' with - StartOf array -> (* A real array indexing operation *) - addOffsetLval (Index(e2'', NoOffset)) array - | _ -> (* Turn into *(e1 + e2) *) - mkMem (BinOp(IndexPI, e1'', e2'', t1)) NoOffset - in - (* Do some optimization of StartOf *) - finishExp se (Lval res) tresult - - end - | A.UNARY (A.MEMOF, e) -> - if asconst then - ignore (warn "MEMOF in constant"); - let (se, e', t) = doExp false e (AExp None) in - let tresult = - match unrollType t with - | TPtr(te, _) -> te - | _ -> E.s (error "Expecting a pointer type in *. Got %a@!" - d_plaintype t) - in - finishExp se - (Lval (mkMem e' NoOffset)) - tresult - - (* e.str = (& e + off(str)). If e = (be + beoff) then e.str = (be - * + beoff + off(str)) *) - | A.MEMBEROF (e, str) -> - (* member of is actually allowed if we only take the address *) - (* if isconst then - E.s (error "MEMBEROF in constant"); *) - let (se, e', t') = doExp false e (AExp None) in - let lv = - match e' with - Lval x -> x - | CastE(_, Lval x) -> x - | _ -> E.s (error "Expected an lval in MEMBEROF (field %s)" str) - in - let field_offset = - match unrollType t' with - TComp (comp, _) -> findField str comp.cfields - | _ -> E.s (error "expecting a struct with field %s" str) - in - let lv' = Lval(addOffsetLval field_offset lv) in - let field_type = typeOf lv' in - finishExp se lv' field_type - - (* e->str = * (e + off(str)) *) - | A.MEMBEROFPTR (e, str) -> - if asconst then - ignore (warn "MEMBEROFPTR in constant"); - let (se, e', t') = doExp false e (AExp None) in - let pointedt = - match unrollType t' with - TPtr(t1, _) -> t1 - | TArray(t1,_,_) -> t1 - | _ -> E.s (error "expecting a pointer to a struct") - in - let field_offset = - match unrollType pointedt with - TComp (comp, _) -> findField str comp.cfields - | x -> - E.s (error - "expecting a struct with field %s. Found %a. t1 is %a" - str d_type x d_type t') - in - let lv' = Lval (mkMem e' field_offset) in - let field_type = typeOf lv' in - finishExp se lv' field_type - - | A.CONSTANT ct -> begin - let hasSuffix str = - let l = String.length str in - fun s -> - let ls = String.length s in - l >= ls && s = String.uppercase (String.sub str (l - ls) ls) - in - match ct with - A.CONST_INT str -> begin - let res = parseInt str in - finishExp empty res (typeOf res) - end - -(* - | A.CONST_WSTRING wstr -> - let len = List.length wstr in - let wchar_t = !wcharType in - (* We will make an array big enough to contain the wide - * characters and the wide-null terminator *) - let ws_t = TArray(wchar_t, Some (integer len), []) in - let ws = - makeGlobalVar ("wide_string" ^ string_of_int !lastStructId) - ws_t - in - ws.vstorage <- Static; - incr lastStructId; - (* Make the initializer. Idx is a wide_char index. *) - let rec loop (idx: int) (s: int64 list) = - match s with - [] -> [] - | wc::rest -> - let wc_cilexp = Const (CInt64(wc, IInt, None)) in - (Index(integer idx, NoOffset), - SingleInit (mkCast wc_cilexp wchar_t)) - :: loop (idx + 1) rest - in - (* Add the definition for the array *) - cabsPushGlobal (GVar(ws, - {init = Some (CompoundInit(ws_t, - loop 0 wstr))}, - !currentLoc)); - finishExp empty (StartOf(Var ws, NoOffset)) - (TPtr(wchar_t, [])) - *) - - | A.CONST_WSTRING (ws: int64 list) -> - let res = Const(CWStr ((* intlist_to_wstring *) ws)) in - finishExp empty res (typeOf res) - - | A.CONST_STRING s -> - (* Maybe we burried __FUNCTION__ in there *) - let s' = - try - let start = String.index s (Char.chr 0) in - let l = String.length s in - let tofind = (String.make 1 (Char.chr 0)) ^ "__FUNCTION__" in - let past = start + String.length tofind in - if past <= l && - String.sub s start (String.length tofind) = tofind then - (if start > 0 then String.sub s 0 start else "") ^ - !currentFunctionFDEC.svar.vname ^ - (if past < l then String.sub s past (l - past) else "") - else - s - with Not_found -> s - in - let res = Const(CStr s') in - finishExp empty res (typeOf res) - - | A.CONST_CHAR char_list -> - let a, b = (interpret_character_constant char_list) in - finishExp empty (Const a) b - - | A.CONST_WCHAR char_list -> - (* matth: I can't see a reason for a list of more than one char - * here, since the kinteger64 below will take only the lower 16 - * bits of value. ('abc' makes sense, because CHAR constants have - * type int, and so more than one char may be needed to represent - * the value. But L'abc' has type wchar, and so is equivalent to - * L'c'). But gcc allows L'abc', so I'll leave this here in case - * I'm missing some architecture dependent behavior. *) - let value = reduce_multichar !wcharType char_list in - let result = kinteger64 !wcharKind value in - finishExp empty result (typeOf result) - - | A.CONST_FLOAT str -> begin - (* Maybe it ends in U or UL. Strip those *) - let l = String.length str in - let hasSuffix = hasSuffix str in - let baseint, kind = - if hasSuffix "L" then - String.sub str 0 (l - 1), FLongDouble - else if hasSuffix "F" then - String.sub str 0 (l - 1), FFloat - else if hasSuffix "D" then - String.sub str 0 (l - 1), FDouble - else - str, FDouble - in - try - finishExp empty - (Const(CReal(float_of_string baseint, kind, - Some str))) - (TFloat(kind,[])) - with e -> begin - ignore (E.log "float_of_string %s (%s)\n" str - (Printexc.to_string e)); - let res = Const(CStr "booo CONS_FLOAT") in - finishExp empty res (typeOf res) - end - end - end - - | A.TYPE_SIZEOF (bt, dt) -> - let typ = doOnlyType bt dt in - finishExp empty (SizeOf(typ)) !typeOfSizeOf - - (* Intercept the sizeof("string") *) - | A.EXPR_SIZEOF (A.CONSTANT (A.CONST_STRING s)) -> begin - (* Process the string first *) - match doExp asconst (A.CONSTANT (A.CONST_STRING s)) (AExp None) with - _, Const(CStr s), _ -> - finishExp empty (SizeOfStr s) !typeOfSizeOf - | _ -> E.s (bug "cabs2cil: sizeOfStr") - end - - | A.EXPR_SIZEOF e -> - (* Allow non-constants in sizeof *) - (* Do not convert arrays and functions into pointers. *) - let (se, e', t) = doExp false e AExpLeaveArrayFun in -(* - ignore (E.log "sizeof: %a e'=%a, t=%a\n" - d_loc !currentLoc d_plainexp e' d_type t); -*) - (* !!!! The book says that the expression is not evaluated, so we - * drop the potential side-effects - if isNotEmpty se then - ignore (warn "Warning: Dropping side-effect in EXPR_SIZEOF\n"); -*) - let size = - match e' with (* If we are taking the sizeof an - * array we must drop the StartOf *) - StartOf(lv) -> SizeOfE (Lval(lv)) - - (* Maybe we are taking the sizeof for a CStr. In that case we - * mean the pointer to the start of the string *) - | Const(CStr _) -> SizeOf (charPtrType) - - (* Maybe we are taking the sizeof a variable-sized array *) - | Lval (Var vi, NoOffset) -> begin - try - IH.find varSizeArrays vi.vid - with Not_found -> SizeOfE e' - end - | _ -> SizeOfE e' - in - finishExp empty size !typeOfSizeOf - - | A.TYPE_ALIGNOF (bt, dt) -> - let typ = doOnlyType bt dt in - finishExp empty (AlignOf(typ)) !typeOfSizeOf - - | A.EXPR_ALIGNOF e -> - let (se, e', t) = doExp false e AExpLeaveArrayFun in - (* !!!! The book says that the expression is not evaluated, so we - * drop the potential side-effects - if isNotEmpty se then - ignore (warn "Warning: Dropping side-effect in EXPR_ALIGNOF\n"); -*) - let e'' = - match e' with (* If we are taking the alignof an - * array we must drop the StartOf *) - StartOf(lv) -> Lval(lv) - - | _ -> e' - in - finishExp empty (AlignOfE(e'')) !typeOfSizeOf - - | A.CAST ((specs, dt), ie) -> - let s', dt', ie' = preprocessCast specs dt ie in - (* We know now that we can do s' and dt' many times *) - let typ = doOnlyType s' dt' in - let what' = - match what with - AExp (Some _) -> AExp (Some typ) - | AExp None -> what - | ADrop | AExpLeaveArrayFun -> what - | ASet (lv, lvt) -> - (* If the cast from typ to lvt would be dropped, then we - * continue with a Set *) - if false && Util.equals (typeSig typ) (typeSig lvt) then - what - else - AExp None (* We'll create a temporary *) - in - (* Remember here if we have done the Set *) - let (se, e', t'), (needcast: bool) = - match ie' with - A.SINGLE_INIT e -> doExp asconst e what', true - - | A.NO_INIT -> E.s (error "missing expression in cast") - - | A.COMPOUND_INIT _ -> begin - (* Pretend that we are declaring and initializing a brand new - * variable *) - let newvar = "__constr_expr_" ^ string_of_int (!constrExprId) in - incr constrExprId; - let spec_res = doSpecList "" s' in - let se1 = - if !scopes == [] then begin - ignore (createGlobal spec_res - ((newvar, dt', [], cabslu), ie')); - empty - end else - createLocal spec_res ((newvar, dt', [], cabslu), ie') - in - (* Now pretend that e is just a reference to the newly created - * variable *) - let se, e', t' = doExp asconst (A.VARIABLE newvar) what' in - (* If typ is an array then the doExp above has already added a - * StartOf. We must undo that now so that it is done once by - * the finishExp at the end of this case *) - let e2, t2 = - match unrollType typ, e' with - TArray _, StartOf lv -> Lval lv, typ - | _, _ -> e', t' - in - (* If we are here, then the type t2 is guaranteed to match the - * type of the expression e2, so we do not need a cast. We have - * to worry about this because otherwise, we might need to cast - * between arrays or structures. *) - (se1 @@ se, e2, t2), false - end - in - let (t'', e'') = - match typ with - TVoid _ when what' = ADrop -> (t', e') (* strange GNU thing *) - | _ -> - (* Do this to check the cast, unless we are sure that we do not - * need the check. *) - let newtyp, newexp = - if needcast then - castTo ~fromsource:true t' typ e' - else - t', e' - in - newtyp, newexp - in - finishExp se e'' t'' - - | A.UNARY(A.MINUS, e) -> - let (se, e', t) = doExp asconst e (AExp None) in - if isIntegralType t then - let tres = integralPromotion t in - let e'' = - match e' with - | Const(CInt64(i, ik, _)) -> kinteger64 ik (Int64.neg i) - | _ -> UnOp(Neg, mkCastT e' t tres, tres) - in - finishExp se e'' tres - else - if isArithmeticType t then - finishExp se (UnOp(Neg,e',t)) t - else - E.s (error "Unary - on a non-arithmetic type") - - | A.UNARY(A.BNOT, e) -> - let (se, e', t) = doExp asconst e (AExp None) in - if isIntegralType t then - let tres = integralPromotion t in - let e'' = UnOp(BNot, mkCastT e' t tres, tres) in - finishExp se e'' tres - else - E.s (error "Unary ~ on a non-integral type") - - | A.UNARY(A.PLUS, e) -> doExp asconst e what - - - | A.UNARY(A.ADDROF, e) -> begin - match e with - A.COMMA el -> (* GCC extension *) - doExp false - (A.COMMA (replaceLastInList el (fun e -> A.UNARY(A.ADDROF, e)))) - what - | A.QUESTION (e1, e2, e3) -> (* GCC extension *) - doExp false - (A.QUESTION (e1, A.UNARY(A.ADDROF, e2), A.UNARY(A.ADDROF, e3))) - what - | A.VARIABLE s when - isOldStyleVarArgName s - && (match !currentFunctionFDEC.svar.vtype with - TFun(_, _, true, _) -> true | _ -> false) -> - (* We are in an old-style variable argument function and we are - * taking the address of the argument that was removed while - * processing the function type. We compute the address based on - * the address of the last real argument *) - if !msvcMode then begin - let rec getLast = function - [] -> E.s (unimp "old-style variable argument function without real arguments") - | [a] -> a - | _ :: rest -> getLast rest - in - let last = getLast !currentFunctionFDEC.sformals in - let res = mkAddrOfAndMark (var last) in - let tres = typeOf res in - let tres', res' = castTo tres (TInt(IULong, [])) res in - (* Now we must add to this address to point to the next - * argument. Round up to a multiple of 4 *) - let sizeOfLast = - (((bitsSizeOf last.vtype) + 31) / 32) * 4 - in - let res'' = - BinOp(PlusA, res', kinteger IULong sizeOfLast, tres') - in - finishExp empty res'' tres' - end else begin (* On GCC the only reliable way to do this is to - * call builtin_next_arg. If we take the address of - * a local we are going to get the address of a copy - * of the local ! *) - - doExp asconst - (A.CALL (A.VARIABLE "__builtin_next_arg", - [A.CONSTANT (A.CONST_INT "0")])) - what - end - - | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *) - A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ | - A.CAST (_, A.COMPOUND_INIT _)) -> begin - let (se, e', t) = doExp false e (AExp None) in - (* ignore (E.log "ADDROF on %a : %a\n" d_plainexp e' - d_plaintype t); *) - match e' with - ( Lval x | CastE(_, Lval x)) -> - finishExp se (mkAddrOfAndMark x) (TPtr(t, [])) - - | StartOf (lv) -> - let tres = TPtr(typeOfLval lv, []) in (* pointer to array *) - finishExp se (mkAddrOfAndMark lv) tres - - (* Function names are converted into pointers to the function. - * Taking the address-of again does not change things *) - | AddrOf (Var v, NoOffset) when isFunctionType v.vtype -> - finishExp se e' t - - | _ -> E.s (error "Expected lval for ADDROF. Got %a@!" - d_plainexp e') - end - | _ -> E.s (error "Unexpected operand for addrof") - end - | A.UNARY((A.PREINCR|A.PREDECR) as uop, e) -> begin - match e with - A.COMMA el -> (* GCC extension *) - doExp asconst - (A.COMMA (replaceLastInList el - (fun e -> A.UNARY(uop, e)))) - what - | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *) - doExp asconst - (A.QUESTION (e1, A.UNARY(uop, e2q), - A.UNARY(uop, e3q))) - what - - | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *) - A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ | - A.CAST _ (* A GCC extension *)) -> begin - let uop' = if uop = A.PREINCR then PlusA else MinusA in - if asconst then - ignore (warn "PREINCR or PREDECR in constant"); - let (se, e', t) = doExp false e (AExp None) in - let lv = - match e' with - Lval x -> x - | CastE (_, Lval x) -> x (* A GCC extension. The operation is - * done at the cast type. The result - * is also of the cast type *) - | _ -> E.s (error "Expected lval for ++ or --") - in - let tresult, result = doBinOp uop' e' t one intType in - finishExp (se +++ (Set(lv, mkCastT result tresult t, - !currentLoc))) - e' - tresult (* Should this be t instead ??? *) - end - | _ -> E.s (error "Unexpected operand for prefix -- or ++") - end - - | A.UNARY((A.POSINCR|A.POSDECR) as uop, e) -> begin - match e with - A.COMMA el -> (* GCC extension *) - doExp asconst - (A.COMMA (replaceLastInList el - (fun e -> A.UNARY(uop, e)))) - what - | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *) - doExp asconst - (A.QUESTION (e1, A.UNARY(uop, e2q), A.UNARY(uop, e3q))) - what - - | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *) - A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ | - A.CAST _ (* A GCC extension *) ) -> begin - if asconst then - ignore (warn "POSTINCR or POSTDECR in constant"); - (* If we do not drop the result then we must save the value *) - let uop' = if uop = A.POSINCR then PlusA else MinusA in - let (se, e', t) = doExp false e (AExp None) in - let lv = - match e' with - Lval x -> x - | CastE (_, Lval x) -> x (* GCC extension. The addition must - * be be done at the cast type. The - * result of this is also of the cast - * type *) - | _ -> E.s (error "Expected lval for ++ or --") - in - let tresult, opresult = doBinOp uop' e' t one intType in - let se', result = - if what <> ADrop then - let tmp = newTempVar t in - se +++ (Set(var tmp, e', !currentLoc)), Lval(var tmp) - else - se, e' - in - finishExp - (se' +++ (Set(lv, mkCastT opresult tresult t, - !currentLoc))) - result - tresult (* Should this be t instead ??? *) - end - | _ -> E.s (error "Unexpected operand for suffix ++ or --") - end - - | A.BINARY(A.ASSIGN, e1, e2) -> begin - match e1 with - A.COMMA el -> (* GCC extension *) - doExp asconst - (A.COMMA (replaceLastInList el - (fun e -> A.BINARY(A.ASSIGN, e, e2)))) - what - | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *) - doExp asconst - (A.QUESTION (e1, A.BINARY(A.ASSIGN, e2q, e2), - A.BINARY(A.ASSIGN, e3q, e2))) - what - | A.CAST (t, A.SINGLE_INIT e) -> (* GCC extension *) - doExp asconst - (A.CAST (t, - A.SINGLE_INIT (A.BINARY(A.ASSIGN, e, - A.CAST (t, A.SINGLE_INIT e2))))) - what - - | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *) - A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ ) -> begin - if asconst then ignore (warn "ASSIGN in constant"); - let (se1, e1', lvt) = doExp false e1 (AExp None) in - let lv = - match e1' with - Lval x -> x - | _ -> E.s (error "Expected lval for assignment. Got %a\n" - d_plainexp e1') - in - let (se2, e'', t'') = doExp false e2 (ASet(lv, lvt)) in - finishExp (se1 @@ se2) e1' lvt - end - | _ -> E.s (error "Invalid left operand for ASSIGN") - end - - | A.BINARY((A.ADD|A.SUB|A.MUL|A.DIV|A.MOD|A.BAND|A.BOR|A.XOR| - A.SHL|A.SHR|A.EQ|A.NE|A.LT|A.GT|A.GE|A.LE) as bop, e1, e2) -> - let bop' = convBinOp bop in - let (se1, e1', t1) = doExp asconst e1 (AExp None) in - let (se2, e2', t2) = doExp asconst e2 (AExp None) in - let tresult, result = doBinOp bop' e1' t1 e2' t2 in - finishExp (se1 @@ se2) result tresult - - (* assignment operators *) - | A.BINARY((A.ADD_ASSIGN|A.SUB_ASSIGN|A.MUL_ASSIGN|A.DIV_ASSIGN| - A.MOD_ASSIGN|A.BAND_ASSIGN|A.BOR_ASSIGN|A.SHL_ASSIGN| - A.SHR_ASSIGN|A.XOR_ASSIGN) as bop, e1, e2) -> begin - match e1 with - A.COMMA el -> (* GCC extension *) - doExp asconst - (A.COMMA (replaceLastInList el - (fun e -> A.BINARY(bop, e, e2)))) - what - | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *) - doExp asconst - (A.QUESTION (e1, A.BINARY(bop, e2q, e2), - A.BINARY(bop, e3q, e2))) - what - - | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *) - A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ | - A.CAST _ (* GCC extension *) ) -> begin - if asconst then - ignore (warn "op_ASSIGN in constant"); - let bop' = match bop with - A.ADD_ASSIGN -> PlusA - | A.SUB_ASSIGN -> MinusA - | A.MUL_ASSIGN -> Mult - | A.DIV_ASSIGN -> Div - | A.MOD_ASSIGN -> Mod - | A.BAND_ASSIGN -> BAnd - | A.BOR_ASSIGN -> BOr - | A.XOR_ASSIGN -> BXor - | A.SHL_ASSIGN -> Shiftlt - | A.SHR_ASSIGN -> Shiftrt - | _ -> E.s (error "binary +=") - in - let (se1, e1', t1) = doExp false e1 (AExp None) in - let lv1 = - match e1' with - Lval x -> x - | CastE (_, Lval x) -> x (* GCC extension. The operation and - * the result are at the cast type *) - | _ -> E.s (error "Expected lval for assignment with arith") - in - let (se2, e2', t2) = doExp false e2 (AExp None) in - let tresult, result = doBinOp bop' e1' t1 e2' t2 in - (* We must cast the result to the type of the lv1, which may be - * different than t1 if lv1 was a Cast *) - let _, result' = castTo tresult (typeOfLval lv1) result in - (* The type of the result is the type of the left-hand side *) - finishExp (se1 @@ se2 +++ - (Set(lv1, result', !currentLoc))) - e1' - t1 - end - | _ -> E.s (error "Unexpected left operand for assignment with arith") - end - - - | A.BINARY((A.AND|A.OR), _, _) | A.UNARY(A.NOT, _) -> begin - let ce = doCondExp asconst e in - (* We must normalize the result to 0 or 1 *) - match ce with - CEExp (se, ((Const _) as c)) -> - finishExp se (if isConstTrue c then one else zero) intType - | CEExp (se, (UnOp(LNot, _, _) as e)) -> - (* already normalized to 0 or 1 *) - finishExp se e intType - | CEExp (se, e) -> - let e' = - let te = typeOf e in - let _, zte = castTo intType te zero in - BinOp(Ne, e, zte, te) - in - finishExp se e' intType - | _ -> - let tmp = var (newTempVar intType) in - finishExp (compileCondExp ce - (empty +++ (Set(tmp, integer 1, - !currentLoc))) - (empty +++ (Set(tmp, integer 0, - !currentLoc)))) - (Lval tmp) - intType - end - - | A.CALL(f, args) -> - if asconst then - ignore (warn "CALL in constant"); - let (sf, f', ft') = - match f with (* Treat the VARIABLE case separate - * becase we might be calling a - * function that does not have a - * prototype. In that case assume it - * takes INTs as arguments *) - A.VARIABLE n -> begin - try - let vi, _ = lookupVar n in - (empty, Lval(var vi), vi.vtype) (* Found. Do not use - * finishExp. Simulate what = - * AExp None *) - with Not_found -> begin - ignore (warnOpt "Calling function %s without prototype." n); - let ftype = TFun(intType, None, false, - [Attr("missingproto",[])]) in - (* Add a prototype to the environment *) - let proto, _ = - makeGlobalVarinfo false (makeGlobalVar n ftype) in - (* Make it EXTERN *) - proto.vstorage <- Extern; - IH.add noProtoFunctions proto.vid true; - (* Add it to the file as well *) - cabsPushGlobal (GVarDecl (proto, !currentLoc)); - (empty, Lval(var proto), ftype) - end - end - | _ -> doExp false f (AExp None) - in - (* Get the result type and the argument types *) - let (resType, argTypes, isvar, f'') = - match unrollType ft' with - TFun(rt,at,isvar,a) -> (rt,at,isvar,f') - | TPtr (t, _) -> begin - match unrollType t with - TFun(rt,at,isvar,a) -> (* Make the function pointer - * explicit *) - let f'' = - match f' with - AddrOf lv -> Lval(lv) - | _ -> Lval(mkMem f' NoOffset) - in - (rt,at,isvar, f'') - | x -> - E.s (error "Unexpected type of the called function %a: %a" - d_exp f' d_type x) - end - | x -> E.s (error "Unexpected type of the called function %a: %a" - d_exp f' d_type x) - in - let argTypesList = argsToList argTypes in - (* Drop certain qualifiers from the result type *) - let resType' = resType in - (* Before we do the arguments we try to intercept a few builtins. For - * these we have defined then with a different type, so we do not - * want to give warnings. We'll just leave the arguments of these - * functions alone*) - let isSpecialBuiltin = - match f'' with - Lval (Var fv, NoOffset) -> - fv.vname = "__builtin_stdarg_start" || - fv.vname = "__builtin_va_arg" || - fv.vname = "__builtin_va_start" || - fv.vname = "__builtin_expect" || - fv.vname = "__builtin_next_arg" - | _ -> false - in - - (** If the "--forceRLArgEval" flag was used, make sure - we evaluate args right-to-left. - Added by Nathan Cooprider. **) - let force_right_to_left_evaluation (c, e, t) = - (* If chunk is empty then it is not already evaluated *) - (* constants don't need to be pulled out *) - if (!forceRLArgEval && (not (isConstant e)) && - (not isSpecialBuiltin)) then - (* create a temporary *) - let tmp = newTempVar t in - (* create an instruction to give the e to the temporary *) - let i = Set(var tmp, e, !currentLoc) in - (* add the instruction to the chunk *) - (* change the expression to be the temporary *) - (c +++ i, (Lval(var tmp)), t) - else - (c, e, t) - in - (* Do the arguments. In REVERSE order !!! Both GCC and MSVC do this *) - let rec loopArgs - : (string * typ * attributes) list * A.expression list - -> (chunk * exp list) = function - | ([], []) -> (empty, []) - - | args, [] -> - if not isSpecialBuiltin then - ignore (warnOpt - "Too few arguments in call to %a." - d_exp f'); - (empty, []) - - | ((_, at, _) :: atypes, a :: args) -> - let (ss, args') = loopArgs (atypes, args) in - (* Do not cast as part of translating the argument. We let - * the castTo to do this work. This was necessary for - * test/small1/union5, in which a transparent union is passed - * as an argument *) - let (sa, a', att) = force_right_to_left_evaluation - (doExp false a (AExp None)) in - let (_, a'') = castTo att at a' in - (ss @@ sa, a'' :: args') - - | ([], args) -> (* No more types *) - if not isvar && argTypes != None && not isSpecialBuiltin then - (* Do not give a warning for functions without a prototype*) - ignore (warnOpt "Too many arguments in call to %a" d_exp f'); - let rec loop = function - [] -> (empty, []) - | a :: args -> - let (ss, args') = loop args in - let (sa, a', at) = force_right_to_left_evaluation - (doExp false a (AExp None)) in - (ss @@ sa, a' :: args') - in - loop args - in - let (sargs, args') = loopArgs (argTypesList, args) in - (* Setup some pointer to the elements of the call. We may change - * these below *) - let prechunk: chunk ref = ref (sf @@ sargs) in (* comes before *) - - (* Do we actually have a call, or an expression? *) - let piscall: bool ref = ref true in - - let pf: exp ref = ref f'' in (* function to call *) - let pargs: exp list ref = ref args' in (* arguments *) - let pis__builtin_va_arg: bool ref = ref false in - let pwhat: expAction ref = ref what in (* what to do with result *) - - let pres: exp ref = ref zero in (* If we do not have a call, this is - * the result *) - let prestype: typ ref = ref intType in - - let rec dropCasts = function CastE (_, e) -> dropCasts e | e -> e in - (* Get the name of the last formal *) - let getNameLastFormal () : string = - match !currentFunctionFDEC.svar.vtype with - TFun(_, Some args, true, _) -> begin - match List.rev args with - (last_par_name, _, _) :: _ -> last_par_name - | _ -> "" - end - | _ -> "" - in - - (* Try to intercept some builtins *) - (match !pf with - Lval(Var fv, NoOffset) -> begin - if fv.vname = "__builtin_va_arg" then begin - match !pargs with - marker :: SizeOf resTyp :: _ -> begin - (* Make a variable of the desired type *) - let destlv, destlvtyp = - match !pwhat with - ASet (lv, lvt) -> lv, lvt - | _ -> var (newTempVar resTyp), resTyp - in - pwhat := (ASet (destlv, destlvtyp)); - pargs := [marker; SizeOf resTyp; AddrOf destlv]; - pis__builtin_va_arg := true; - end - | _ -> - ignore (warn "Invalid call to %s\n" fv.vname); - end else if fv.vname = "__builtin_stdarg_start" then begin - match !pargs with - marker :: last :: [] -> begin - let isOk = - match dropCasts last with - Lval (Var lastv, NoOffset) -> - lastv.vname = getNameLastFormal () - | _ -> false - in - if not isOk then - ignore (warn "The second argument in call to %s should be the last formal argument\n" fv.vname); - - (* Check that "lastv" is indeed the last variable in the - * prototype and then drop it *) - pargs := [ marker ] - end - | _ -> - ignore (warn "Invalid call to %s\n" fv.vname); - - (* We have to turn uses of __builtin_varargs_start into uses - * of __builtin_stdarg_start (because we have dropped the - * __builtin_va_alist argument from this function) *) - - end else if fv.vname = "__builtin_varargs_start" then begin - (* Lookup the prototype for the replacement *) - let v, _ = - try lookupGlobalVar "__builtin_stdarg_start" - with Not_found -> E.s (bug "Cannot find __builtin_stdarg_start to replace %s\n" fv.vname) - in - pf := Lval (var v) - end else if fv.vname = "__builtin_next_arg" then begin - match !pargs with - last :: [] -> begin - let isOk = - match dropCasts last with - Lval (Var lastv, NoOffset) -> - lastv.vname = getNameLastFormal () - | _ -> false - in - if not isOk then - ignore (warn "The argument in call to %s should be the last formal argument\n" fv.vname); - - pargs := [ ] - end - | _ -> - ignore (warn "Invalid call to %s\n" fv.vname); - end else if fv.vname = "__builtin_constant_p" then begin - (* Drop the side-effects *) - prechunk := empty; - - (* Constant-fold the argument and see if it is a constant *) - (match !pargs with - [ arg ] -> begin - match constFold true arg with - Const _ -> piscall := false; - pres := integer 1; - prestype := intType - - | _ -> piscall := false; - pres := integer 0; - prestype := intType - end - | _ -> - ignore (warn "Invalid call to builtin_constant_p")); - end - end - | _ -> ()); - - - (* Now we must finish the call *) - if !piscall then begin - let addCall (calldest: lval option) (res: exp) (t: typ) = - prechunk := !prechunk +++ - (Call(calldest, !pf, !pargs, !currentLoc)); - pres := res; - prestype := t - in - match !pwhat with - ADrop -> addCall None zero intType - - (* Set to a variable of corresponding type *) - | ASet(lv, vtype) -> - (* Make an exception here for __builtin_va_arg *) - if !pis__builtin_va_arg then - addCall None (Lval(lv)) vtype - else - addCall (Some lv) (Lval(lv)) vtype - - | _ -> begin - let tmp, restyp' = - match !pwhat with - AExp (Some t) -> newTempVar t, t - | _ -> newTempVar resType', resType' - in - (* Remember that this variable has been created for this - * specific call. We will use this in collapseCallCast and - * above in finishCall. *) - IH.add callTempVars tmp.vid (); - addCall (Some (var tmp)) (Lval(var tmp)) restyp' - end - end; - - finishExp !prechunk !pres !prestype - - - | A.COMMA el -> - if asconst then - ignore (warn "COMMA in constant"); - let rec loop sofar = function - [e] -> - let (se, e', t') = doExp false e what in (* Pass on the action *) - (sofar @@ se, e', t') -(* - finishExp (sofar @@ se) e' t' (* does not hurt to do it twice. - * GN: it seems it does *) -*) - | e :: rest -> - let (se, _, _) = doExp false e ADrop in - loop (sofar @@ se) rest - | [] -> E.s (error "empty COMMA expression") - in - loop empty el - - | A.QUESTION (e1,e2,e3) when what = ADrop -> - if asconst then - ignore (warn "QUESTION with ADrop in constant"); - let (se3,_,_) = doExp false e3 ADrop in - let se2 = - match e2 with - A.NOTHING -> skipChunk - | _ -> let (se2,_,_) = doExp false e2 ADrop in se2 - in - finishExp (doCondition asconst e1 se2 se3) zero intType - - | A.QUESTION (e1, e2, e3) -> begin (* what is not ADrop *) - (* Compile the conditional expression *) - let ce1 = doCondExp asconst e1 in - (* Now we must find the type of both branches, in order to compute - * the type of the result *) - let se2, e2'o (* is an option. None means use e1 *), t2 = - match e2 with - A.NOTHING -> begin (* The same as the type of e1 *) - match ce1 with - CEExp (_, e1') -> empty, None, typeOf e1' (* Do not promote - to bool *) - | _ -> empty, None, intType - end - | _ -> - let se2, e2', t2 = doExp asconst e2 (AExp None) in - se2, Some e2', t2 - in - (* Do e3 for real *) - let se3, e3', t3 = doExp asconst e3 (AExp None) in - (* Compute the type of the result *) - let tresult = conditionalConversion t2 t3 in - match ce1 with - CEExp (se1, e1') when isConstFalse e1' && canDrop se2 -> - finishExp (se1 @@ se3) (snd (castTo t3 tresult e3')) tresult - | CEExp (se1, e1') when isConstTrue e1' && canDrop se3 -> - begin - match e2'o with - None -> (* use e1' *) - finishExp (se1 @@ se2) (snd (castTo t2 tresult e1')) tresult - | Some e2' -> - finishExp (se1 @@ se2) (snd (castTo t2 tresult e2')) tresult - end - - | _ -> (* Use a conditional *) begin - match e2 with - A.NOTHING -> - let tmp = var (newTempVar tresult) in - let (se1, _, _) = doExp asconst e1 (ASet(tmp, tresult)) in - let (se3, _, _) = doExp asconst e3 (ASet(tmp, tresult)) in - finishExp (se1 @@ ifChunk (Lval(tmp)) lu - skipChunk se3) - (Lval(tmp)) - tresult - | _ -> - let lv, lvt = - match what with - | ASet (lv, lvt) -> lv, lvt - | _ -> - let tmp = newTempVar tresult in - var tmp, tresult - in - (* Now do e2 and e3 for real *) - let (se2, _, _) = doExp asconst e2 (ASet(lv, lvt)) in - let (se3, _, _) = doExp asconst e3 (ASet(lv, lvt)) in - finishExp (doCondition asconst e1 se2 se3) (Lval(lv)) tresult - end - -(* - (* Do these only to collect the types *) - let se2, e2', t2' = - match e2 with - A.NOTHING -> (* A GNU thing. Use e1 as e2 *) - doExp isconst e1 (AExp None) - | _ -> doExp isconst e2 (AExp None) in - (* Do e3 for real *) - let se3, e3', t3' = doExp isconst e3 (AExp None) in - (* Compute the type of the result *) - let tresult = conditionalConversion e2' t2' e3' t3' in - if (isEmpty se2 || e2 = A.NOTHING) - && isEmpty se3 && isconst then begin - (* Use the Question. This allows Question in initializers without - * having to do constant folding *) - let se1, e1', t1 = doExp isconst e1 (AExp None) in - ignore (checkBool t1 e1'); - let e2'' = - if e2 = A.NOTHING then - mkCastT e1' t1 tresult - else mkCastT e2' t2' tresult (* We know se2 is empty *) - in - let e3'' = mkCastT e3' t3' tresult in - let resexp = - match e1' with - Const(CInt64(i, _, _)) when i <> Int64.zero -> e2'' - | Const(CInt64(z, _, _)) when z = Int64.zero -> e3'' - | _ -> Question(e1', e2'', e3'') - in - finishExp se1 resexp tresult - end else begin (* Now use a conditional *) - match e2 with - A.NOTHING -> - let tmp = var (newTempVar tresult) in - let (se1, _, _) = doExp isconst e1 (ASet(tmp, tresult)) in - let (se3, _, _) = doExp isconst e3 (ASet(tmp, tresult)) in - finishExp (se1 @@ ifChunk (Lval(tmp)) lu - skipChunk se3) - (Lval(tmp)) - tresult - | _ -> - let lv, lvt = - match what with - | ASet (lv, lvt) -> lv, lvt - | _ -> - let tmp = newTempVar tresult in - var tmp, tresult - in - (* Now do e2 and e3 for real *) - let (se2, _, _) = doExp isconst e2 (ASet(lv, lvt)) in - let (se3, _, _) = doExp isconst e3 (ASet(lv, lvt)) in - finishExp (doCondition isconst e1 se2 se3) (Lval(lv)) tresult - end -*) - end - - | A.GNU_BODY b -> begin - (* Find the last A.COMPUTATION and remember it. This one is invoked - * on the reversed list of statements. *) - let rec findLastComputation = function - s :: _ -> - let rec findLast = function - A.SEQUENCE (_, s, loc) -> findLast s - | CASE (_, s, _) -> findLast s - | CASERANGE (_, _, s, _) -> findLast s - | LABEL (_, s, _) -> findLast s - | (A.COMPUTATION _) as s -> s - | _ -> raise Not_found - in - findLast s - | [] -> raise Not_found - in - (* Save the previous data *) - let old_gnu = ! gnu_body_result in - let lastComp, isvoidbody = - match what with - ADrop -> (* We are dropping the result *) - A.NOP cabslu, true - | _ -> - try findLastComputation (List.rev b.A.bstmts), false - with Not_found -> - E.s (error "Cannot find COMPUTATION in GNU.body") - (* A.NOP cabslu, true *) - in - (* Prepare some data to be filled by doExp *) - let data : (exp * typ) option ref = ref None in - gnu_body_result := (lastComp, data); - - let se = doBody b in - - gnu_body_result := old_gnu; - match !data with - None when isvoidbody -> finishExp se zero voidType - | None -> E.s (bug "Cannot find COMPUTATION in GNU.body") - | Some (e, t) -> finishExp se e t - end - - | A.LABELADDR l -> begin (* GCC's taking the address of a label *) - let l = lookupLabel l in (* To support locallly declared labels *) - let addrval = - try H.find gotoTargetHash l - with Not_found -> begin - let res = !gotoTargetNextAddr in - incr gotoTargetNextAddr; - H.add gotoTargetHash l res; - res - end - in - finishExp empty (mkCast (integer addrval) voidPtrType) voidPtrType - end - - | A.EXPR_PATTERN _ -> E.s (E.bug "EXPR_PATTERN in cabs2cil input") - - with e -> begin - ignore (E.log "error in doExp (%s)@!" (Printexc.to_string e)); - E.hadErrors := true; - (i2c (dInstr (dprintf "booo_exp(%t)" d_thisloc) !currentLoc), - integer 0, intType) - end - -(* bop is always the arithmetic version. Change it to the appropriate pointer - * version if necessary *) -and doBinOp (bop: binop) (e1: exp) (t1: typ) (e2: exp) (t2: typ) : typ * exp = - let doArithmetic () = - let tres = arithmeticConversion t1 t2 in - (* Keep the operator since it is arithmetic *) - tres, - optConstFoldBinOp false bop (mkCastT e1 t1 tres) (mkCastT e2 t2 tres) tres - in - let doArithmeticComp () = - let tres = arithmeticConversion t1 t2 in - (* Keep the operator since it is arithemtic *) - intType, - optConstFoldBinOp false bop - (mkCastT e1 t1 tres) (mkCastT e2 t2 tres) intType - in - let doIntegralArithmetic () = - let tres = unrollType (arithmeticConversion t1 t2) in - match tres with - TInt _ -> - tres, - optConstFoldBinOp false bop - (mkCastT e1 t1 tres) (mkCastT e2 t2 tres) tres - | _ -> E.s (error "%a operator on a non-integer type" d_binop bop) - in - let pointerComparison e1 t1 e2 t2 = - (* XL: Do not cast both sides -- what's the point? *) - intType, - optConstFoldBinOp false bop e1 e2 intType - in - - match bop with - (Mult|Div) -> doArithmetic () - | (Mod|BAnd|BOr|BXor) -> doIntegralArithmetic () - | (Shiftlt|Shiftrt) -> (* ISO 6.5.7. Only integral promotions. The result - * has the same type as the left hand side *) - if !msvcMode then - (* MSVC has a bug. We duplicate it here *) - doIntegralArithmetic () - else - let t1' = integralPromotion t1 in - let t2' = integralPromotion t2 in - t1', - optConstFoldBinOp false bop (mkCastT e1 t1 t1') (mkCastT e2 t2 t2') t1' - - | (PlusA|MinusA) - when isArithmeticType t1 && isArithmeticType t2 -> doArithmetic () - | (Eq|Ne|Lt|Le|Ge|Gt) - when isArithmeticType t1 && isArithmeticType t2 -> - doArithmeticComp () - | PlusA when isPointerType t1 && isIntegralType t2 -> - t1, - optConstFoldBinOp false PlusPI e1 - (mkCastT e2 t2 (integralPromotion t2)) t1 - | PlusA when isIntegralType t1 && isPointerType t2 -> - t2, - optConstFoldBinOp false PlusPI e2 - (mkCastT e1 t1 (integralPromotion t1)) t2 - | MinusA when isPointerType t1 && isIntegralType t2 -> - t1, - optConstFoldBinOp false MinusPI e1 - (mkCastT e2 t2 (integralPromotion t2)) t1 - | MinusA when isPointerType t1 && isPointerType t2 -> - let commontype = t1 in - intType, - optConstFoldBinOp false MinusPP (mkCastT e1 t1 commontype) - (mkCastT e2 t2 commontype) intType - | (Le|Lt|Ge|Gt|Eq|Ne) when isPointerType t1 && isPointerType t2 -> - pointerComparison e1 t1 e2 t2 - | (Eq|Ne) when isPointerType t1 && isZero e2 -> - pointerComparison e1 t1 (mkCastT zero !upointType t1) t1 - | (Eq|Ne) when isPointerType t2 && isZero e1 -> - pointerComparison (mkCastT zero !upointType t2) t2 e2 t2 - - - | (Eq|Ne|Le|Lt|Ge|Gt) when isPointerType t1 && isArithmeticType t2 -> - ignore (warnOpt "Comparison of pointer and non-pointer"); - (* Cast both values to void * *) - doBinOp bop (mkCastT e1 t1 voidPtrType) voidPtrType - (mkCastT e2 t2 voidPtrType) voidPtrType - | (Eq|Ne|Le|Lt|Ge|Gt) when isArithmeticType t1 && isPointerType t2 -> - ignore (warnOpt "Comparison of pointer and non-pointer"); - (* Cast both values to void * *) - doBinOp bop (mkCastT e1 t1 voidPtrType) voidPtrType - (mkCastT e2 t2 voidPtrType) voidPtrType - - | _ -> E.s (error "doBinOp: %a\n" d_plainexp (BinOp(bop,e1,e2,intType))) - -(* Constant fold a conditional. This is because we want to avoid having - * conditionals in the initializers. So, we try very hard to avoid creating - * new statements. *) -and doCondExp (asconst: bool) (** Try to evaluate the conditional expression - * to TRUE or FALSE, because it occurs in a - * constant *) - (e: A.expression) : condExpRes = - let rec addChunkBeforeCE (c0: chunk) = function - CEExp (c, e) -> CEExp (c0 @@ c, e) - | CEAnd (ce1, ce2) -> CEAnd (addChunkBeforeCE c0 ce1, ce2) - | CEOr (ce1, ce2) -> CEOr (addChunkBeforeCE c0 ce1, ce2) - | CENot ce1 -> CENot (addChunkBeforeCE c0 ce1) - in - let rec canDropCE = function - CEExp (c, e) -> canDrop c - | CEAnd (ce1, ce2) | CEOr (ce1, ce2) -> canDropCE ce1 && canDropCE ce2 - | CENot (ce1) -> canDropCE ce1 - in - match e with - A.BINARY (A.AND, e1, e2) -> begin - let ce1 = doCondExp asconst e1 in - let ce2 = doCondExp asconst e2 in - match ce1, ce2 with - CEExp (se1, ((Const _) as ci1)), _ -> - if isConstTrue ci1 then - addChunkBeforeCE se1 ce2 - else - (* se2 might contain labels so we cannot always drop it *) - if canDropCE ce2 then - ce1 - else - CEAnd (ce1, ce2) - | CEExp(se1, e1'), CEExp (se2, e2') when - !useLogicalOperators && isEmpty se1 && isEmpty se2 -> - CEExp (empty, BinOp(LAnd, - mkCast e1' intType, - mkCast e2' intType, intType)) - | _ -> CEAnd (ce1, ce2) - end - - | A.BINARY (A.OR, e1, e2) -> begin - let ce1 = doCondExp asconst e1 in - let ce2 = doCondExp asconst e2 in - match ce1, ce2 with - CEExp (se1, (Const(CInt64 _) as ci1)), _ -> - if isConstFalse ci1 then - addChunkBeforeCE se1 ce2 - else - (* se2 might contain labels so we cannot drop it *) - if canDropCE ce2 then - ce1 - else - CEOr (ce1, ce2) - - | CEExp (se1, e1'), CEExp (se2, e2') when - !useLogicalOperators && isEmpty se1 && isEmpty se2 -> - CEExp (empty, BinOp(LOr, mkCast e1' intType, - mkCast e2' intType, intType)) - | _ -> CEOr (ce1, ce2) - end - - | A.UNARY(A.NOT, e1) -> begin - match doCondExp asconst e1 with - CEExp (se1, (Const _ as ci1)) -> - if isConstFalse ci1 then - CEExp (se1, one) - else - CEExp (se1, zero) - | CEExp (se1, e) when isEmpty se1 -> - let t = typeOf e in - if not ((isPointerType t) || (isArithmeticType t))then - E.s (error "Bad operand to !"); - CEExp (empty, UnOp(LNot, e, intType)) - - | ce1 -> CENot ce1 - end - - | _ -> - let (se, e, t) = doExp asconst e (AExp None) in - ignore (checkBool t e); - CEExp (se, if !lowerConstants then constFold asconst e else e) - -and compileCondExp (ce: condExpRes) (st: chunk) (sf: chunk) : chunk = - match ce with - | CEAnd (ce1, ce2) -> - let (sf1, sf2) = - (* If sf is small then will copy it *) - try (sf, duplicateChunk sf) - with Failure _ -> - let lab = newLabelName "_L" in - (gotoChunk lab lu, consLabel lab sf !currentLoc false) - in - let st' = compileCondExp ce2 st sf1 in - let sf' = sf2 in - compileCondExp ce1 st' sf' - - | CEOr (ce1, ce2) -> - let (st1, st2) = - (* If st is small then will copy it *) - try (st, duplicateChunk st) - with Failure _ -> - let lab = newLabelName "_L" in - (gotoChunk lab lu, consLabel lab st !currentLoc false) - in - let st' = st1 in - let sf' = compileCondExp ce2 st2 sf in - compileCondExp ce1 st' sf' - - | CENot ce1 -> compileCondExp ce1 sf st - - | CEExp (se, e) -> begin - match e with - Const(CInt64(i,_,_)) when i <> Int64.zero && canDrop sf -> se @@ st - | Const(CInt64(z,_,_)) when z = Int64.zero && canDrop st -> se @@ sf - | _ -> se @@ ifChunk e !currentLoc st sf - end - - -(* A special case for conditionals *) -and doCondition (isconst: bool) (* If we are in constants, we do our best to - * eliminate the conditional *) - (e: A.expression) - (st: chunk) - (sf: chunk) : chunk = - compileCondExp (doCondExp isconst e) st sf - - -and doPureExp (e : A.expression) : exp = - let (se, e', _) = doExp true e (AExp None) in - if isNotEmpty se then - E.s (error "doPureExp: not pure"); - e' - -and doInitializer - (vi: varinfo) - (inite: A.init_expression) - (* Return the accumulated chunk, the initializer and the new type (might be - * different for arrays) *) - : chunk * init * typ = - - (* Setup the pre-initializer *) - let topPreInit = ref NoInitPre in - if debugInit then - ignore (E.log "\nStarting a new initializer for %s : %a\n" - vi.vname d_type vi.vtype); - let topSetupInit (o: offset) (e: exp) = - if debugInit then - ignore (E.log " set %a := %a\n" d_lval (Var vi, o) d_exp e); - let newinit = setOneInit !topPreInit o e in - if newinit != !topPreInit then topPreInit := newinit - in - let acc, restl = - let so = makeSubobj vi vi.vtype NoOffset in - doInit vi.vglob topSetupInit so empty [ (A.NEXT_INIT, inite) ] - in - if restl <> [] then - ignore (warn "Ignoring some initializers"); - (* sm: we used to do array-size fixups here, but they only worked - * for toplevel array types; now, collectInitializer does the job, - * including for nested array types *) - let typ' = unrollType vi.vtype in - if debugInit then - ignore (E.log "Collecting the initializer for %s\n" vi.vname); - let (init, typ'') = collectInitializer !topPreInit typ' in - if debugInit then - ignore (E.log "Finished the initializer for %s\n init=%a\n typ=%a\n acc=%a\n" - vi.vname d_init init d_type typ' d_chunk acc); - acc, init, typ'' - - - -(* Consume some initializers. Watch out here. Make sure we use only - * tail-recursion because these things can be big. *) -and doInit - (isconst: bool) - (setone: offset -> exp -> unit) (* Use to announce an intializer *) - (so: subobj) - (acc: chunk) - (initl: (A.initwhat * A.init_expression) list) - - (* Return the resulting chunk along with some unused initializers *) - : chunk * (A.initwhat * A.init_expression) list = - - let whoami () = d_lval () (Var so.host, so.soOff) in - - let initl1 = - match initl with - | (A.NEXT_INIT, - A.SINGLE_INIT (A.CAST ((s, dt), ie))) :: rest -> - let s', dt', ie' = preprocessCast s dt ie in - (A.NEXT_INIT, A.SINGLE_INIT (A.CAST ((s', dt'), ie'))) :: rest - | _ -> initl - in - (* Sometimes we have a cast in front of a compound (in GCC). This - * appears as a single initializer. Ignore the cast *) - let initl2 = - match initl1 with - (what, - A.SINGLE_INIT (A.CAST (_, A.COMPOUND_INIT ci))) :: rest -> - (what, A.COMPOUND_INIT ci) :: rest - | _ -> initl1 - in - let allinitl = initl2 in - - if debugInit then begin - ignore (E.log "doInit for %t %s (current %a). Looking at: " whoami - (if so.eof then "(eof)" else "") - d_lval (Var so.host, so.curOff)); - (match allinitl with - [] -> ignore (E.log "[]") - | (what, ie) :: _ -> - withCprint - Cprint.print_init_expression (A.COMPOUND_INIT [(what, ie)])); - ignore (E.log "\n"); - end; - match unrollType so.soTyp, allinitl with - _, [] -> acc, [] (* No more initializers return *) - - (* No more subobjects *) - | _, (A.NEXT_INIT, _) :: _ when so.eof -> acc, allinitl - - - (* If we are at an array of characters and the initializer is a - * string literal (optionally enclosed in braces) then explode the - * string into characters *) - | TArray(bt, leno, _), - (A.NEXT_INIT, - (A.SINGLE_INIT(A.CONSTANT (A.CONST_STRING s))| - A.COMPOUND_INIT - [(A.NEXT_INIT, - A.SINGLE_INIT(A.CONSTANT - (A.CONST_STRING s)))])) :: restil - when (match unrollType bt with - TInt((IChar|IUChar|ISChar), _) -> true - | TInt _ -> - (*Base type is a scalar other than char. Maybe a wchar_t?*) - E.s (error "Using a string literal to initialize something other than a character array.\n") - | _ -> false (* OK, this is probably an array of strings. Handle *) - ) (* it with the other arrays below.*) - -> - let charinits = - let init c = A.NEXT_INIT, A.SINGLE_INIT(A.CONSTANT (A.CONST_CHAR [c])) - in - let collector = - (* ISO 6.7.8 para 14: final NUL added only if no size specified, or - * if there is room for it; btw, we can't rely on zero-init of - * globals, since this array might be a local variable *) - if ((isNone leno) or ((String.length s) < (integerArrayLength leno))) - then ref [init Int64.zero] - else ref [] - in - for pos = String.length s - 1 downto 0 do - collector := init (Int64.of_int (Char.code (s.[pos]))) :: !collector - done; - !collector - in - (* Create a separate object for the array *) - let so' = makeSubobj so.host so.soTyp so.soOff in - (* Go inside the array *) - let leno = integerArrayLength leno in - so'.stack <- [InArray(so'.curOff, bt, leno, ref 0)]; - normalSubobj so'; - let acc', initl' = doInit isconst setone so' acc charinits in - if initl' <> [] then - ignore (warn "Too many initializers for character array %t" whoami); - (* Advance past the array *) - advanceSubobj so; - (* Continue *) - let res = doInit isconst setone so acc' restil in - res - - (* If we are at an array of WIDE characters and the initializer is a - * WIDE string literal (optionally enclosed in braces) then explore - * the WIDE string into characters *) - (* [weimer] Wed Jan 30 15:38:05 PST 2002 - * Despite what the compiler says, this match case is used and it is - * important. *) - | TArray(bt, leno, _), - (A.NEXT_INIT, - (A.SINGLE_INIT(A.CONSTANT (A.CONST_WSTRING s)) | - A.COMPOUND_INIT - [(A.NEXT_INIT, - A.SINGLE_INIT(A.CONSTANT - (A.CONST_WSTRING s)))])) :: restil - when(let bt' = unrollType bt in - match bt' with - (* compare bt to wchar_t, ignoring signed vs. unsigned *) - TInt _ when (bitsSizeOf bt') = (bitsSizeOf !wcharType) -> true - | TInt _ -> - (*Base type is a scalar other than wchar_t. Maybe a char?*) - E.s (error "Using a wide string literal to initialize something other than a wchar_t array.\n") - | _ -> false (* OK, this is probably an array of strings. Handle *) - ) (* it with the other arrays below.*) - -> - let maxWChar = (* (2**(bitsSizeOf !wcharType)) - 1 *) - Int64.sub (Int64.shift_left Int64.one (bitsSizeOf !wcharType)) - Int64.one in - let charinits = - let init c = - if (compare c maxWChar > 0) then (* if c > maxWChar *) - E.s (error "cab2cil:doInit:character 0x%Lx too big." c); - A.NEXT_INIT, - A.SINGLE_INIT(A.CONSTANT (A.CONST_INT (Int64.to_string c))) - in - (List.map init s) @ - ( - (* ISO 6.7.8 para 14: final NUL added only if no size specified, or - * if there is room for it; btw, we can't rely on zero-init of - * globals, since this array might be a local variable *) - if ((isNone leno) or ((List.length s) < (integerArrayLength leno))) - then [init Int64.zero] - else []) -(* - List.map - (fun c -> - if (compare c maxWChar > 0) then (* if c > maxWChar *) - E.s (error "cab2cil:doInit:character 0x%Lx too big." c) - else - (A.NEXT_INIT, - A.SINGLE_INIT(A.CONSTANT (A.CONST_INT (Int64.to_string c))))) - s -*) - in - (* Create a separate object for the array *) - let so' = makeSubobj so.host so.soTyp so.soOff in - (* Go inside the array *) - let leno = integerArrayLength leno in - so'.stack <- [InArray(so'.curOff, bt, leno, ref 0)]; - normalSubobj so'; - let acc', initl' = doInit isconst setone so' acc charinits in - if initl' <> [] then - (* sm: see above regarding ISO 6.7.8 para 14, which is not implemented - * for wchar_t because, as far as I can tell, we don't even put in - * the automatic NUL (!) *) - ignore (warn "Too many initializers for wchar_t array %t" whoami); - (* Advance past the array *) - advanceSubobj so; - (* Continue *) - doInit isconst setone so acc' restil - - (* If we are at an array and we see a single initializer then it must - * be one for the first element *) - | TArray(bt, leno, al), (A.NEXT_INIT, A.SINGLE_INIT oneinit) :: restil -> - (* Grab the length if there is one *) - let leno = integerArrayLength leno in - so.stack <- InArray(so.soOff, bt, leno, ref 0) :: so.stack; - normalSubobj so; - (* Start over with the fields *) - doInit isconst setone so acc allinitl - - (* If we are at a composite and we see a single initializer of the same - * type as the composite then grab it all. If the type is not the same - * then we must go on and try to initialize the fields *) - | TComp (comp, _), (A.NEXT_INIT, A.SINGLE_INIT oneinit) :: restil -> - let se, oneinit', t' = doExp isconst oneinit (AExp None) in - if (match unrollType t' with - TComp (comp', _) when comp'.ckey = comp.ckey -> true - | _ -> false) - then begin - (* Initialize the whole struct *) - setone so.soOff oneinit'; - (* Advance to the next subobject *) - advanceSubobj so; - doInit isconst setone so (acc @@ se) restil - end else begin (* Try to initialize fields *) - let toinit = fieldsToInit comp None in - so.stack <- InComp(so.soOff, comp, toinit) :: so.stack; - normalSubobj so; - doInit isconst setone so acc allinitl - end - - (* A scalar with a single initializer *) - | _, (A.NEXT_INIT, A.SINGLE_INIT oneinit) :: restil -> - let se, oneinit', t' = doExp isconst oneinit (AExp(Some so.soTyp)) in -(* - ignore (E.log "oneinit'=%a, t'=%a, so.soTyp=%a\n" - d_exp oneinit' d_type t' d_type so.soTyp); -*) - setone so.soOff (mkCastT oneinit' t' so.soTyp); - (* Move on *) - advanceSubobj so; - doInit isconst setone so (acc @@ se) restil - - - (* An array with a compound initializer. The initializer is for the - * array elements *) - | TArray (bt, leno, _), (A.NEXT_INIT, A.COMPOUND_INIT initl) :: restil -> - (* Create a separate object for the array *) - let so' = makeSubobj so.host so.soTyp so.soOff in - (* Go inside the array *) - let leno = integerArrayLength leno in - so'.stack <- [InArray(so'.curOff, bt, leno, ref 0)]; - normalSubobj so'; - let acc', initl' = doInit isconst setone so' acc initl in - if initl' <> [] then - ignore (warn "Too many initializers for array %t" whoami); - (* Advance past the array *) - advanceSubobj so; - (* Continue *) - let res = doInit isconst setone so acc' restil in - res - - (* We have a designator that tells us to select the matching union field. - * This is to support a GCC extension *) - | TComp(ci, _), [(A.NEXT_INIT, - A.COMPOUND_INIT [(A.INFIELD_INIT ("___matching_field", - A.NEXT_INIT), - A.SINGLE_INIT oneinit)])] - when not ci.cstruct -> - (* Do the expression to find its type *) - let _, _, t' = doExp isconst oneinit (AExp None) in - let tsig = typeSigWithAttrs (fun _ -> []) t' in - let rec findField = function - [] -> E.s (error "Cannot find matching union field in cast") - | fi :: rest - when Util.equals (typeSigWithAttrs (fun _ -> []) fi.ftype) tsig - -> fi - | _ :: rest -> findField rest - in - let fi = findField ci.cfields in - (* Change the designator and redo *) - doInit isconst setone so acc [(A.INFIELD_INIT (fi.fname, A.NEXT_INIT), - A.SINGLE_INIT oneinit)] - - - (* A structure with a composite initializer. We initialize the fields*) - | TComp (comp, _), (A.NEXT_INIT, A.COMPOUND_INIT initl) :: restil -> - (* Create a separate subobject iterator *) - let so' = makeSubobj so.host so.soTyp so.soOff in - (* Go inside the comp *) - so'.stack <- [InComp(so'.curOff, comp, fieldsToInit comp None)]; - normalSubobj so'; - let acc', initl' = doInit isconst setone so' acc initl in - if initl' <> [] then - ignore (warn "Too many initializers for structure"); - (* Advance past the structure *) - advanceSubobj so; - (* Continue *) - doInit isconst setone so acc' restil - - (* A scalar with a initializer surrounded by braces *) - | _, (A.NEXT_INIT, A.COMPOUND_INIT [(A.NEXT_INIT, - A.SINGLE_INIT oneinit)]) :: restil -> - let se, oneinit', t' = doExp isconst oneinit (AExp(Some so.soTyp)) in - setone so.soOff (mkCastT oneinit' t' so.soTyp); - (* Move on *) - advanceSubobj so; - doInit isconst setone so (acc @@ se) restil - - | t, (A.NEXT_INIT, _) :: _ -> - E.s (unimp "doInit: unexpected NEXT_INIT for %a\n" d_type t); - - (* We have a designator *) - | _, (what, ie) :: restil when what != A.NEXT_INIT -> - (* Process a designator and position to the designated subobject *) - let rec addressSubobj - (so: subobj) - (what: A.initwhat) - (acc: chunk) : chunk = - (* Always start from the current element *) - so.stack <- []; so.eof <- false; - normalSubobj so; - let rec address (what: A.initwhat) (acc: chunk) : chunk = - match what with - A.NEXT_INIT -> acc - | A.INFIELD_INIT (fn, whatnext) -> begin - match unrollType so.soTyp with - TComp (comp, _) -> - let toinit = fieldsToInit comp (Some fn) in - so.stack <- InComp(so.soOff, comp, toinit) :: so.stack; - normalSubobj so; - address whatnext acc - - | _ -> E.s (error "Field designator %s not in a struct " fn) - end - - | A.ATINDEX_INIT(idx, whatnext) -> begin - match unrollType so.soTyp with - TArray (bt, leno, _) -> - let ilen = integerArrayLength leno in - let nextidx', doidx = - let (doidx, idxe', _) = - doExp true idx (AExp(Some intType)) in - match constFold true idxe', isNotEmpty doidx with - Const(CInt64(x, _, _)), false -> Int64.to_int x, doidx - | _ -> E.s (error - "INDEX initialization designator is not a constant") - in - if nextidx' < 0 || nextidx' >= ilen then - E.s (error "INDEX designator is outside bounds"); - so.stack <- - InArray(so.soOff, bt, ilen, ref nextidx') :: so.stack; - normalSubobj so; - address whatnext (acc @@ doidx) - - | _ -> E.s (error "INDEX designator for a non-array") - end - - | A.ATINDEXRANGE_INIT _ -> - E.s (bug "addressSubobj: INDEXRANGE") - in - address what acc - in - (* First expand the INDEXRANGE by making copies *) - let rec expandRange (top: A.initwhat -> A.initwhat) = function - | A.INFIELD_INIT (fn, whatnext) -> - expandRange (fun what -> top (A.INFIELD_INIT(fn, what))) whatnext - | A.ATINDEX_INIT (idx, whatnext) -> - expandRange (fun what -> top (A.ATINDEX_INIT(idx, what))) whatnext - - | A.ATINDEXRANGE_INIT (idxs, idxe) -> - let (doidxs, idxs', _) = - doExp true idxs (AExp(Some intType)) in - let (doidxe, idxe', _) = - doExp true idxe (AExp(Some intType)) in - if isNotEmpty doidxs || isNotEmpty doidxe then - E.s (error "Range designators are not constants\n"); - let first, last = - match constFold true idxs', constFold true idxe' with - Const(CInt64(s, _, _)), - Const(CInt64(e, _, _)) -> - Int64.to_int s, Int64.to_int e - | _ -> E.s (error - "INDEX_RANGE initialization designator is not a constant") - in - if first < 0 || first > last then - E.s (error - "start index larger than end index in range initializer"); - let rec loop (i: int) = - if i > last then restil - else - (top (A.ATINDEX_INIT(A.CONSTANT(A.CONST_INT(string_of_int i)), - A.NEXT_INIT)), ie) - :: loop (i + 1) - in - doInit isconst setone so acc (loop first) - - | A.NEXT_INIT -> (* We have not found any RANGE *) - let acc' = addressSubobj so what acc in - doInit isconst setone so (acc @@ acc') - ((A.NEXT_INIT, ie) :: restil) - in - expandRange (fun x -> x) what - - | t, (what, ie) :: _ -> - E.s (bug "doInit: cases for t=%a" d_type t) - - -(* Create and add to the file (if not already added) a global. Return the - * varinfo *) -and createGlobal (specs : (typ * storage * bool * A.attribute list)) - (((n,ndt,a,cloc), inite) : A.init_name) : varinfo = - try - if debugGlobal then - ignore (E.log "createGlobal: %s\n" n); - (* Make a first version of the varinfo *) - let vi = makeVarInfoCabs ~isformal:false - ~isglobal:true (convLoc cloc) specs (n,ndt,a) in - (* Add the variable to the environment before doing the initializer - * because it might refer to the variable itself *) - if isFunctionType vi.vtype then begin - if inite != A.NO_INIT then - E.s (error "Function declaration with initializer (%s)\n" - vi.vname); - (* sm: if it's a function prototype, and the storage class *) - (* isn't specified, make it 'extern'; this fixes a problem *) - (* with no-storage prototype and static definition *) - if vi.vstorage = NoStorage then - (*(trace "sm" (dprintf "adding extern to prototype of %s\n" n));*) - vi.vstorage <- Extern; - end; - let vi, alreadyInEnv = makeGlobalVarinfo (inite != A.NO_INIT) vi in -(* - ignore (E.log "createGlobal %a: %s type=%a\n" - d_loc (convLoc cloc) vi.vname d_plaintype vi.vtype); -*) - (* Do the initializer and complete the array type if necessary *) - let init : init option = - if inite = A.NO_INIT then - None - else - let se, ie', et = doInitializer vi inite in - (* Maybe we now have a better type *) - vi.vtype <- et; - if isNotEmpty se then - E.s (error "global initializer"); - Some ie' - in - - try - let oldloc = H.find alreadyDefined vi.vname in - if init != None then begin - E.s (error "Global %s was already defined at %a\n" - vi.vname d_loc oldloc); - end; - if debugGlobal then - ignore (E.log " global %s was already defined\n" vi.vname); - (* Do not declare it again *) - vi - with Not_found -> begin - (* Not already defined *) - if debugGlobal then - ignore (E.log " first definition for %s\n" vi.vname); - if init != None then begin - (* weimer: Sat Dec 8 17:43:34 2001 - * MSVC NT Kernel headers include this lovely line: - * extern const GUID __declspec(selectany) \ - * MOUNTDEV_MOUNTED_DEVICE_GUID = { 0x53f5630d, 0xb6bf, 0x11d0, { \ - * 0x94, 0xf2, 0x00, 0xa0, 0xc9, 0x1e, 0xfb, 0x8b } }; - * So we allow "extern" + "initializer" if "const" is - * around. *) - (* sm: As I read the ISO spec, in particular 6.9.2 and 6.7.8, - * "extern int foo = 3" is exactly equivalent to "int foo = 3"; - * that is, if you put an initializer, then it is a definition, - * and "extern" is redundantly giving the name external linkage. - * gcc emits a warning, I guess because it is contrary to - * usual practice, but I think CIL warnings should be about - * semantic rather than stylistic issues, so I see no reason to - * even emit a warning. *) - if vi.vstorage = Extern then - vi.vstorage <- NoStorage; (* equivalent and canonical *) - - H.add alreadyDefined vi.vname !currentLoc; - IH.remove mustTurnIntoDef vi.vid; - cabsPushGlobal (GVar(vi, {init = init}, !currentLoc)); - vi - end else begin - if not (isFunctionType vi.vtype) - && not (IH.mem mustTurnIntoDef vi.vid) then - begin - IH.add mustTurnIntoDef vi.vid true - end; - if not alreadyInEnv then begin (* Only one declaration *) - (* If it has function type it is a prototype *) - cabsPushGlobal (GVarDecl (vi, !currentLoc)); - vi - end else begin - if debugGlobal then - ignore (E.log " already in env %s\n" vi.vname); - vi - end - end - end - with e -> begin - ignore (E.log "error in createGlobal(%s: %a): %s\n" n - d_loc !currentLoc - (Printexc.to_string e)); - cabsPushGlobal (dGlobal (dprintf "booo - error in global %s (%t)" - n d_thisloc) !currentLoc); - dummyFunDec.svar - end -(* - ignore (E.log "Env after processing global %s is:@!%t@!" - n docEnv); - ignore (E.log "Alpha after processing global %s is:@!%t@!" - n docAlphaTable) -*) - -(* Must catch the Static local variables. Make them global *) -and createLocal ((_, sto, _, _) as specs) - ((((n, ndt, a, cloc) : A.name), - (inite: A.init_expression)) as init_name) - : chunk = - let loc = convLoc cloc in - (* Check if we are declaring a function *) - let rec isProto (dt: decl_type) : bool = - match dt with - | PROTO (JUSTBASE, _, _) -> true - | PROTO (x, _, _) -> isProto x - | PARENTYPE (_, x, _) -> isProto x - | ARRAY (x, _, _) -> isProto x - | PTR (_, x) -> isProto x - | _ -> false - in - match ndt with - (* Maybe we have a function prototype in local scope. Make it global. We - * do this even if the storage is Static *) - | _ when isProto ndt -> - let vi = createGlobal specs init_name in - (* Add it to the environment to shadow previous decls *) - addLocalToEnv n (EnvVar vi); - empty - - | _ when sto = Static -> - if debugGlobal then - ignore (E.log "createGlobal (local static): %s\n" n); - - - (* Now alpha convert it to make sure that it does not conflict with - * existing globals or locals from this function. *) - let newname, _ = newAlphaName true "" n in - (* Make it global *) - let vi = makeVarInfoCabs ~isformal:false - ~isglobal:true - loc specs (newname, ndt, a) in - (* However, we have a problem if a real global appears later with the - * name that we have happened to choose for this one. Remember these names - * for later. *) - H.add staticLocals vi.vname vi; - (* Add it to the environment as a local so that the name goes out of - * scope properly *) - addLocalToEnv n (EnvVar vi); - - (* Maybe this is an array whose length depends on something with local - scope, e.g. "static char device[ sizeof(local) ]". - Const-fold the type to fix this. *) - vi.vtype <- constFoldType vi.vtype; - - let init : init option = - if inite = A.NO_INIT then - None - else begin - let se, ie', et = doInitializer vi inite in - (* Maybe we now have a better type *) - vi.vtype <- et; - if isNotEmpty se then - E.s (error "global static initializer"); - (* Maybe the initializer refers to the function itself. - Push a prototype for the function, just in case. Hopefully, - if does not refer to the locals *) - cabsPushGlobal (GVarDecl (!currentFunctionFDEC.svar, !currentLoc)); - Some ie' - end - in - cabsPushGlobal (GVar(vi, {init = init}, !currentLoc)); - empty - - (* Maybe we have an extern declaration. Make it a global *) - | _ when sto = Extern -> - let vi = createGlobal specs init_name in - (* Add it to the local environment to ensure that it shadows previous - * local variables *) - addLocalToEnv n (EnvVar vi); - empty - - | _ -> - (* Make a variable of potentially variable size. If se0 <> empty then - * it is a variable size variable *) - let vi,se0,len,isvarsize = - makeVarSizeVarInfo loc specs (n, ndt, a) in - - let vi = alphaConvertVarAndAddToEnv true vi in (* Replace vi *) - let se1 = - if isvarsize then begin (* Variable-sized array *) - ignore (warn "Variable-sized local variable %s" vi.vname); - (* Make a local variable to keep the length *) - let savelen = - makeVarInfoCabs - ~isformal:false - ~isglobal:false - loc - (TInt(IUInt, []), NoStorage, false, []) - ("__lengthof" ^ vi.vname,JUSTBASE, []) - in - (* Register it *) - let savelen = alphaConvertVarAndAddToEnv true savelen in - (* Compute the sizeof *) - let sizeof = - BinOp(Mult, - SizeOfE (Lval(Mem(Lval(var vi)), NoOffset)), - Lval (var savelen), !typeOfSizeOf) in - (* Register the length *) - IH.add varSizeArrays vi.vid sizeof; - (* There can be no initializer for this *) - if inite != A.NO_INIT then - E.s (error "Variable-sized array cannot have initializer"); - se0 +++ (Set(var savelen, len, !currentLoc)) - (* Initialize the variable *) - +++ (Call(Some(var vi), Lval(var (allocaFun ())), - [ sizeof ], !currentLoc)) - end else empty - in - if inite = A.NO_INIT then - se1 (* skipChunk *) - else begin - let se4, ie', et = doInitializer vi inite in - (* Fix the length *) - (match vi.vtype, ie', et with - (* We have a length now *) - TArray(_,None, _), _, TArray(_, Some _, _) -> vi.vtype <- et - (* Initializing a local array *) - | TArray(TInt((IChar|IUChar|ISChar), _) as bt, None, a), - SingleInit(Const(CStr s)), _ -> - vi.vtype <- TArray(bt, - Some (integer (String.length s + 1)), - a) - | _, _, _ -> ()); - - (* Now create assignments instead of the initialization *) - se1 @@ se4 @@ (assignInit (Var vi, NoOffset) ie' et empty) - end - -and doAliasFun vtype (thisname:string) (othername:string) - (sname:single_name) (loc: cabsloc) : unit = - (* This prototype declares that name is an alias for - othername, which must be defined in this file *) -(* E.log "%s is alias for %s at %a\n" thisname othername *) -(* d_loc !currentLoc; *) - let rt, formals, isva, _ = splitFunctionType vtype in - if isva then E.s (error "%a: alias unsupported with varargs." - d_loc !currentLoc); - let args = List.map - (fun (n,_,_) -> A.VARIABLE n) - (argsToList formals) in - let call = A.CALL (A.VARIABLE othername, args) in - let stmt = if isVoidType rt then A.COMPUTATION(call, loc) - else A.RETURN(call, loc) - in - let body = { A.blabels = []; A.battrs = []; A.bstmts = [stmt] } in - let fdef = A.FUNDEF (sname, body, loc, loc) in - ignore (doDecl true fdef); - (* get the new function *) - let v,_ = try lookupGlobalVar thisname - with Not_found -> E.s (bug "error in doDecl") in - v.vattr <- dropAttribute "alias" v.vattr - - -(* Do one declaration *) -and doDecl (isglobal: bool) : A.definition -> chunk = function - | A.DECDEF ((s, nl), loc) -> - currentLoc := convLoc(loc); - (* Do the specifiers exactly once *) - let sugg = - match nl with - [] -> "" - | ((n, _, _, _), _) :: _ -> n - in - let spec_res = doSpecList sugg s in - (* Do all the variables and concatenate the resulting statements *) - let doOneDeclarator (acc: chunk) (name: init_name) = - let (n,ndt,a,l),_ = name in - if isglobal then begin - let bt,_,_,attrs = spec_res in - let vtype, nattr = - doType (AttrName false) bt (A.PARENTYPE(attrs, ndt, a)) in - (match filterAttributes "alias" nattr with - [] -> (* ordinary prototype. *) - ignore (createGlobal spec_res name) - (* E.log "%s is not aliased\n" name *) - | [Attr("alias", [AStr othername])] -> - if not (isFunctionType vtype) then begin - ignore (warn - "%a: CIL only supports attribute((alias)) for functions.\n" - d_loc !currentLoc); - ignore (createGlobal spec_res name) - end else - doAliasFun vtype n othername (s, (n,ndt,a,l)) loc - | _ -> E.s (error "Bad alias attribute at %a" d_loc !currentLoc)); - acc - end else - acc @@ createLocal spec_res name - in - let res = List.fold_left doOneDeclarator empty nl in -(* - ignore (E.log "after doDecl %a: res=%a\n" - d_loc !currentLoc d_chunk res); -*) - res - - - - | A.TYPEDEF (ng, loc) -> - currentLoc := convLoc(loc); - doTypedef ng; empty - - | A.ONLYTYPEDEF (s, loc) -> - currentLoc := convLoc(loc); - doOnlyTypedef s; empty - - | A.GLOBASM (s,loc) when isglobal -> - currentLoc := convLoc(loc); - cabsPushGlobal (GAsm (s, !currentLoc)); - empty - - | A.PRAGMA (a, loc) when isglobal -> begin - currentLoc := convLoc(loc); - match doAttr ("dummy", [a]) with - [Attr("dummy", [a'])] -> - let a'' = - match a' with - | ACons (s, args) -> Attr (s, args) - | _ -> E.s (error "Unexpected attribute in #pragma") - in - cabsPushGlobal (GPragma (a'', !currentLoc)); - empty - - | _ -> E.s (error "Too many attributes in pragma") - end - | A.TRANSFORMER (_, _, _) -> E.s (E.bug "TRANSFORMER in cabs2cil input") - | A.EXPRTRANSFORMER (_, _, _) -> - E.s (E.bug "EXPRTRANSFORMER in cabs2cil input") - - (* If there are multiple definitions of extern inline, turn all but the - * first into a prototype *) - | A.FUNDEF (((specs,(n,dt,a,loc')) : A.single_name), - (body : A.block), loc, _) - when isglobal && isExtern specs && isInline specs - && (H.mem genv (n ^ "__extinline")) -> - currentLoc := convLoc(loc); - let othervi, _ = lookupVar (n ^ "__extinline") in - if othervi.vname = n then - (* The previous entry in the env is also an extern inline version - of n. *) - ignore (warn "Duplicate extern inline definition for %s ignored" n) - else begin - (* Otherwise, the previous entry is an ordinary function that - happens to be named __extinline. Renaming n to n__extinline - would confict with other, so report an error. *) - E.s (unimp("Trying to rename %s to\n %s__extinline, but %s__extinline" - ^^ " already exists in the env.\n \"__extinline\" is" - ^^ " reserved for CIL.\n") n n n) - end; - (* Treat it as a prototype *) - doDecl isglobal (A.DECDEF ((specs, [((n,dt,a,loc'), A.NO_INIT)]), loc)) - - | A.FUNDEF (((specs,(n,dt,a, _)) : A.single_name), - (body : A.block), loc1, loc2) when isglobal -> - begin - let funloc = convLoc loc1 in - let endloc = convLoc loc2 in -(* ignore (E.log "Definition of %s at %a\n" n d_loc funloc); *) - currentLoc := funloc; - E.withContext - (fun _ -> dprintf "2cil: %s" n) - (fun _ -> - try - IH.clear callTempVars; - - (* Make the fundec right away, and we'll populate it later. We - * need this throughout the code to create temporaries. *) - currentFunctionFDEC := - { svar = makeGlobalVar "@tempname@" voidType; - slocals = []; (* For now we'll put here both the locals and - * the formals. Then "endFunction" will - * separate them *) - sformals = []; (* Not final yet *) - smaxid = 0; - sbody = dummyFunDec.sbody; (* Not final yet *) - smaxstmtid = None; - sallstmts = []; - }; - !currentFunctionFDEC.svar.vdecl <- funloc; - - constrExprId := 0; - (* Setup the environment. Add the formals to the locals. Maybe - * they need alpha-conv *) - enterScope (); (* Start the scope *) - - IH.clear varSizeArrays; - - (* Do not process transparent unions in function definitions. - * We'll do it later *) - transparentUnionArgs := []; - - (* Fix the NAME and the STORAGE *) - let _ = - let bt,sto,inl,attrs = doSpecList n specs in - !currentFunctionFDEC.svar.vinline <- inl; - - let ftyp, funattr = - doType (AttrName false) bt (A.PARENTYPE(attrs, dt, a)) in - !currentFunctionFDEC.svar.vtype <- ftyp; - !currentFunctionFDEC.svar.vattr <- funattr; - - (* If this is the definition of an extern inline then we change - * its name, by adding the suffix __extinline. We also make it - * static *) - let n', sto' = - let n' = n ^ "__extinline" in - if inl && sto = Extern then - n', Static - else begin - (* Maybe this is the body of a previous extern inline. Then - * we must take that one out of the environment because it - * is not used from here on. This will also ensure that - * then we make this functions' varinfo we will not think - * it is a duplicate definition *) - (try - ignore (lookupVar n'); (* if this succeeds, n' is defined*) - let oldvi, _ = lookupVar n in - if oldvi.vname = n' then begin - (* oldvi is an extern inline function that has been - renamed to n ^ "__extinline". Remove it from the - environment. *) - H.remove env n; H.remove genv n; - H.remove env n'; H.remove genv n' - end - else - (* oldvi is not a renamed extern inline function, and - we should do nothing. The reason the lookup - of n' succeeded is probably because there's - an ordinary function that happens to be named, - n ^ "__extinline", probably as a result of a previous - pass through CIL. See small2/extinline.c*) - () - with Not_found -> ()); - n, sto - end - in - (* Now we have the name and the storage *) - !currentFunctionFDEC.svar.vname <- n'; - !currentFunctionFDEC.svar.vstorage <- sto' - in - - (* Add the function itself to the environment. Add it before - * you do the body because the function might be recursive. Add - * it also before you add the formals to the environment - * because there might be a formal with the same name as the - * function and we want it to take precedence. *) - (* Make a variable out of it and put it in the environment *) - !currentFunctionFDEC.svar <- - fst (makeGlobalVarinfo true !currentFunctionFDEC.svar); - - (* If it is extern inline then we add it to the global - * environment for the original name as well. This will ensure - * that all uses of this function will refer to the renamed - * function *) - addGlobalToEnv n (EnvVar !currentFunctionFDEC.svar); - - if H.mem alreadyDefined !currentFunctionFDEC.svar.vname then - E.s (error "There is a definition already for %s" n); - -(* - ignore (E.log "makefunvar:%s@! type=%a@! vattr=%a@!" - n d_type thisFunctionVI.vtype - d_attrlist thisFunctionVI.vattr); -*) - - (* makeGlobalVarinfo might have changed the type of the function - * (when combining it with the type of the prototype). So get the - * type only now. *) - - (**** Process the TYPE and the FORMALS ***) - let _ = - let (returnType, formals_t, isvararg, funta) = - splitFunctionTypeVI !currentFunctionFDEC.svar - in - (* Record the returnType for doStatement *) - currentReturnType := returnType; - - - (* Create the formals and add them to the environment. *) - (* sfg: extract locations for the formals from dt *) - let doFormal (loc : location) (fn, ft, fa) = - let f = makeVarinfo false fn ft in - (f.vdecl <- loc; - f.vattr <- fa; - alphaConvertVarAndAddToEnv true f) - in - let rec doFormals fl' ll' = - begin - match (fl', ll') with - | [], _ -> [] - - | fl, [] -> (* no more locs available *) - List.map (doFormal !currentLoc) fl - - | f::fl, (_,(_,_,_,l))::ll -> - (* sfg: these lets seem to be necessary to - * force the right order of evaluation *) - let f' = doFormal (convLoc l) f in - let fl' = doFormals fl ll in - f' :: fl' - end - in - let fmlocs = (match dt with PROTO(_, fml, _) -> fml | _ -> []) in - let formals = doFormals (argsToList formals_t) fmlocs in - - (* Recreate the type based on the formals. *) - let ftype = TFun(returnType, - Some (List.map (fun f -> (f.vname, - f.vtype, - f.vattr)) formals), - isvararg, funta) in - (* - ignore (E.log "Funtype of %s: %a\n" n' d_type ftype); - *) - (* Now fix the names of the formals in the type of the function - * as well *) - !currentFunctionFDEC.svar.vtype <- ftype; - !currentFunctionFDEC.sformals <- formals; - in - (* Now change the type of transparent union args back to what it - * was so that the body type checks. We must do it this late - * because makeGlobalVarinfo from above might choke if we give - * the function a type containing transparent unions *) - let _ = - let rec fixbackFormals (idx: int) (args: varinfo list) : unit= - match args with - [] -> () - | a :: args' -> - (* Fix the type back to a transparent union type *) - (try - let origtype = List.assq idx !transparentUnionArgs in - a.vtype <- origtype; - with Not_found -> ()); - fixbackFormals (idx + 1) args' - in - fixbackFormals 0 !currentFunctionFDEC.sformals; - transparentUnionArgs := []; - in - - (********** Now do the BODY *************) - let _ = - let stmts = doBody body in - (* Finish everything *) - exitScope (); - - (* Now fill in the computed goto statement with cases. Do this - * before mkFunctionbody which resolves the gotos *) - (match !gotoTargetData with - Some (switchv, switch) -> - let switche, l = - match switch.skind with - Switch (switche, _, _, l) -> switche, l - | _ -> E.s(bug "the computed goto statement not a switch") - in - (* Build a default chunk that segfaults *) - let default = - defaultChunk - l - (i2c (Set ((Mem (mkCast (integer 0) intPtrType), - NoOffset), - integer 0, l))) - in - let bodychunk = ref default in - H.iter (fun lname laddr -> - bodychunk := - caseRangeChunk - [integer laddr] l - (gotoChunk lname l @@ !bodychunk)) - gotoTargetHash; - (* Now recreate the switch *) - let newswitch = switchChunk switche !bodychunk l in - (* We must still share the old switch statement since we - * have already inserted the goto's *) - let newswitchkind = - match newswitch.stmts with - [ s] - when newswitch.postins == [] && newswitch.cases == []-> - s.skind - | _ -> E.s (bug "Unexpected result from switchChunk") - in - switch.skind <- newswitchkind - - | None -> ()); - (* Now finish the body and store it *) - !currentFunctionFDEC.sbody <- mkFunctionBody stmts; - (* Reset the global parameters *) - gotoTargetData := None; - H.clear gotoTargetHash; - gotoTargetNextAddr := 0; - in - - - -(* - ignore (E.log "endFunction %s at %t:@! sformals=%a@! slocals=%a@!" - !currentFunctionFDEC.svar.vname d_thisloc - (docList ~sep:(chr ',') (fun v -> text v.vname)) - !currentFunctionFDEC.sformals - (docList ~sep:(chr ',') (fun v -> text v.vname)) - !currentFunctionFDEC.slocals); -*) - - let rec dropFormals formals locals = - match formals, locals with - [], l -> l - | f :: formals, l :: locals -> - if f != l then - E.s (bug "formal %s is not in locals (found instead %s)" - f.vname l.vname); - dropFormals formals locals - | _ -> E.s (bug "Too few locals") - in - !currentFunctionFDEC.slocals - <- dropFormals !currentFunctionFDEC.sformals - (List.rev !currentFunctionFDEC.slocals); - setMaxId !currentFunctionFDEC; - - (* Now go over the types of the formals and pull out the formals - * with transparent union type. Replace them with some shadow - * parameters and then add assignments *) - let _ = - let newformals, newbody = - List.fold_right (* So that the formals come out in order *) - (fun f (accform, accbody) -> - match isTransparentUnion f.vtype with - None -> (f :: accform, accbody) - | Some fstfield -> - (* A new shadow to be placed in the formals. Use - * makeTempVar to update smaxid and all others. *) - let shadow = - makeTempVar !currentFunctionFDEC fstfield.ftype in - (* Now take it out of the locals and replace it with - * the current formal. It is not worth optimizing this - * one. *) - !currentFunctionFDEC.slocals <- - f :: - (List.filter (fun x -> x.vid <> shadow.vid) - !currentFunctionFDEC.slocals); - (shadow :: accform, - mkStmt (Instr [Set ((Var f, Field(fstfield, - NoOffset)), - Lval (var shadow), - !currentLoc)]) :: accbody)) - !currentFunctionFDEC.sformals - ([], !currentFunctionFDEC.sbody.bstmts) - in - !currentFunctionFDEC.sbody.bstmts <- newbody; - (* To make sure sharing with the type is proper *) - setFormals !currentFunctionFDEC newformals; - in - - (* Now see whether we can fall through to the end of the function - * *) - (* weimer: Sat Dec 8 17:30:47 2001 MSVC NT kernel headers include - * functions like long convert(x) { __asm { mov eax, x \n cdq } } - * That set a return value via an ASM statement. As a result, I - * am changing this so a final ASM statement does not count as - * "fall through" for the purposes of this warning. *) - (* matth: But it's better to assume assembly will fall through, - * since most such blocks do. It's probably better to print an - * unnecessary warning than to break CIL's invariant that - * return statements are inserted properly. *) - let instrFallsThrough (i : instr) = match i with - Set _ -> true - | Call (None, Lval (Var e, NoOffset), _, _) -> - (* See if this is exit, or if it has the noreturn attribute *) - if e.vname = "exit" then false - else if hasAttribute "noreturn" e.vattr then false - else true - | Call _ -> true - | Asm _ -> true - in - let rec stmtFallsThrough (s: stmt) : bool = - match s.skind with - Instr(il) -> - List.fold_left (fun acc elt -> - acc && instrFallsThrough elt) true il - | Return _ | Break _ | Continue _ -> false - | Goto _ -> false - | If (_, b1, b2, _) -> - blockFallsThrough b1 || blockFallsThrough b2 - | Switch (e, b, targets, _) -> - (* See if there is a "default" case *) - if not - (List.exists (fun s -> - List.exists (function Default _ -> true | _ -> false) - s.labels) - targets) then begin -(* - ignore (E.log "Switch falls through because no default"); - -*) true (* We fall through because there is no default *) - end else begin - (* We must examine all cases. If any falls through, - * then the switch falls through. *) - blockFallsThrough b || blockCanBreak b - end -(* - | Loop (b, _, _, _) -> - (* A loop falls through if it can break. *) - blockCanBreak b -*) - | While (_, b, _) -> blockCanBreak b - | DoWhile (_, b, _) -> blockCanBreak b - | For (_, _, _, b, _) -> blockCanBreak b - | Block b -> blockFallsThrough b - | TryFinally (b, h, _) -> blockFallsThrough h - | TryExcept (b, _, h, _) -> true (* Conservative *) - and blockFallsThrough b = - let rec fall = function - [] -> true - | s :: rest -> - if stmtFallsThrough s then begin -(* - ignore (E.log "Stmt %a falls through\n" d_stmt s); -*) - fall rest - end else begin -(* - ignore (E.log "Stmt %a DOES NOT fall through\n" - d_stmt s); -*) - (* If we are not falling thorough then maybe there - * are labels who are *) - labels rest - end - and labels = function - [] -> false - (* We have a label, perhaps we can jump here *) - | s :: rest when s.labels <> [] -> -(* - ignore (E.log "invoking fall %a: %a\n" - d_loc !currentLoc d_stmt s); -*) - fall (s :: rest) - | _ :: rest -> labels rest - in - let res = fall b.bstmts in -(* - ignore (E.log "blockFallsThrough=%b %a\n" res d_block b); -*) - res - (* will we leave this statement or block with a break command? *) - and stmtCanBreak (s: stmt) : bool = - match s.skind with - Instr _ | Return _ | Continue _ | Goto _ -> false - | Break _ -> true - | If (_, b1, b2, _) -> - blockCanBreak b1 || blockCanBreak b2 - | Switch _ | (*Loop _*) While _ | DoWhile _ | For _ -> - (* switches and loops catch any breaks in their bodies *) - false - | Block b -> blockCanBreak b - | TryFinally (b, h, _) -> blockCanBreak b || blockCanBreak h - | TryExcept (b, _, h, _) -> blockCanBreak b || blockCanBreak h - and blockCanBreak b = - List.exists stmtCanBreak b.bstmts - in - if blockFallsThrough !currentFunctionFDEC.sbody then begin -(* - let retval = - match unrollType !currentReturnType with - TVoid _ -> None - | (TInt _ | TEnum _ | TFloat _ | TPtr _) as rt -> - ignore (warn "Body of function %s falls-through. Adding a return statement\n" !currentFunctionFDEC.svar.vname); - Some (mkCastT zero intType rt) - | _ -> - ignore (warn "Body of function %s falls-through and cannot find an appropriate return value\n" !currentFunctionFDEC.svar.vname); - None - in - if not (hasAttribute "noreturn" - !currentFunctionFDEC.svar.vattr) then - !currentFunctionFDEC.sbody.bstmts <- - !currentFunctionFDEC.sbody.bstmts - @ [mkStmt (Return(retval, endloc))] -*) - end; - - (* ignore (E.log "The env after finishing the body of %s:\n%t\n" - n docEnv); *) - cabsPushGlobal (GFun (!currentFunctionFDEC, funloc)); - empty - with E.Error as e -> raise e - | e -> begin - ignore (E.log "error in collectFunction %s: %s\n" - n (Printexc.to_string e)); - cabsPushGlobal (GAsm("error in function " ^ n, !currentLoc)); - empty - end) - () (* argument of E.withContext *) - end (* FUNDEF *) - - | LINKAGE (n, loc, dl) -> - currentLoc := convLoc loc; - if n <> "C" then - ignore (warn "Encountered linkage specification \"%s\"" n); - if not isglobal then - E.s (error "Encountered linkage specification in local scope"); - (* For now drop the linkage on the floor !!! *) - List.iter - (fun d -> - let s = doDecl isglobal d in - if isNotEmpty s then - E.s (bug "doDecl returns non-empty statement for global")) - dl; - empty - - | _ -> E.s (error "unexpected form of declaration") - -and doTypedef ((specs, nl): A.name_group) = - try - (* Do the specifiers exactly once *) - let bt, sto, inl, attrs = doSpecList (suggestAnonName nl) specs in - if sto <> NoStorage || inl then - E.s (error "Storage or inline specifier not allowed in typedef"); - let createTypedef ((n,ndt,a,loc) : A.name) = - (* E.s (error "doTypeDef") *) - try - let newTyp, tattr = - doType AttrType bt (A.PARENTYPE(attrs, ndt, a)) in - let newTyp' = cabsTypeAddAttributes tattr newTyp in - (* Create a new name for the type. Use the same name space as that of - * variables to avoid confusion between variable names and types. This - * is actually necessary in some cases. *) - let n', _ = newAlphaName true "" n in - let ti = { tname = n'; ttype = newTyp'; treferenced = false } in - (* Since we use the same name space, we might later hit a global with - * the same name and we would want to change the name of the global. - * It is better to change the name of the type instead. So, remember - * all types whose names have changed *) - H.add typedefs n' ti; - let namedTyp = TNamed(ti, []) in - (* Register the type. register it as local because we might be in a - * local context *) - addLocalToEnv (kindPlusName "type" n) (EnvTyp namedTyp); - cabsPushGlobal (GType (ti, !currentLoc)) - with E.Error as e -> raise e - | e -> begin - ignore (E.log "Error on A.TYPEDEF (%s)\n" - (Printexc.to_string e)); - cabsPushGlobal (GAsm ("booo_typedef:" ^ n, !currentLoc)) - end - in - List.iter createTypedef nl - with E.Error as e -> raise e - | e -> begin - ignore (E.log "Error on A.TYPEDEF (%s)\n" - (Printexc.to_string e)); - let fstname = - match nl with - [] -> "" - | (n, _, _, _) :: _ -> n - in - cabsPushGlobal (GAsm ("booo_typedef: " ^ fstname, !currentLoc)) - end - -and doOnlyTypedef (specs: A.spec_elem list) : unit = - try - let bt, sto, inl, attrs = doSpecList "" specs in - if sto <> NoStorage || inl then - E.s (error "Storage or inline specifier not allowed in typedef"); - let restyp, nattr = doType AttrType bt (A.PARENTYPE(attrs, - A.JUSTBASE, [])) in - if nattr <> [] then - ignore (warn "Ignoring identifier attribute"); - (* doSpec will register the type. *) - (* See if we are defining a composite or enumeration type, and in that - * case move the attributes from the defined type into the composite type - * *) - let isadef = - List.exists - (function - A.SpecType(A.Tstruct(_, Some _, _)) -> true - | A.SpecType(A.Tunion(_, Some _, _)) -> true - | A.SpecType(A.Tenum(_, Some _, _)) -> true - | _ -> false) specs - in - match restyp with - TComp(ci, al) -> - if isadef then begin - ci.cattr <- cabsAddAttributes ci.cattr al; - (* The GCompTag was already added *) - end else (* Add a GCompTagDecl *) - cabsPushGlobal (GCompTagDecl(ci, !currentLoc)) - | TEnum(ei, al) -> - if isadef then begin - ei.eattr <- cabsAddAttributes ei.eattr al; - end else - cabsPushGlobal (GEnumTagDecl(ei, !currentLoc)) - | _ -> - ignore (warn "Ignoring un-named typedef that does not introduce a struct or enumeration type\n") - - with E.Error as e -> raise e - | e -> begin - ignore (E.log "Error on A.ONLYTYPEDEF (%s)\n" - (Printexc.to_string e)); - cabsPushGlobal (GAsm ("booo_typedef", !currentLoc)) - end - -and assignInit (lv: lval) - (ie: init) - (iet: typ) - (acc: chunk) : chunk = - match ie with - SingleInit e -> - let (_, e'') = castTo iet (typeOfLval lv) e in - acc +++ (Set(lv, e'', !currentLoc)) - | CompoundInit (t, initl) -> - foldLeftCompound - ~doinit:(fun off i it acc -> - assignInit (addOffsetLval off lv) i it acc) - ~ct:t - ~initl:initl - ~acc:acc -(* - | ArrayInit (bt, len, initl) -> - let idx = ref ( -1 ) in - List.fold_left - (fun acc i -> - assignInit (addOffsetLval (Index(integer !idx, NoOffset)) lv) i bt acc) - acc - initl -*) - (* Now define the processors for body and statement *) -and doBody (blk: A.block) : chunk = - enterScope (); - (* Rename the labels and add them to the environment *) - List.iter (fun l -> ignore (genNewLocalLabel l)) blk.blabels; - (* See if we have some attributes *) - let battrs = doAttributes blk.A.battrs in - - let bodychunk = - afterConversion - (List.fold_left (* !!! @ evaluates its arguments backwards *) - (fun prev s -> let res = doStatement s in - prev @@ res) - empty - blk.A.bstmts) - in - exitScope (); - - - if battrs == [] then - bodychunk - else begin - let b = c2block bodychunk in - b.battrs <- battrs; - s2c (mkStmt (Block b)) - end - -and doStatement (s : A.statement) : chunk = - try - match s with - A.NOP _ -> skipChunk - | A.COMPUTATION (e, loc) -> - currentLoc := convLoc loc; - let (lasts, data) = !gnu_body_result in - if lasts == s then begin (* This is the last in a GNU_BODY *) - let (s', e', t') = doExp false e (AExp None) in - data := Some (e', t'); (* Record the result *) - s' - end else - let (s', _, _) = doExp false e ADrop in - (* drop the side-effect free expression *) - (* And now do some peep-hole optimizations *) - s' - - | A.BLOCK (b, loc) -> - currentLoc := convLoc loc; - doBody b - - | A.SEQUENCE (s1, s2, loc) -> - (doStatement s1) @@ (doStatement s2) - - | A.IF(e,st,sf,loc) -> - let st' = doStatement st in - let sf' = doStatement sf in - currentLoc := convLoc loc; - doCondition false e st' sf' - - | A.WHILE(e,s,loc) -> -(* - startLoop true; - let s' = doStatement s in - exitLoop (); - let loc' = convLoc loc in - currentLoc := loc'; - loopChunk ((doCondition false e skipChunk - (breakChunk loc')) - @@ s') -*) - (** We need to convert A.WHILE(e,s) where e may have side effects - into Cil.While(e',s') where e' is side-effect free. *) - - (* Let e == (sCond , eCond) with sCond a sequence of statements - and eCond a side-effect free expression. *) - let (sCond, eCond, _) = doExp false e (AExp None) in - - (* Then doStatement(A.WHILE((sCond , eCond), s)) - = sCond ; Cil.While(eCond, (doStatement(s) ; sCond)) - where doStatement(A.CONTINUE) = (sCond ; Cil.Continue). *) - - startLoop (DuplicateBeforeContinue sCond); - let s' = doStatement s in - exitLoop (); - let loc' = convLoc loc in - currentLoc := loc'; - sCond @@ (whileChunk eCond (s' @@ sCond)) - - | A.DOWHILE(e,s,loc) -> -(* - startLoop false; - let s' = doStatement s in - let loc' = convLoc loc in - currentLoc := loc'; - let s'' = - consLabContinue (doCondition false e skipChunk (breakChunk loc')) - in - exitLoop (); - loopChunk (s' @@ s'') -*) - (** We need to convert A.DOWHILE(e,s) where e may have side effects - into Cil.DoWhile(e',s') where e' is side-effect free. *) - - (* Let e == (sCond , eCond) with sCond a sequence of statements - and eCond a side-effect free expression. *) - let (sCond, eCond, _) = doExp false e (AExp None) in - - (* Then doStatement(A.DOWHILE((sCond , eCond), s)) - = Cil.DoWhile(eCond, (doStatement(s) ; sCond)) - where doStatement(A.CONTINUE) = (sCond ; Cil.Continue). *) - - startLoop (DuplicateBeforeContinue sCond); - let s' = doStatement s in - exitLoop (); - let loc' = convLoc loc in - currentLoc := loc'; - doWhileChunk eCond (s' @@ sCond) - - | A.FOR(fc1,e2,e3,s,loc) -> -(*begin - let loc' = convLoc loc in - currentLoc := loc'; - enterScope (); (* Just in case we have a declaration *) - let (se1, _, _) = - match fc1 with - FC_EXP e1 -> doExp false e1 ADrop - | FC_DECL d1 -> (doDecl false d1, zero, voidType) - in - let (se3, _, _) = doExp false e3 ADrop in - startLoop false; - let s' = doStatement s in - currentLoc := loc'; - let s'' = consLabContinue se3 in - exitLoop (); - let res = - match e2 with - A.NOTHING -> (* This means true *) - se1 @@ loopChunk (s' @@ s'') - | _ -> - se1 @@ loopChunk ((doCondition false e2 skipChunk (breakChunk loc')) - @@ s' @@ s'') - in - exitScope (); - res - end -*) - (** We need to convert A.FOR(e1,e2,e3,s) where e1, e2 and e3 may - have side effects into Cil.For(bInit,e2',bIter,s') where e2' - is side-effect free. **) - - (* Let e1 == bInit be a block of statements - Let e2 == (bCond , eCond) with bCond a block of statements - and eCond a side-effect free expression - Let e3 == bIter be a sequence of statements. *) - let (bInit, _, _) = match fc1 with - | FC_EXP e1 -> doExp false e1 ADrop - | FC_DECL d1 -> (doDecl false d1, zero, voidType) in - let (bCond, eCond, _) = doExp false e2 (AExp None) in - let eCond' = match eCond with - | Const(CStr "exp_nothing") -> Cil.one - | _ -> eCond in - let (bIter, _, _) = doExp false e3 ADrop in - - (* Then doStatement(A.FOR(bInit, (bCond , eCond), bIter, s)) - = Cil.For({bInit; bCond}, eCond', {bIter; bCond}, {doStatement(s)}) - where doStatement(A.CONTINUE) = Cil.Continue. *) - - startLoop ContinueUnchanged; - let s' = doStatement s in - exitLoop (); - let loc' = convLoc loc in - currentLoc := loc'; - (forChunk (bInit @@ bCond) eCond' (bIter @@ bCond) s') - - | A.BREAK loc -> - let loc' = convLoc loc in - currentLoc := loc'; - breakChunk loc' - - | A.CONTINUE loc -> - let loc' = convLoc loc in - currentLoc := loc'; -(* - continueOrLabelChunk loc' -*) - continueDuplicateChunk loc' - - | A.RETURN (A.NOTHING, loc) -> - let loc' = convLoc loc in - currentLoc := loc'; - if not (isVoidType !currentReturnType) then - ignore (warn "Return statement without a value in function returning %a\n" d_type !currentReturnType); - returnChunk None loc' - - | A.RETURN (e, loc) -> - let loc' = convLoc loc in - currentLoc := loc'; - (* Sometimes we return the result of a void function call *) - if isVoidType !currentReturnType then begin - ignore (warn "Return statement with a value in function returning void"); - let (se, _, _) = doExp false e ADrop in - se @@ returnChunk None loc' - end else begin - let (se, e', et) = - doExp false e (AExp (Some !currentReturnType)) in - let (et'', e'') = castTo et (!currentReturnType) e' in - se @@ (returnChunk (Some e'') loc') - end - - | A.SWITCH (e, s, loc) -> - let loc' = convLoc loc in - currentLoc := loc'; - let (se, e', et) = doExp false e (AExp (Some intType)) in - let (et'', e'') = castTo et intType e' in - let s' = doStatement s in - se @@ (switchChunk e'' s' loc') - - | A.CASE (e, s, loc) -> - let loc' = convLoc loc in - currentLoc := loc'; - let (se, e', et) = doExp true e (AExp None) in - if isNotEmpty se then - E.s (error "Case statement with a non-constant"); - caseRangeChunk [if !lowerConstants then constFold false e' else e'] - loc' (doStatement s) - - | A.CASERANGE (el, eh, s, loc) -> - let loc' = convLoc loc in - currentLoc := loc'; - let (sel, el', etl) = doExp false el (AExp None) in - let (seh, eh', etl) = doExp false eh (AExp None) in - if isNotEmpty sel || isNotEmpty seh then - E.s (error "Case statement with a non-constant"); - let il, ih = - match constFold true el', constFold true eh' with - Const(CInt64(il, _, _)), Const(CInt64(ih, _, _)) -> - Int64.to_int il, Int64.to_int ih - | _ -> E.s (unimp "Cannot understand the constants in case range") - in - if il > ih then - E.s (error "Empty case range"); - let rec mkAll (i: int) = - if i > ih then [] else integer i :: mkAll (i + 1) - in - caseRangeChunk (mkAll il) loc' (doStatement s) - - - | A.DEFAULT (s, loc) -> - let loc' = convLoc loc in - currentLoc := loc'; - defaultChunk loc' (doStatement s) - - | A.LABEL (l, s, loc) -> - let loc' = convLoc loc in - currentLoc := loc'; - (* Lookup the label because it might have been locally defined *) - consLabel (lookupLabel l) (doStatement s) loc' true - - | A.GOTO (l, loc) -> - let loc' = convLoc loc in - currentLoc := loc'; - (* Maybe we need to rename this label *) - gotoChunk (lookupLabel l) loc' - - | A.COMPGOTO (e, loc) -> begin - let loc' = convLoc loc in - currentLoc := loc'; - (* Do the expression *) - let se, e', t' = doExp false e (AExp (Some voidPtrType)) in - match !gotoTargetData with - Some (switchv, switch) -> (* We have already generated this one *) - se - @@ i2c(Set (var switchv, mkCast e' uintType, loc')) - @@ s2c(mkStmt(Goto (ref switch, loc'))) - - | None -> begin - (* Make a temporary variable *) - let vchunk = createLocal - (TInt(IUInt, []), NoStorage, false, []) - (("__compgoto", A.JUSTBASE, [], loc), A.NO_INIT) - in - if not (isEmpty vchunk) then - E.s (unimp "Non-empty chunk in creating temporary for goto *"); - let switchv, _ = - try lookupVar "__compgoto" - with Not_found -> E.s (bug "Cannot find temporary for goto *"); - in - (* Make a switch statement. We'll fill in the statements at the - * end of the function *) - let switch = mkStmt (Switch (Lval(var switchv), - mkBlock [], [], loc')) in - (* And make a label for it since we'll goto it *) - switch.labels <- [Label ("__docompgoto", loc', false)]; - gotoTargetData := Some (switchv, switch); - se @@ i2c (Set(var switchv, mkCast e' uintType, loc')) @@ - s2c switch - end - end - - | A.DEFINITION d -> - let s = doDecl false d in -(* - ignore (E.log "Def at %a: %a\n" d_loc !currentLoc d_chunk s); -*) - s - - - - | A.ASM (asmattr, tmpls, details, loc) -> - (* Make sure all the outs are variables *) - let loc' = convLoc loc in - let attr' = doAttributes asmattr in - currentLoc := loc'; - let stmts : chunk ref = ref empty in - let (tmpls', outs', ins', clobs') = - match details with - | None -> - let tmpls' = - if !msvcMode then - tmpls - else - let pattern = Str.regexp "%" in - let escape = Str.global_replace pattern "%%" in - List.map escape tmpls - in - (tmpls', [], [], []) - | Some { aoutputs = outs; ainputs = ins; aclobbers = clobs } -> - let outs' = - List.map - (fun (c, e) -> - let (se, e', t) = doExp false e (AExp None) in - let lv = - match e' with - | Lval lval - | StartOf lval -> lval - | _ -> E.s (error "Expected lval for ASM outputs") - in - stmts := !stmts @@ se; - (c, lv)) outs - in - (* Get the side-effects out of expressions *) - let ins' = - List.map - (fun (c, e) -> - let (se, e', et) = doExp false e (AExp None) in - stmts := !stmts @@ se; - (c, e')) - ins - in - (tmpls, outs', ins', clobs) - in - !stmts @@ - (i2c (Asm(attr', tmpls', outs', ins', clobs', loc'))) - - | TRY_FINALLY (b, h, loc) -> - let loc' = convLoc loc in - currentLoc := loc'; - let b': chunk = doBody b in - let h': chunk = doBody h in - if b'.cases <> [] || h'.cases <> [] then - E.s (error "Try statements cannot contain switch cases"); - - s2c (mkStmt (TryFinally (c2block b', c2block h', loc'))) - - | TRY_EXCEPT (b, e, h, loc) -> - let loc' = convLoc loc in - currentLoc := loc'; - let b': chunk = doBody b in - (* Now do e *) - let ((se: chunk), e', t') = doExp false e (AExp None) in - let h': chunk = doBody h in - if b'.cases <> [] || h'.cases <> [] || se.cases <> [] then - E.s (error "Try statements cannot contain switch cases"); - (* Now take se and try to convert it to a list of instructions. This - * might not be always possible *) - let il' = - match compactStmts se.stmts with - [] -> se.postins - | [ s ] -> begin - match s.skind with - Instr il -> il @ se.postins - | _ -> E.s (error "Except expression contains unexpected statement") - end - | _ -> E.s (error "Except expression contains too many statements") - in - s2c (mkStmt (TryExcept (c2block b', (il', e'), c2block h', loc'))) - - with e -> begin - (ignore (E.log "Error in doStatement (%s)\n" (Printexc.to_string e))); - consLabel "booo_statement" empty (convLoc (A.get_statementloc s)) false - end - - -(* Translate a file *) -let convFile ((fname : string), (dl : Cabs.definition list)) : Cil.file = - Cil.initCIL (); (* make sure we have initialized CIL *) - (* Clean up the global types *) - E.hadErrors := false; - initGlobals(); - startFile (); - IH.clear noProtoFunctions; - H.clear compInfoNameEnv; - H.clear enumInfoNameEnv; - IH.clear mustTurnIntoDef; - H.clear alreadyDefined; - H.clear staticLocals; - H.clear typedefs; - H.clear isomorphicStructs; - annonCompFieldNameId := 0; - if !E.verboseFlag || !Cilutil.printStages then - ignore (E.log "Converting CABS->CIL\n"); - (* Setup the built-ins, but do not add their prototypes to the file *) - let setupBuiltin name (resTyp, argTypes, isva) = - let v = - makeGlobalVar name (TFun(resTyp, - Some (List.map (fun at -> ("", at, [])) - argTypes), - isva, [])) in - ignore (alphaConvertVarAndAddToEnv true v) - in - H.iter setupBuiltin (if !msvcMode then msvcBuiltins else gccBuiltins); - - let globalidx = ref 0 in - let doOneGlobal (d: A.definition) = - let s = doDecl true d in - if isNotEmpty s then - E.s (bug "doDecl returns non-empty statement for global"); - (* See if this is one of the globals which we can leave alone. Increment - * globalidx and see if we must leave this alone. *) - if - (match d with - A.DECDEF _ -> true - | A.FUNDEF _ -> true - | _ -> false) && (incr globalidx; !globalidx = !nocil) then begin - (* Create a file where we put the CABS output *) - let temp_cabs_name = "__temp_cabs" in - let temp_cabs = open_out temp_cabs_name in - (* Now print the CABS in there *) - Cprint.commit (); Cprint.flush (); - let old = !Cprint.out in (* Save the old output channel *) - Cprint.out := temp_cabs; - Cprint.print_def d; - Cprint.commit (); Cprint.flush (); - flush !Cprint.out; - Cprint.out := old; - close_out temp_cabs; - (* Now read everythign in *and create a GText from it *) - let temp_cabs = open_in temp_cabs_name in - let buff = Buffer.create 1024 in - Buffer.add_string buff "// Start of CABS form\n"; - Buffer.add_channel buff temp_cabs (in_channel_length temp_cabs); - Buffer.add_string buff "// End of CABS form\n"; - close_in temp_cabs; - (* Try to pop the last thing in the file *) - (match !theFile with - _ :: rest -> theFile := rest - | _ -> ()); - (* Insert in the file a GText *) - cabsPushGlobal (GText(Buffer.contents buff)) - end - in - List.iter doOneGlobal dl; - let globals = ref (popGlobals ()) in - - IH.clear noProtoFunctions; - IH.clear mustTurnIntoDef; - H.clear alreadyDefined; - H.clear compInfoNameEnv; - H.clear enumInfoNameEnv; - H.clear isomorphicStructs; - H.clear staticLocals; - H.clear typedefs; - H.clear env; - H.clear genv; - IH.clear callTempVars; - - if false then ignore (E.log "Cabs2cil converted %d globals\n" !globalidx); - (* We are done *) - { fileName = fname; - globals = !globals; - globinit = None; - globinitcalled = false; - } - - - - diff --git a/cil/src/frontc/cabs2cil.mli b/cil/src/frontc/cabs2cil.mli deleted file mode 100644 index 986f5a28..00000000 --- a/cil/src/frontc/cabs2cil.mli +++ /dev/null @@ -1,49 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -val convFile: Cabs.file -> Cil.file - -(** NDC added command line parameter **) -(* Turn on tranformation that forces correct parameter evaluation order *) -val forceRLArgEval: bool ref - -(* Set this integer to the index of the global to be left in CABS form. Use - * -1 to disable *) -val nocil: int ref - -(* Indicates whether we're allowed to duplicate small chunks of code. *) -val allowDuplication: bool ref diff --git a/cil/src/frontc/cabsvisit.ml b/cil/src/frontc/cabsvisit.ml deleted file mode 100644 index b2f9784a..00000000 --- a/cil/src/frontc/cabsvisit.ml +++ /dev/null @@ -1,577 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(* cabsvisit.ml *) -(* tree visitor and rewriter for cabs *) - -open Cabs -open Trace -open Pretty -module E = Errormsg - -(* basic interface for a visitor object *) - -(* Different visiting actions. 'a will be instantiated with exp, instr, etc. *) -type 'a visitAction = - SkipChildren (* Do not visit the children. Return - * the node as it is *) - | ChangeTo of 'a (* Replace the expression with the - * given one *) - | DoChildren (* Continue with the children of this - * node. Rebuild the node on return - * if any of the children changes - * (use == test) *) - | ChangeDoChildrenPost of 'a * ('a -> 'a) (* First consider that the entire - * exp is replaced by the first - * paramenter. Then continue with - * the children. On return rebuild - * the node if any of the children - * has changed and then apply the - * function on the node *) - -type nameKind = - NVar (* Variable or function prototype - name *) - | NFun (* A function definition name *) - | NField (* The name of a field *) - | NType (* The name of a type *) - -(* All visit methods are called in preorder! (but you can use - * ChangeDoChildrenPost to change the order) *) -class type cabsVisitor = object - method vexpr: expression -> expression visitAction (* expressions *) - method vinitexpr: init_expression -> init_expression visitAction - method vstmt: statement -> statement list visitAction - method vblock: block -> block visitAction - method vvar: string -> string (* use of a variable - * names *) - method vdef: definition -> definition list visitAction - method vtypespec: typeSpecifier -> typeSpecifier visitAction - method vdecltype: decl_type -> decl_type visitAction - - (* For each declaration we call vname *) - method vname: nameKind -> specifier -> name -> name visitAction - method vspec: specifier -> specifier visitAction (* specifier *) - method vattr: attribute -> attribute list visitAction - - method vEnterScope: unit -> unit - method vExitScope: unit -> unit -end - -let visitorLocation = ref { filename = ""; - lineno = -1; - byteno = -1;} - - (* a default visitor which does nothing to the tree *) -class nopCabsVisitor : cabsVisitor = object - method vexpr (e:expression) = DoChildren - method vinitexpr (e:init_expression) = DoChildren - method vstmt (s: statement) = - visitorLocation := get_statementloc s; - DoChildren - method vblock (b: block) = DoChildren - method vvar (s: string) = s - method vdef (d: definition) = - visitorLocation := get_definitionloc d; - DoChildren - method vtypespec (ts: typeSpecifier) = DoChildren - method vdecltype (dt: decl_type) = DoChildren - method vname k (s:specifier) (n: name) = DoChildren - method vspec (s:specifier) = DoChildren - method vattr (a: attribute) = DoChildren - - method vEnterScope () = () - method vExitScope () = () -end - - (* Map but try not to copy the list unless necessary *) -let rec mapNoCopy (f: 'a -> 'a) = function - [] -> [] - | (i :: resti) as li -> - let i' = f i in - let resti' = mapNoCopy f resti in - if i' != i || resti' != resti then i' :: resti' else li - -let rec mapNoCopyList (f: 'a -> 'a list) = function - [] -> [] - | (i :: resti) as li -> - let il' = f i in - let resti' = mapNoCopyList f resti in - match il' with - [i'] when i' == i && resti' == resti -> li - | _ -> il' @ resti' - -let doVisit (vis: cabsVisitor) - (startvisit: 'a -> 'a visitAction) - (children: cabsVisitor -> 'a -> 'a) - (node: 'a) : 'a = - let action = startvisit node in - match action with - SkipChildren -> node - | ChangeTo node' -> node' - | _ -> - let nodepre = match action with - ChangeDoChildrenPost (node', _) -> node' - | _ -> node - in - let nodepost = children vis nodepre in - match action with - ChangeDoChildrenPost (_, f) -> f nodepost - | _ -> nodepost - -(* A visitor for lists *) -let doVisitList (vis: cabsVisitor) - (startvisit: 'a -> 'a list visitAction) - (children: cabsVisitor -> 'a -> 'a) - (node: 'a) : 'a list = - let action = startvisit node in - match action with - SkipChildren -> [node] - | ChangeTo nodes' -> nodes' - | _ -> - let nodespre = match action with - ChangeDoChildrenPost (nodespre, _) -> nodespre - | _ -> [node] - in - let nodespost = mapNoCopy (children vis) nodespre in - match action with - ChangeDoChildrenPost (_, f) -> f nodespost - | _ -> nodespost - - -let rec visitCabsTypeSpecifier (vis: cabsVisitor) (ts: typeSpecifier) = - doVisit vis vis#vtypespec childrenTypeSpecifier ts - -and childrenTypeSpecifier vis ts = - let childrenFieldGroup ((s, nel) as input) = - let s' = visitCabsSpecifier vis s in - let doOneField ((n, eo) as input) = - let n' = visitCabsName vis NField s' n in - let eo' = - match eo with - None -> None - | Some e -> let e' = visitCabsExpression vis e in - if e' != e then Some e' else eo - in - if n' != n || eo' != eo then (n', eo') else input - in - let nel' = mapNoCopy doOneField nel in - if s' != s || nel' != nel then (s', nel') else input - in - match ts with - Tstruct (n, Some fg, extraAttrs) -> - (*(trace "sm" (dprintf "visiting struct %s\n" n));*) - let fg' = mapNoCopy childrenFieldGroup fg in - if fg' != fg then Tstruct( n, Some fg', extraAttrs) else ts - | Tunion (n, Some fg, extraAttrs) -> - let fg' = mapNoCopy childrenFieldGroup fg in - if fg' != fg then Tunion( n, Some fg', extraAttrs) else ts - | Tenum (n, Some ei, extraAttrs) -> - let doOneEnumItem ((s, e, loc) as ei) = - let e' = visitCabsExpression vis e in - if e' != e then (s, e', loc) else ei - in - vis#vEnterScope (); - let ei' = mapNoCopy doOneEnumItem ei in - vis#vExitScope(); - if ei' != ei then Tenum( n, Some ei', extraAttrs) else ts - | TtypeofE e -> - let e' = visitCabsExpression vis e in - if e' != e then TtypeofE e' else ts - | TtypeofT (s, dt) -> - let s' = visitCabsSpecifier vis s in - let dt' = visitCabsDeclType vis false dt in - if s != s' || dt != dt' then TtypeofT (s', dt') else ts - | ts -> ts - -and childrenSpecElem (vis: cabsVisitor) (se: spec_elem) : spec_elem = - match se with - SpecTypedef | SpecInline | SpecStorage _ | SpecPattern _ -> se - | SpecCV _ -> se (* cop out *) - | SpecAttr a -> begin - let al' = visitCabsAttribute vis a in - match al' with - [a''] when a'' == a -> se - | [a''] -> SpecAttr a'' - | _ -> E.s (E.unimp "childrenSpecElem: visitCabsAttribute returned a list") - end - | SpecType ts -> - let ts' = visitCabsTypeSpecifier vis ts in - if ts' != ts then SpecType ts' else se - -and visitCabsSpecifier (vis: cabsVisitor) (s: specifier) : specifier = - doVisit vis vis#vspec childrenSpec s -and childrenSpec vis s = mapNoCopy (childrenSpecElem vis) s - - -and visitCabsDeclType vis (isfundef: bool) (dt: decl_type) : decl_type = - doVisit vis vis#vdecltype (childrenDeclType isfundef) dt -and childrenDeclType isfundef vis dt = - match dt with - JUSTBASE -> dt - | PARENTYPE (prea, dt1, posta) -> - let prea' = mapNoCopyList (visitCabsAttribute vis) prea in - let dt1' = visitCabsDeclType vis isfundef dt1 in - let posta'= mapNoCopyList (visitCabsAttribute vis) posta in - if prea' != prea || dt1' != dt1 || posta' != posta then - PARENTYPE (prea', dt1', posta') else dt - | ARRAY (dt1, al, e) -> - let dt1' = visitCabsDeclType vis isfundef dt1 in - let al' = mapNoCopy (childrenAttribute vis) al in - let e'= visitCabsExpression vis e in - if dt1' != dt1 || al' != al || e' != e then ARRAY(dt1', al', e') else dt - | PTR (al, dt1) -> - let al' = mapNoCopy (childrenAttribute vis) al in - let dt1' = visitCabsDeclType vis isfundef dt1 in - if al' != al || dt1' != dt1 then PTR(al', dt1') else dt - | PROTO (dt1, snl, b) -> - (* Do not propagate isfundef further *) - let dt1' = visitCabsDeclType vis false dt1 in - let _ = vis#vEnterScope () in - let snl' = mapNoCopy (childrenSingleName vis NVar) snl in - (* Exit the scope only if not in a function definition *) - let _ = if not isfundef then vis#vExitScope () in - if dt1' != dt1 || snl' != snl then PROTO(dt1', snl', b) else dt - - -and childrenNameGroup vis (kind: nameKind) ((s, nl) as input) = - let s' = visitCabsSpecifier vis s in - let nl' = mapNoCopy (visitCabsName vis kind s') nl in - if s' != s || nl' != nl then (s', nl') else input - - -and childrenInitNameGroup vis ((s, inl) as input) = - let s' = visitCabsSpecifier vis s in - let inl' = mapNoCopy (childrenInitName vis s') inl in - if s' != s || inl' != inl then (s', inl') else input - -and visitCabsName vis (k: nameKind) (s: specifier) - (n: name) : name = - doVisit vis (vis#vname k s) (childrenName s k) n -and childrenName (s: specifier) (k: nameKind) vis (n: name) : name = - let (sn, dt, al, loc) = n in - let dt' = visitCabsDeclType vis (k = NFun) dt in - let al' = mapNoCopy (childrenAttribute vis) al in - if dt' != dt || al' != al then (sn, dt', al', loc) else n - -and childrenInitName vis (s: specifier) (inn: init_name) : init_name = - let (n, ie) = inn in - let n' = visitCabsName vis NVar s n in - let ie' = visitCabsInitExpression vis ie in - if n' != n || ie' != ie then (n', ie') else inn - -and childrenSingleName vis (k: nameKind) (sn: single_name) : single_name = - let s, n = sn in - let s' = visitCabsSpecifier vis s in - let n' = visitCabsName vis k s' n in - if s' != s || n' != n then (s', n') else sn - -and visitCabsDefinition vis (d: definition) : definition list = - doVisitList vis vis#vdef childrenDefinition d -and childrenDefinition vis d = - match d with - FUNDEF (sn, b, l, lend) -> - let sn' = childrenSingleName vis NFun sn in - let b' = visitCabsBlock vis b in - (* End the scope that was started by childrenFunctionName *) - vis#vExitScope (); - if sn' != sn || b' != b then FUNDEF (sn', b', l, lend) else d - - | DECDEF ((s, inl), l) -> - let s' = visitCabsSpecifier vis s in - let inl' = mapNoCopy (childrenInitName vis s') inl in - if s' != s || inl' != inl then DECDEF ((s', inl'), l) else d - | TYPEDEF (ng, l) -> - let ng' = childrenNameGroup vis NType ng in - if ng' != ng then TYPEDEF (ng', l) else d - | ONLYTYPEDEF (s, l) -> - let s' = visitCabsSpecifier vis s in - if s' != s then ONLYTYPEDEF (s', l) else d - | GLOBASM _ -> d - | PRAGMA (e, l) -> - let e' = visitCabsExpression vis e in - if e' != e then PRAGMA (e', l) else d - | LINKAGE (n, l, dl) -> - let dl' = mapNoCopyList (visitCabsDefinition vis) dl in - if dl' != dl then LINKAGE (n, l, dl') else d - - | TRANSFORMER _ -> d - | EXPRTRANSFORMER _ -> d - -and visitCabsBlock vis (b: block) : block = - doVisit vis vis#vblock childrenBlock b - -and childrenBlock vis (b: block) : block = - let _ = vis#vEnterScope () in - let battrs' = mapNoCopyList (visitCabsAttribute vis) b.battrs in - let bstmts' = mapNoCopyList (visitCabsStatement vis) b.bstmts in - let _ = vis#vExitScope () in - if battrs' != b.battrs || bstmts' != b.bstmts then - { blabels = b.blabels; battrs = battrs'; bstmts = bstmts' } - else - b - -and visitCabsStatement vis (s: statement) : statement list = - doVisitList vis vis#vstmt childrenStatement s -and childrenStatement vis s = - let ve e = visitCabsExpression vis e in - let vs l s = - match visitCabsStatement vis s with - [s'] -> s' - | sl -> BLOCK ({blabels = []; battrs = []; bstmts = sl }, l) - in - match s with - NOP _ -> s - | COMPUTATION (e, l) -> - let e' = ve e in - if e' != e then COMPUTATION (e', l) else s - | BLOCK (b, l) -> - let b' = visitCabsBlock vis b in - if b' != b then BLOCK (b', l) else s - | SEQUENCE (s1, s2, l) -> - let s1' = vs l s1 in - let s2' = vs l s2 in - if s1' != s1 || s2' != s2 then SEQUENCE (s1', s2', l) else s - | IF (e, s1, s2, l) -> - let e' = ve e in - let s1' = vs l s1 in - let s2' = vs l s2 in - if e' != e || s1' != s1 || s2' != s2 then IF (e', s1', s2', l) else s - | WHILE (e, s1, l) -> - let e' = ve e in - let s1' = vs l s1 in - if e' != e || s1' != s1 then WHILE (e', s1', l) else s - | DOWHILE (e, s1, l) -> - let e' = ve e in - let s1' = vs l s1 in - if e' != e || s1' != s1 then DOWHILE (e', s1', l) else s - | FOR (fc1, e2, e3, s4, l) -> - let _ = vis#vEnterScope () in - let fc1' = - match fc1 with - FC_EXP e1 -> - let e1' = ve e1 in - if e1' != e1 then FC_EXP e1' else fc1 - | FC_DECL d1 -> - let d1' = - match visitCabsDefinition vis d1 with - [d1'] -> d1' - | _ -> E.s (E.unimp "visitCabs: for can have only one definition") - in - if d1' != d1 then FC_DECL d1' else fc1 - in - let e2' = ve e2 in - let e3' = ve e3 in - let s4' = vs l s4 in - let _ = vis#vExitScope () in - if fc1' != fc1 || e2' != e2 || e3' != e3 || s4' != s4 - then FOR (fc1', e2', e3', s4', l) else s - | BREAK _ | CONTINUE _ | GOTO _ -> s - | RETURN (e, l) -> - let e' = ve e in - if e' != e then RETURN (e', l) else s - | SWITCH (e, s1, l) -> - let e' = ve e in - let s1' = vs l s1 in - if e' != e || s1' != s1 then SWITCH (e', s1', l) else s - | CASE (e, s1, l) -> - let e' = ve e in - let s1' = vs l s1 in - if e' != e || s1' != s1 then CASE (e', s1', l) else s - | CASERANGE (e1, e2, s3, l) -> - let e1' = ve e1 in - let e2' = ve e2 in - let s3' = vs l s3 in - if e1' != e1 || e2' != e2 || s3' != s3 then - CASERANGE (e1', e2', s3', l) else s - | DEFAULT (s1, l) -> - let s1' = vs l s1 in - if s1' != s1 then DEFAULT (s1', l) else s - | LABEL (n, s1, l) -> - let s1' = vs l s1 in - if s1' != s1 then LABEL (n, s1', l) else s - | COMPGOTO (e, l) -> - let e' = ve e in - if e' != e then COMPGOTO (e', l) else s - | DEFINITION d -> begin - match visitCabsDefinition vis d with - [d'] when d' == d -> s - | [d'] -> DEFINITION d' - | dl -> let l = get_definitionloc d in - let dl' = List.map (fun d' -> DEFINITION d') dl in - BLOCK ({blabels = []; battrs = []; bstmts = dl' }, l) - end - | ASM (sl, b, details, l) -> - let childrenStringExp ((s, e) as input) = - let e' = ve e in - if e' != e then (s, e') else input - in - let details' = match details with - | None -> details - | Some { aoutputs = outl; ainputs = inl; aclobbers = clobs } -> - let outl' = mapNoCopy childrenStringExp outl in - let inl' = mapNoCopy childrenStringExp inl in - if outl' == outl && inl' == inl then - details - else - Some { aoutputs = outl'; ainputs = inl'; aclobbers = clobs } - in - if details' != details then - ASM (sl, b, details', l) else s - | TRY_FINALLY (b1, b2, l) -> - let b1' = visitCabsBlock vis b1 in - let b2' = visitCabsBlock vis b2 in - if b1' != b1 || b2' != b2 then TRY_FINALLY(b1', b2', l) else s - | TRY_EXCEPT (b1, e, b2, l) -> - let b1' = visitCabsBlock vis b1 in - let e' = visitCabsExpression vis e in - let b2' = visitCabsBlock vis b2 in - if b1' != b1 || e' != e || b2' != b2 then TRY_EXCEPT(b1', e', b2', l) else s - - -and visitCabsExpression vis (e: expression) : expression = - doVisit vis vis#vexpr childrenExpression e -and childrenExpression vis e = - let ve e = visitCabsExpression vis e in - match e with - NOTHING | LABELADDR _ -> e - | UNARY (uo, e1) -> - let e1' = ve e1 in - if e1' != e1 then UNARY (uo, e1') else e - | BINARY (bo, e1, e2) -> - let e1' = ve e1 in - let e2' = ve e2 in - if e1' != e1 || e2' != e2 then BINARY (bo, e1', e2') else e - | QUESTION (e1, e2, e3) -> - let e1' = ve e1 in - let e2' = ve e2 in - let e3' = ve e3 in - if e1' != e1 || e2' != e2 || e3' != e3 then - QUESTION (e1', e2', e3') else e - | CAST ((s, dt), ie) -> - let s' = visitCabsSpecifier vis s in - let dt' = visitCabsDeclType vis false dt in - let ie' = visitCabsInitExpression vis ie in - if s' != s || dt' != dt || ie' != ie then CAST ((s', dt'), ie') else e - | CALL (f, el) -> - let f' = ve f in - let el' = mapNoCopy ve el in - if f' != f || el' != el then CALL (f', el') else e - | COMMA el -> - let el' = mapNoCopy ve el in - if el' != el then COMMA (el') else e - | CONSTANT _ -> e - | VARIABLE s -> - let s' = vis#vvar s in - if s' != s then VARIABLE s' else e - | EXPR_SIZEOF (e1) -> - let e1' = ve e1 in - if e1' != e1 then EXPR_SIZEOF (e1') else e - | TYPE_SIZEOF (s, dt) -> - let s' = visitCabsSpecifier vis s in - let dt' = visitCabsDeclType vis false dt in - if s' != s || dt' != dt then TYPE_SIZEOF (s' ,dt') else e - | EXPR_ALIGNOF (e1) -> - let e1' = ve e1 in - if e1' != e1 then EXPR_ALIGNOF (e1') else e - | TYPE_ALIGNOF (s, dt) -> - let s' = visitCabsSpecifier vis s in - let dt' = visitCabsDeclType vis false dt in - if s' != s || dt' != dt then TYPE_ALIGNOF (s' ,dt') else e - | INDEX (e1, e2) -> - let e1' = ve e1 in - let e2' = ve e2 in - if e1' != e1 || e2' != e2 then INDEX (e1', e2') else e - | MEMBEROF (e1, n) -> - let e1' = ve e1 in - if e1' != e1 then MEMBEROF (e1', n) else e - | MEMBEROFPTR (e1, n) -> - let e1' = ve e1 in - if e1' != e1 then MEMBEROFPTR (e1', n) else e - | GNU_BODY b -> - let b' = visitCabsBlock vis b in - if b' != b then GNU_BODY b' else e - | EXPR_PATTERN _ -> e - -and visitCabsInitExpression vis (ie: init_expression) : init_expression = - doVisit vis vis#vinitexpr childrenInitExpression ie -and childrenInitExpression vis ie = - let rec childrenInitWhat iw = - match iw with - NEXT_INIT -> iw - | INFIELD_INIT (n, iw1) -> - let iw1' = childrenInitWhat iw1 in - if iw1' != iw1 then INFIELD_INIT (n, iw1') else iw - | ATINDEX_INIT (e, iw1) -> - let e' = visitCabsExpression vis e in - let iw1' = childrenInitWhat iw1 in - if e' != e || iw1' != iw1 then ATINDEX_INIT (e', iw1') else iw - | ATINDEXRANGE_INIT (e1, e2) -> - let e1' = visitCabsExpression vis e1 in - let e2' = visitCabsExpression vis e2 in - if e1' != e1 || e2' != e2 then ATINDEXRANGE_INIT (e1, e2) else iw - in - match ie with - NO_INIT -> ie - | SINGLE_INIT e -> - let e' = visitCabsExpression vis e in - if e' != e then SINGLE_INIT e' else ie - | COMPOUND_INIT il -> - let childrenOne ((iw, ie) as input) = - let iw' = childrenInitWhat iw in - let ie' = visitCabsInitExpression vis ie in - if iw' != iw || ie' != ie then (iw', ie') else input - in - let il' = mapNoCopy childrenOne il in - if il' != il then COMPOUND_INIT il' else ie - - -and visitCabsAttribute vis (a: attribute) : attribute list = - doVisitList vis vis#vattr childrenAttribute a - -and childrenAttribute vis ((n, el) as input) = - let el' = mapNoCopy (visitCabsExpression vis) el in - if el' != el then (n, el') else input - -and visitCabsAttributes vis (al: attribute list) : attribute list = - mapNoCopyList (visitCabsAttribute vis) al - -let visitCabsFile (vis: cabsVisitor) ((fname, f): file) : file = - (fname, mapNoCopyList (visitCabsDefinition vis) f) - - (* end of file *) - diff --git a/cil/src/frontc/cabsvisit.mli b/cil/src/frontc/cabsvisit.mli deleted file mode 100644 index d2387892..00000000 --- a/cil/src/frontc/cabsvisit.mli +++ /dev/null @@ -1,115 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(* cabsvisit.mli *) -(* interface for cabsvisit.ml *) - -(* Different visiting actions. 'a will be instantiated with exp, instr, etc. *) -type 'a visitAction = - SkipChildren (* Do not visit the children. Return - * the node as it is *) - | ChangeTo of 'a (* Replace the expression with the - * given one *) - | DoChildren (* Continue with the children of this - * node. Rebuild the node on return - * if any of the children changes - * (use == test) *) - | ChangeDoChildrenPost of 'a * ('a -> 'a) (* First consider that the entire - * exp is replaced by the first - * paramenter. Then continue with - * the children. On return rebuild - * the node if any of the children - * has changed and then apply the - * function on the node *) - -type nameKind = - NVar (** Variable or function prototype - name *) - | NFun (** Function definition name *) - | NField (** The name of a field *) - | NType (** The name of a type *) - - -(* All visit methods are called in preorder! (but you can use - * ChangeDoChildrenPost to change the order) *) -class type cabsVisitor = object - method vexpr: Cabs.expression -> Cabs.expression visitAction (* expressions *) - method vinitexpr: Cabs.init_expression -> Cabs.init_expression visitAction - method vstmt: Cabs.statement -> Cabs.statement list visitAction - method vblock: Cabs.block -> Cabs.block visitAction - method vvar: string -> string (* use of a variable - * names *) - method vdef: Cabs.definition -> Cabs.definition list visitAction - method vtypespec: Cabs.typeSpecifier -> Cabs.typeSpecifier visitAction - method vdecltype: Cabs.decl_type -> Cabs.decl_type visitAction - - (* For each declaration we call vname *) - method vname: nameKind -> Cabs.specifier -> Cabs.name -> Cabs.name visitAction - method vspec: Cabs.specifier -> Cabs.specifier visitAction (* specifier *) - method vattr: Cabs.attribute -> Cabs.attribute list visitAction - - - method vEnterScope: unit -> unit - method vExitScope: unit -> unit -end - - -class nopCabsVisitor: cabsVisitor - - -val visitCabsTypeSpecifier: cabsVisitor -> - Cabs.typeSpecifier -> Cabs.typeSpecifier -val visitCabsSpecifier: cabsVisitor -> Cabs.specifier -> Cabs.specifier - -(** Visits a decl_type. The bool argument is saying whether we are ina - * function definition and thus the scope in a PROTO should extend until the - * end of the function *) -val visitCabsDeclType: cabsVisitor -> bool -> Cabs.decl_type -> Cabs.decl_type -val visitCabsDefinition: cabsVisitor -> Cabs.definition -> Cabs.definition list -val visitCabsBlock: cabsVisitor -> Cabs.block -> Cabs.block -val visitCabsStatement: cabsVisitor -> Cabs.statement -> Cabs.statement list -val visitCabsExpression: cabsVisitor -> Cabs.expression -> Cabs.expression -val visitCabsAttributes: cabsVisitor -> Cabs.attribute list - -> Cabs.attribute list -val visitCabsName: cabsVisitor -> nameKind - -> Cabs.specifier -> Cabs.name -> Cabs.name -val visitCabsFile: cabsVisitor -> Cabs.file -> Cabs.file - - - -(** Set by the visitor to the current location *) -val visitorLocation: Cabs.cabsloc ref diff --git a/cil/src/frontc/clexer.mli b/cil/src/frontc/clexer.mli deleted file mode 100644 index 01acfd04..00000000 --- a/cil/src/frontc/clexer.mli +++ /dev/null @@ -1,55 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - - -(* This interface is generated manually. The corresponding .ml file is - * generated automatically and is placed in ../obj/clexer.ml. The reason we - * want this interface is to avoid confusing make with freshly generated - * interface files *) - - -val init: filename:string -> Lexing.lexbuf -val finish: unit -> unit - -(* This is the main parser function *) -val initial: Lexing.lexbuf -> Cparser.token - - -val push_context: unit -> unit (* Start a context *) -val add_type: string -> unit (* Add a new string as a type name *) -val add_identifier: string -> unit (* Add a new string as a variable name *) -val pop_context: unit -> unit (* Remove all names added in this context *) diff --git a/cil/src/frontc/clexer.mll b/cil/src/frontc/clexer.mll deleted file mode 100644 index 41c86922..00000000 --- a/cil/src/frontc/clexer.mll +++ /dev/null @@ -1,666 +0,0 @@ -(* - * - * Copyright (c) 2001-2003, - * George C. Necula - * Scott McPeak - * Wes Weimer - * Ben Liblit - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) -(* FrontC -- lexical analyzer -** -** 1.0 3.22.99 Hugues Cassé First version. -** 2.0 George Necula 12/12/00: Many extensions -*) -{ -open Cparser -open Pretty -exception Eof -exception InternalError of string -module E = Errormsg -module H = Hashtbl - -let matchingParsOpen = ref 0 - -let currentLoc () = - let l, f, c = E.getPosition () in - { Cabs.lineno = l; - Cabs.filename = f; - Cabs.byteno = c;} - -(* string -> unit *) -let addComment c = - let l = currentLoc() in - let i = GrowArray.max_init_index Cabs.commentsGA in - GrowArray.setg Cabs.commentsGA (i+1) (l,c,false) - -let int64_to_char value = - if (compare value (Int64.of_int 255) > 0) || (compare value Int64.zero < 0) then - begin - let msg = Printf.sprintf "clexer:intlist_to_string: character 0x%Lx too big" value in - E.parse_error msg; - end - else - Char.chr (Int64.to_int value) - -(* takes a not-nul-terminated list, and converts it to a string. *) -let rec intlist_to_string (str: int64 list):string = - match str with - [] -> "" (* add nul-termination *) - | value::rest -> - let this_char = int64_to_char value in - (String.make 1 this_char) ^ (intlist_to_string rest) - -(* Some debugging support for line numbers *) -let dbgToken (t: token) = - if false then begin - ignore (E.log "%a" insert - (match t with - IDENT (n, l) -> dprintf "IDENT(%s,%d)\n" n l.Cabs.lineno - | LBRACE l -> dprintf "LBRACE(%d)\n" l.Cabs.lineno - | RBRACE l -> dprintf "RBRACE(%d)\n" l.Cabs.lineno - | IF l -> dprintf "IF(%d)\n" l.Cabs.lineno - | SWITCH l -> dprintf "SWITCH(%d)\n" l.Cabs.lineno - | RETURN l -> dprintf "RETURN(%d)\n" l.Cabs.lineno - | _ -> nil)); - t - end else - t - - -(* -** Keyword hashtable -*) -let lexicon = H.create 211 -let init_lexicon _ = - H.clear lexicon; - List.iter - (fun (key, builder) -> H.add lexicon key builder) - [ ("auto", fun loc -> AUTO loc); - ("const", fun loc -> CONST loc); - ("__const", fun loc -> CONST loc); - ("__const__", fun loc -> CONST loc); - ("static", fun loc -> STATIC loc); - ("extern", fun loc -> EXTERN loc); - ("long", fun loc -> LONG loc); - ("short", fun loc -> SHORT loc); - ("register", fun loc -> REGISTER loc); - ("signed", fun loc -> SIGNED loc); - ("__signed", fun loc -> SIGNED loc); - ("unsigned", fun loc -> UNSIGNED loc); - ("volatile", fun loc -> VOLATILE loc); - ("__volatile", fun loc -> VOLATILE loc); - (* WW: see /usr/include/sys/cdefs.h for why __signed and __volatile - * are accepted GCC-isms *) - ("char", fun loc -> CHAR loc); - ("int", fun loc -> INT loc); - ("float", fun loc -> FLOAT loc); - ("double", fun loc -> DOUBLE loc); - ("void", fun loc -> VOID loc); - ("enum", fun loc -> ENUM loc); - ("struct", fun loc -> STRUCT loc); - ("typedef", fun loc -> TYPEDEF loc); - ("union", fun loc -> UNION loc); - ("break", fun loc -> BREAK loc); - ("continue", fun loc -> CONTINUE loc); - ("goto", fun loc -> GOTO loc); - ("return", fun loc -> dbgToken (RETURN loc)); - ("switch", fun loc -> dbgToken (SWITCH loc)); - ("case", fun loc -> CASE loc); - ("default", fun loc -> DEFAULT loc); - ("while", fun loc -> WHILE loc); - ("do", fun loc -> DO loc); - ("for", fun loc -> FOR loc); - ("if", fun loc -> dbgToken (IF loc)); - ("else", fun _ -> ELSE); - (*** Implementation specific keywords ***) - ("__signed__", fun loc -> SIGNED loc); - ("__inline__", fun loc -> INLINE loc); - ("inline", fun loc -> INLINE loc); - ("__inline", fun loc -> INLINE loc); - ("_inline", fun loc -> INLINE loc); - ("__attribute__", fun loc -> ATTRIBUTE loc); - ("__attribute", fun loc -> ATTRIBUTE loc); -(* - ("__attribute_used__", fun loc -> ATTRIBUTE_USED loc); -*) - ("__blockattribute__", fun _ -> BLOCKATTRIBUTE); - ("__blockattribute", fun _ -> BLOCKATTRIBUTE); - ("__asm__", fun loc -> ASM loc); - ("asm", fun loc -> ASM loc); - ("__typeof__", fun loc -> TYPEOF loc); - ("__typeof", fun loc -> TYPEOF loc); - ("typeof", fun loc -> TYPEOF loc); - ("__alignof", fun loc -> ALIGNOF loc); - ("__alignof__", fun loc -> ALIGNOF loc); - ("__volatile__", fun loc -> VOLATILE loc); - ("__volatile", fun loc -> VOLATILE loc); - - ("__FUNCTION__", fun loc -> FUNCTION__ loc); - ("__func__", fun loc -> FUNCTION__ loc); (* ISO 6.4.2.2 *) - ("__PRETTY_FUNCTION__", fun loc -> PRETTY_FUNCTION__ loc); - ("__label__", fun _ -> LABEL__); - (*** weimer: GCC arcana ***) - ("__restrict", fun loc -> RESTRICT loc); - ("restrict", fun loc -> RESTRICT loc); -(* ("__extension__", EXTENSION); *) - (**** MS VC ***) - ("__int64", fun _ -> INT64 (currentLoc ())); - ("__int32", fun loc -> INT loc); - ("_cdecl", fun _ -> MSATTR ("_cdecl", currentLoc ())); - ("__cdecl", fun _ -> MSATTR ("__cdecl", currentLoc ())); - ("_stdcall", fun _ -> MSATTR ("_stdcall", currentLoc ())); - ("__stdcall", fun _ -> MSATTR ("__stdcall", currentLoc ())); - ("_fastcall", fun _ -> MSATTR ("_fastcall", currentLoc ())); - ("__fastcall", fun _ -> MSATTR ("__fastcall", currentLoc ())); - ("__w64", fun _ -> MSATTR("__w64", currentLoc ())); - ("__declspec", fun loc -> DECLSPEC loc); - ("__forceinline", fun loc -> INLINE loc); (* !! we turn forceinline - * into inline *) - ("__try", fun loc -> TRY loc); - ("__except", fun loc -> EXCEPT loc); - ("__finally", fun loc -> FINALLY loc); - (* weimer: some files produced by 'GCC -E' expect this type to be - * defined *) - ("__builtin_va_list", - fun _ -> NAMED_TYPE ("__builtin_va_list", currentLoc ())); - ("__builtin_va_arg", fun loc -> BUILTIN_VA_ARG loc); - ("__builtin_types_compatible_p", fun loc -> BUILTIN_TYPES_COMPAT loc); - ("__builtin_offsetof", fun loc -> BUILTIN_OFFSETOF loc); - (* On some versions of GCC __thread is a regular identifier *) - ("__thread", fun loc -> - if Machdep.__thread_is_keyword then - THREAD loc - else - IDENT ("__thread", loc)); - ] - -(* Mark an identifier as a type name. The old mapping is preserved and will - * be reinstated when we exit this context *) -let add_type name = - (* ignore (print_string ("adding type name " ^ name ^ "\n")); *) - H.add lexicon name (fun loc -> NAMED_TYPE (name, loc)) - -let context : string list list ref = ref [] - -let push_context _ = context := []::!context - -let pop_context _ = - match !context with - [] -> raise (InternalError "Empty context stack") - | con::sub -> - (context := sub; - List.iter (fun name -> - (* ignore (print_string ("removing lexicon for " ^ name ^ "\n")); *) - H.remove lexicon name) con) - -(* Mark an identifier as a variable name. The old mapping is preserved and - * will be reinstated when we exit this context *) -let add_identifier name = - match !context with - [] -> () (* Just ignore raise (InternalError "Empty context stack") *) - | con::sub -> - (context := (name::con)::sub; - (* print_string ("adding IDENT for " ^ name ^ "\n"); *) - H.add lexicon name (fun loc -> - dbgToken (IDENT (name, loc)))) - - -(* -** Useful primitives -*) -let scan_ident id = - let here = currentLoc () in - try (H.find lexicon id) here - (* default to variable name, as opposed to type *) - with Not_found -> dbgToken (IDENT (id, here)) - - -(* -** Buffer processor -*) - - -let init ~(filename: string) : Lexing.lexbuf = - init_lexicon (); - (* Inititialize the pointer in Errormsg *) - Lexerhack.add_type := add_type; - Lexerhack.push_context := push_context; - Lexerhack.pop_context := pop_context; - Lexerhack.add_identifier := add_identifier; - E.startParsing filename - - -let finish () = - E.finishParsing () - -(*** Error handling ***) -let error msg = - E.parse_error msg - - -(*** escape character management ***) -let scan_escape (char: char) : int64 = - let result = match char with - 'n' -> '\n' - | 'r' -> '\r' - | 't' -> '\t' - | 'b' -> '\b' - | 'f' -> '\012' (* ASCII code 12 *) - | 'v' -> '\011' (* ASCII code 11 *) - | 'a' -> '\007' (* ASCII code 7 *) - | 'e' | 'E' -> '\027' (* ASCII code 27. This is a GCC extension *) - | '\'' -> '\'' - | '"'-> '"' (* '"' *) - | '?' -> '?' - | '(' when not !Cprint.msvcMode -> '(' - | '{' when not !Cprint.msvcMode -> '{' - | '[' when not !Cprint.msvcMode -> '[' - | '%' when not !Cprint.msvcMode -> '%' - | '\\' -> '\\' - | other -> error ("Unrecognized escape sequence: \\" ^ (String.make 1 other)) - in - Int64.of_int (Char.code result) - -let scan_hex_escape str = - let radix = Int64.of_int 16 in - let the_value = ref Int64.zero in - (* start at character 2 to skip the \x *) - for i = 2 to (String.length str) - 1 do - let thisDigit = Cabs.valueOfDigit (String.get str i) in - (* the_value := !the_value * 16 + thisDigit *) - the_value := Int64.add (Int64.mul !the_value radix) thisDigit - done; - !the_value - -let scan_oct_escape str = - let radix = Int64.of_int 8 in - let the_value = ref Int64.zero in - (* start at character 1 to skip the \x *) - for i = 1 to (String.length str) - 1 do - let thisDigit = Cabs.valueOfDigit (String.get str i) in - (* the_value := !the_value * 8 + thisDigit *) - the_value := Int64.add (Int64.mul !the_value radix) thisDigit - done; - !the_value - -let lex_hex_escape remainder lexbuf = - let prefix = scan_hex_escape (Lexing.lexeme lexbuf) in - prefix :: remainder lexbuf - -let lex_oct_escape remainder lexbuf = - let prefix = scan_oct_escape (Lexing.lexeme lexbuf) in - prefix :: remainder lexbuf - -let lex_simple_escape remainder lexbuf = - let lexchar = Lexing.lexeme_char lexbuf 1 in - let prefix = scan_escape lexchar in - prefix :: remainder lexbuf - -let lex_unescaped remainder lexbuf = - let prefix = Int64.of_int (Char.code (Lexing.lexeme_char lexbuf 0)) in - prefix :: remainder lexbuf - -let lex_comment remainder lexbuf = - let ch = Lexing.lexeme_char lexbuf 0 in - let prefix = Int64.of_int (Char.code ch) in - if ch = '\n' then E.newline(); - prefix :: remainder lexbuf - -let make_char (i:int64):char = - let min_val = Int64.zero in - let max_val = Int64.of_int 255 in - (* if i < 0 || i > 255 then error*) - if compare i min_val < 0 || compare i max_val > 0 then begin - let msg = Printf.sprintf "clexer:make_char: character 0x%Lx too big" i in - error msg - end; - Char.chr (Int64.to_int i) - - -(* ISO standard locale-specific function to convert a wide character - * into a sequence of normal characters. Here we work on strings. - * We convert L"Hi" to "H\000i\000" - matth: this seems unused. -let wbtowc wstr = - let len = String.length wstr in - let dest = String.make (len * 2) '\000' in - for i = 0 to len-1 do - dest.[i*2] <- wstr.[i] ; - done ; - dest -*) - -(* This function converst the "Hi" in L"Hi" to { L'H', L'i', L'\0' } - matth: this seems unused. -let wstr_to_warray wstr = - let len = String.length wstr in - let res = ref "{ " in - for i = 0 to len-1 do - res := !res ^ (Printf.sprintf "L'%c', " wstr.[i]) - done ; - res := !res ^ "}" ; - !res -*) - -(* Pragmas get explicit end-of-line tokens. - * Elsewhere they are silently discarded as whitespace. *) -let pragmaLine = ref false - -} - -let decdigit = ['0'-'9'] -let octdigit = ['0'-'7'] -let hexdigit = ['0'-'9' 'a'-'f' 'A'-'F'] -let letter = ['a'- 'z' 'A'-'Z'] - - -let usuffix = ['u' 'U'] -let lsuffix = "l"|"L"|"ll"|"LL" -let intsuffix = lsuffix | usuffix | usuffix lsuffix | lsuffix usuffix - | usuffix ? "i64" - - -let hexprefix = '0' ['x' 'X'] - -let intnum = decdigit+ intsuffix? -let octnum = '0' octdigit+ intsuffix? -let hexnum = hexprefix hexdigit+ intsuffix? - -let exponent = ['e' 'E']['+' '-']? decdigit+ -let fraction = '.' decdigit+ -let decfloat = (intnum? fraction) - |(intnum exponent) - |(intnum? fraction exponent) - | (intnum '.') - | (intnum '.' exponent) - -let hexfraction = hexdigit* '.' hexdigit+ | hexdigit+ -let binexponent = ['p' 'P'] ['+' '-']? decdigit+ -let hexfloat = hexprefix hexfraction binexponent - | hexprefix hexdigit+ binexponent - -let floatsuffix = ['f' 'F' 'l' 'L'] -let floatnum = (decfloat | hexfloat) floatsuffix? - -let ident = (letter|'_')(letter|decdigit|'_'|'$')* -let blank = [' ' '\t' '\012' '\r']+ -let escape = '\\' _ -let hex_escape = '\\' ['x' 'X'] hexdigit+ -let oct_escape = '\\' octdigit octdigit? octdigit? - -(* Pragmas that are not parsed by CIL. We lex them as PRAGMA_LINE tokens *) - -let no_parse_pragma = - "warning" | "GCC" - (* Solaris-style pragmas: *) - | "ident" | "section" | "option" | "asm" | "use_section" | "weak" - | "redefine_extname" - | "TCS_align" - (* Added by XL *) - | "global_register" - -rule initial = - parse "/*" { let il = comment lexbuf in - let sl = intlist_to_string il in - addComment sl; - initial lexbuf} -| "//" { let il = onelinecomment lexbuf in - let sl = intlist_to_string il in - addComment sl; - E.newline(); - initial lexbuf - } -| blank {initial lexbuf} -| '\n' { E.newline (); - if !pragmaLine then - begin - pragmaLine := false; - PRAGMA_EOL - end - else - initial lexbuf } -| '\\' '\r' * '\n' { - E.newline (); - initial lexbuf - } -| '#' { hash lexbuf} -| "_Pragma" { PRAGMA (currentLoc ()) } -| '\'' { CST_CHAR (chr lexbuf, currentLoc ())} -| "L'" { CST_WCHAR (chr lexbuf, currentLoc ()) } -| '"' { (* '"' *) -(* matth: BUG: this could be either a regular string or a wide string. - * e.g. if it's the "world" in - * L"Hello, " "world" - * then it should be treated as wide even though there's no L immediately - * preceding it. See test/small1/wchar5.c for a failure case. *) - try CST_STRING (str lexbuf, currentLoc ()) - with e -> - raise (InternalError - ("str: " ^ - Printexc.to_string e))} -| "L\"" { (* weimer: wchar_t string literal *) - try CST_WSTRING(str lexbuf, currentLoc ()) - with e -> - raise (InternalError - ("wide string: " ^ - Printexc.to_string e))} -| floatnum {CST_FLOAT (Lexing.lexeme lexbuf, currentLoc ())} -| hexnum {CST_INT (Lexing.lexeme lexbuf, currentLoc ())} -| octnum {CST_INT (Lexing.lexeme lexbuf, currentLoc ())} -| intnum {CST_INT (Lexing.lexeme lexbuf, currentLoc ())} -| "!quit!" {EOF} -| "..." {ELLIPSIS} -| "+=" {PLUS_EQ} -| "-=" {MINUS_EQ} -| "*=" {STAR_EQ} -| "/=" {SLASH_EQ} -| "%=" {PERCENT_EQ} -| "|=" {PIPE_EQ} -| "&=" {AND_EQ} -| "^=" {CIRC_EQ} -| "<<=" {INF_INF_EQ} -| ">>=" {SUP_SUP_EQ} -| "<<" {INF_INF} -| ">>" {SUP_SUP} -| "==" {EQ_EQ} -| "!=" {EXCLAM_EQ} -| "<=" {INF_EQ} -| ">=" {SUP_EQ} -| "=" {EQ} -| "<" {INF} -| ">" {SUP} -| "++" {PLUS_PLUS (currentLoc ())} -| "--" {MINUS_MINUS (currentLoc ())} -| "->" {ARROW} -| '+' {PLUS (currentLoc ())} -| '-' {MINUS (currentLoc ())} -| '*' {STAR (currentLoc ())} -| '/' {SLASH} -| '%' {PERCENT} -| '!' {EXCLAM (currentLoc ())} -| "&&" {AND_AND (currentLoc ())} -| "||" {PIPE_PIPE} -| '&' {AND (currentLoc ())} -| '|' {PIPE} -| '^' {CIRC} -| '?' {QUEST} -| ':' {COLON} -| '~' {TILDE (currentLoc ())} - -| '{' {dbgToken (LBRACE (currentLoc ()))} -| '}' {dbgToken (RBRACE (currentLoc ()))} -| '[' {LBRACKET} -| ']' {RBRACKET} -| '(' {dbgToken (LPAREN (currentLoc ())) } -| ')' {RPAREN} -| ';' {dbgToken (SEMICOLON (currentLoc ())) } -| ',' {COMMA} -| '.' {DOT} -| "sizeof" {SIZEOF (currentLoc ())} -| "__asm" { if !Cprint.msvcMode then - MSASM (msasm lexbuf, currentLoc ()) - else (ASM (currentLoc ())) } - -(* If we see __pragma we eat it and the matching parentheses as well *) -| "__pragma" { matchingParsOpen := 0; - let _ = matchingpars lexbuf in - initial lexbuf - } - -(* sm: tree transformation keywords *) -| "@transform" {AT_TRANSFORM (currentLoc ())} -| "@transformExpr" {AT_TRANSFORMEXPR (currentLoc ())} -| "@specifier" {AT_SPECIFIER (currentLoc ())} -| "@expr" {AT_EXPR (currentLoc ())} -| "@name" {AT_NAME} - -(* __extension__ is a black. The parser runs into some conflicts if we let it - * pass *) -| "__extension__" {initial lexbuf } -| ident {scan_ident (Lexing.lexeme lexbuf)} -| eof {EOF} -| _ {E.parse_error "Invalid symbol"} -and comment = - parse - "*/" { [] } -(*| '\n' { E.newline (); lex_unescaped comment lexbuf }*) -| _ { lex_comment comment lexbuf } - - -and onelinecomment = parse - '\n' {[]} -| _ { lex_comment onelinecomment lexbuf } - -and matchingpars = parse - '\n' { E.newline (); matchingpars lexbuf } -| blank { matchingpars lexbuf } -| '(' { incr matchingParsOpen; matchingpars lexbuf } -| ')' { decr matchingParsOpen; - if !matchingParsOpen = 0 then - () - else - matchingpars lexbuf - } -| "/*" { let il = comment lexbuf in - let sl = intlist_to_string il in - addComment sl; - matchingpars lexbuf} -| '"' { (* '"' *) - let _ = str lexbuf in - matchingpars lexbuf - } -| _ { matchingpars lexbuf } - -(* # ... *) -and hash = parse - '\n' { E.newline (); initial lexbuf} -| blank { hash lexbuf} -| intnum { (* We are seeing a line number. This is the number for the - * next line *) - let s = Lexing.lexeme lexbuf in - begin try - E.setCurrentLine (int_of_string s - 1) - with Failure _ -> - E.warn "Bad line number in preprocessed file: %s" s - end; - (* A file name must follow *) - file lexbuf } -| "line" { hash lexbuf } (* MSVC line number info *) - (* For pragmas with irregular syntax, like #pragma warning, - * we parse them as a whole line. *) -| "pragma" blank (no_parse_pragma as pragmaName) - { let here = currentLoc () in - PRAGMA_LINE (pragmaName ^ pragma lexbuf, here) - } -| "pragma" { pragmaLine := true; PRAGMA (currentLoc ()) } -| _ { endline lexbuf} - -and file = parse - '\n' {E.newline (); initial lexbuf} -| blank {file lexbuf} -| '"' [^ '\012' '\t' '"']* '"' { (* '"' *) - let n = Lexing.lexeme lexbuf in - let n1 = String.sub n 1 - ((String.length n) - 2) in - E.setCurrentFile n1; - endline lexbuf} - -| _ {endline lexbuf} - -and endline = parse - '\n' { E.newline (); initial lexbuf} -| eof { EOF } -| _ { endline lexbuf} - -and pragma = parse - '\n' { E.newline (); "" } -| _ { let cur = Lexing.lexeme lexbuf in - cur ^ (pragma lexbuf) } - -and str = parse - '"' {[]} (* no nul terminiation in CST_STRING '"' *) -| hex_escape {lex_hex_escape str lexbuf} -| oct_escape {lex_oct_escape str lexbuf} -| escape {lex_simple_escape str lexbuf} -| _ {lex_unescaped str lexbuf} - -and chr = parse - '\'' {[]} -| hex_escape {lex_hex_escape chr lexbuf} -| oct_escape {lex_oct_escape chr lexbuf} -| escape {lex_simple_escape chr lexbuf} -| _ {lex_unescaped chr lexbuf} - -and msasm = parse - blank { msasm lexbuf } -| '{' { msasminbrace lexbuf } -| _ { let cur = Lexing.lexeme lexbuf in - cur ^ (msasmnobrace lexbuf) } - -and msasminbrace = parse - '}' { "" } -| _ { let cur = Lexing.lexeme lexbuf in - cur ^ (msasminbrace lexbuf) } -and msasmnobrace = parse - ['}' ';' '\n'] { lexbuf.Lexing.lex_curr_pos <- - lexbuf.Lexing.lex_curr_pos - 1; - "" } -| "__asm" { lexbuf.Lexing.lex_curr_pos <- - lexbuf.Lexing.lex_curr_pos - 5; - "" } -| _ { let cur = Lexing.lexeme lexbuf in - - cur ^ (msasmnobrace lexbuf) } - -{ - -} diff --git a/cil/src/frontc/cparser.mly b/cil/src/frontc/cparser.mly deleted file mode 100644 index f1e1ef94..00000000 --- a/cil/src/frontc/cparser.mly +++ /dev/null @@ -1,1521 +0,0 @@ -/*(* - * - * Copyright (c) 2001-2003, - * George C. Necula - * Scott McPeak - * Wes Weimer - * Ben Liblit - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - **) -(** -** 1.0 3.22.99 Hugues Cassé First version. -** 2.0 George Necula 12/12/00: Practically complete rewrite. -*) -*/ -%{ -open Cabs -module E = Errormsg - -let parse_error msg : unit = (* sm: c++-mode highlight hack: -> ' <- *) - E.parse_error msg - -let print = print_string - -(* unit -> string option *) -(* -let getComments () = - match !comments with - [] -> None - | _ -> - let r = Some(String.concat "\n" (List.rev !comments)) in - comments := []; - r -*) - -let currentLoc () = - let l, f, c = E.getPosition () in - { lineno = l; - filename = f; - byteno = c;} - -let cabslu = {lineno = -10; - filename = "cabs loc unknown"; - byteno = -10;} - -(* cabsloc -> cabsloc *) -(* -let handleLoc l = - l.clcomment <- getComments(); - l -*) - -(* -** Expression building -*) -let smooth_expression lst = - match lst with - [] -> NOTHING - | [expr] -> expr - | _ -> COMMA (lst) - - -let currentFunctionName = ref "" - -let announceFunctionName ((n, decl, _, _):name) = - !Lexerhack.add_identifier n; - (* Start a context that includes the parameter names and the whole body. - * Will pop when we finish parsing the function body *) - !Lexerhack.push_context (); - (* Go through all the parameter names and mark them as identifiers *) - let rec findProto = function - PROTO (d, args, _) when isJUSTBASE d -> - List.iter (fun (_, (an, _, _, _)) -> !Lexerhack.add_identifier an) args - - | PROTO (d, _, _) -> findProto d - | PARENTYPE (_, d, _) -> findProto d - | PTR (_, d) -> findProto d - | ARRAY (d, _, _) -> findProto d - | _ -> parse_error "Cannot find the prototype in a function definition"; - raise Parsing.Parse_error - - and isJUSTBASE = function - JUSTBASE -> true - | PARENTYPE (_, d, _) -> isJUSTBASE d - | _ -> false - in - findProto decl; - currentFunctionName := n - - - -let applyPointer (ptspecs: attribute list list) (dt: decl_type) - : decl_type = - (* Outer specification first *) - let rec loop = function - [] -> dt - | attrs :: rest -> PTR(attrs, loop rest) - in - loop ptspecs - -let doDeclaration (loc: cabsloc) (specs: spec_elem list) (nl: init_name list) : definition = - if isTypedef specs then begin - (* Tell the lexer about the new type names *) - List.iter (fun ((n, _, _, _), _) -> !Lexerhack.add_type n) nl; - TYPEDEF ((specs, List.map (fun (n, _) -> n) nl), loc) - end else - if nl = [] then - ONLYTYPEDEF (specs, loc) - else begin - (* Tell the lexer about the new variable names *) - List.iter (fun ((n, _, _, _), _) -> !Lexerhack.add_identifier n) nl; - DECDEF ((specs, nl), loc) - end - - -let doFunctionDef (loc: cabsloc) - (lend: cabsloc) - (specs: spec_elem list) - (n: name) - (b: block) : definition = - let fname = (specs, n) in - FUNDEF (fname, b, loc, lend) - - -let doOldParDecl (names: string list) - ((pardefs: name_group list), (isva: bool)) - : single_name list * bool = - let findOneName n = - (* Search in pardefs for the definition for this parameter *) - let rec loopGroups = function - [] -> ([SpecType Tint], (n, JUSTBASE, [], cabslu)) - | (specs, names) :: restgroups -> - let rec loopNames = function - [] -> loopGroups restgroups - | ((n',_, _, _) as sn) :: _ when n' = n -> (specs, sn) - | _ :: restnames -> loopNames restnames - in - loopNames names - in - loopGroups pardefs - in - let args = List.map findOneName names in - (args, isva) - -let checkConnective (s : string) : unit = -begin - (* checking this means I could possibly have more connectives, with *) - (* different meaning *) - if (s <> "to") then ( - parse_error "transformer connective must be 'to'"; - raise Parsing.Parse_error - ) - else () -end - -let int64_to_char value = - if (compare value (Int64.of_int 255) > 0) || (compare value Int64.zero < 0) then - begin - let msg = Printf.sprintf "cparser:intlist_to_string: character 0x%Lx too big" value in - parse_error msg; - raise Parsing.Parse_error - end - else - Char.chr (Int64.to_int value) - -(* takes a not-nul-terminated list, and converts it to a string. *) -let rec intlist_to_string (str: int64 list):string = - match str with - [] -> "" (* add nul-termination *) - | value::rest -> - let this_char = int64_to_char value in - (String.make 1 this_char) ^ (intlist_to_string rest) - -let fst3 (result, _, _) = result -let snd3 (_, result, _) = result -let trd3 (_, _, result) = result - - -(* - transform: __builtin_offsetof(type, member) - into : (size_t) (&(type * ) 0)->member - *) - -let transformOffsetOf (speclist, dtype) member = - let rec addPointer = function - | JUSTBASE -> - PTR([], JUSTBASE) - | PARENTYPE (attrs1, dtype, attrs2) -> - PARENTYPE (attrs1, addPointer dtype, attrs2) - | ARRAY (dtype, attrs, expr) -> - ARRAY (addPointer dtype, attrs, expr) - | PTR (attrs, dtype) -> - PTR (attrs, addPointer dtype) - | PROTO (dtype, names, variadic) -> - PROTO (addPointer dtype, names, variadic) - in - let nullType = (speclist, addPointer dtype) in - let nullExpr = CONSTANT (CONST_INT "0") in - let castExpr = CAST (nullType, SINGLE_INIT nullExpr) in - - let rec replaceBase = function - | VARIABLE field -> - MEMBEROFPTR (castExpr, field) - | MEMBEROF (base, field) -> - MEMBEROF (replaceBase base, field) - | INDEX (base, index) -> - INDEX (replaceBase base, index) - | _ -> - parse_error "malformed offset expression in __builtin_offsetof"; - raise Parsing.Parse_error - in - let memberExpr = replaceBase member in - let addrExpr = UNARY (ADDROF, memberExpr) in - (* slight cheat: hard-coded assumption that size_t == unsigned int *) - let sizeofType = [SpecType Tunsigned], JUSTBASE in - let resultExpr = CAST (sizeofType, SINGLE_INIT addrExpr) in - resultExpr - -%} - -%token IDENT -%token CST_CHAR -%token CST_WCHAR -%token CST_INT -%token CST_FLOAT -%token NAMED_TYPE - -/* Each character is its own list element, and the terminating nul is not - included in this list. */ -%token CST_STRING -%token CST_WSTRING - -%token EOF -%token CHAR INT DOUBLE FLOAT VOID INT64 INT32 -%token ENUM STRUCT TYPEDEF UNION -%token SIGNED UNSIGNED LONG SHORT -%token VOLATILE EXTERN STATIC CONST RESTRICT AUTO REGISTER -%token THREAD - -%token SIZEOF ALIGNOF - -%token EQ PLUS_EQ MINUS_EQ STAR_EQ SLASH_EQ PERCENT_EQ -%token AND_EQ PIPE_EQ CIRC_EQ INF_INF_EQ SUP_SUP_EQ -%token ARROW DOT - -%token EQ_EQ EXCLAM_EQ INF SUP INF_EQ SUP_EQ -%token PLUS MINUS STAR -%token SLASH PERCENT -%token TILDE AND -%token PIPE CIRC -%token EXCLAM AND_AND -%token PIPE_PIPE -%token INF_INF SUP_SUP -%token PLUS_PLUS MINUS_MINUS - -%token RPAREN -%token LPAREN RBRACE -%token LBRACE -%token LBRACKET RBRACKET -%token COLON -%token SEMICOLON -%token COMMA ELLIPSIS QUEST - -%token BREAK CONTINUE GOTO RETURN -%token SWITCH CASE DEFAULT -%token WHILE DO FOR -%token IF TRY EXCEPT FINALLY -%token ELSE - -%token ATTRIBUTE INLINE ASM TYPEOF FUNCTION__ PRETTY_FUNCTION__ -%token LABEL__ -%token BUILTIN_VA_ARG ATTRIBUTE_USED -%token BUILTIN_VA_LIST -%token BLOCKATTRIBUTE -%token BUILTIN_TYPES_COMPAT BUILTIN_OFFSETOF -%token DECLSPEC -%token MSASM MSATTR -%token PRAGMA_LINE -%token PRAGMA -%token PRAGMA_EOL - -/* sm: cabs tree transformation specification keywords */ -%token AT_TRANSFORM AT_TRANSFORMEXPR AT_SPECIFIER AT_EXPR -%token AT_NAME - -/* operator precedence */ -%nonassoc IF -%nonassoc ELSE - - -%left COMMA -%right EQ PLUS_EQ MINUS_EQ STAR_EQ SLASH_EQ PERCENT_EQ - AND_EQ PIPE_EQ CIRC_EQ INF_INF_EQ SUP_SUP_EQ -%right QUEST COLON -%left PIPE_PIPE -%left AND_AND -%left PIPE -%left CIRC -%left AND -%left EQ_EQ EXCLAM_EQ -%left INF SUP INF_EQ SUP_EQ -%left INF_INF SUP_SUP -%left PLUS MINUS -%left STAR SLASH PERCENT CONST RESTRICT VOLATILE -%right EXCLAM TILDE PLUS_PLUS MINUS_MINUS CAST RPAREN ADDROF SIZEOF ALIGNOF -%left LBRACKET -%left DOT ARROW LPAREN LBRACE -%right NAMED_TYPE /* We'll use this to handle redefinitions of - * NAMED_TYPE as variables */ -%left IDENT - -/* Non-terminals informations */ -%start interpret file -%type file interpret globals - -%type global - - -%type attributes attributes_with_asm asmattr -%type statement -%type constant -%type string_constant -%type expression -%type opt_expression -%type init_expression -%type comma_expression -%type paren_comma_expression -%type arguments -%type bracket_comma_expression -%type string_list -%type wstring_list - -%type initializer -%type <(Cabs.initwhat * Cabs.init_expression) list> initializer_list -%type init_designators init_designators_opt - -%type decl_spec_list -%type type_spec -%type struct_decl_list - - -%type old_proto_decl -%type parameter_decl -%type enumerator -%type enum_list -%type declaration function_def -%type function_def_start -%type type_name -%type block -%type block_element_list -%type local_labels local_label_names -%type old_parameter_list_ne - -%type init_declarator -%type init_declarator_list -%type declarator -%type field_decl -%type <(Cabs.name * expression option) list> field_decl_list -%type direct_decl -%type abs_direct_decl abs_direct_decl_opt -%type abstract_decl - - /* (* Each element is a "* ". *) */ -%type pointer pointer_opt -%type location -%type cvspec -%% - -interpret: - file EOF {$1} -; -file: globals {$1} -; -globals: - /* empty */ { [] } -| global globals { $1 :: $2 } -| SEMICOLON globals { $2 } -; - -location: - /* empty */ { currentLoc () } %prec IDENT - - -/*** Global Definition ***/ -global: -| declaration { $1 } -| function_def { $1 } -/*(* Some C header files ar shared with the C++ compiler and have linkage - * specification *)*/ -| EXTERN string_constant declaration { LINKAGE (fst $2, (*handleLoc*) (snd $2), [ $3 ]) } -| EXTERN string_constant LBRACE globals RBRACE - { LINKAGE (fst $2, (*handleLoc*) (snd $2), $4) } -| ASM LPAREN string_constant RPAREN SEMICOLON - { GLOBASM (fst $3, (*handleLoc*) $1) } -| pragma { $1 } -/* (* Old-style function prototype. This should be somewhere else, like in - * "declaration". For now we keep it at global scope only because in local - * scope it looks too much like a function call *) */ -| IDENT LPAREN old_parameter_list_ne RPAREN old_pardef_list SEMICOLON - { (* Convert pardecl to new style *) - let pardecl, isva = doOldParDecl $3 $5 in - (* Make the function declarator *) - doDeclaration ((*handleLoc*) (snd $1)) [] - [((fst $1, PROTO(JUSTBASE, pardecl,isva), [], cabslu), - NO_INIT)] - } -/* (* Old style function prototype, but without any arguments *) */ -| IDENT LPAREN RPAREN SEMICOLON - { (* Make the function declarator *) - doDeclaration ((*handleLoc*)(snd $1)) [] - [((fst $1, PROTO(JUSTBASE,[],false), [], cabslu), - NO_INIT)] - } -/* transformer for a toplevel construct */ -| AT_TRANSFORM LBRACE global RBRACE IDENT/*to*/ LBRACE globals RBRACE { - checkConnective(fst $5); - TRANSFORMER($3, $7, $1) - } -/* transformer for an expression */ -| AT_TRANSFORMEXPR LBRACE expression RBRACE IDENT/*to*/ LBRACE expression RBRACE { - checkConnective(fst $5); - EXPRTRANSFORMER(fst $3, fst $7, $1) - } -| location error SEMICOLON { PRAGMA (VARIABLE "parse_error", $1) } -; - -id_or_typename: - IDENT {fst $1} -| NAMED_TYPE {fst $1} -| AT_NAME LPAREN IDENT RPAREN { "@name(" ^ fst $3 ^ ")" } /* pattern variable name */ -; - -maybecomma: - /* empty */ { () } -| COMMA { () } -; - -/* *** Expressions *** */ - -primary_expression: /*(* 6.5.1. *)*/ -| IDENT - {VARIABLE (fst $1), snd $1} -| constant - {CONSTANT (fst $1), snd $1} -| paren_comma_expression - {smooth_expression (fst $1), snd $1} -| LPAREN block RPAREN - { GNU_BODY (fst3 $2), $1 } - - /*(* Next is Scott's transformer *)*/ -| AT_EXPR LPAREN IDENT RPAREN /* expression pattern variable */ - { EXPR_PATTERN(fst $3), $1 } -; - -postfix_expression: /*(* 6.5.2 *)*/ -| primary_expression - { $1 } -| postfix_expression bracket_comma_expression - {INDEX (fst $1, smooth_expression $2), snd $1} -| postfix_expression LPAREN arguments RPAREN - {CALL (fst $1, $3), snd $1} -| BUILTIN_VA_ARG LPAREN expression COMMA type_name RPAREN - { let b, d = $5 in - CALL (VARIABLE "__builtin_va_arg", - [fst $3; TYPE_SIZEOF (b, d)]), $1 } -| BUILTIN_TYPES_COMPAT LPAREN type_name COMMA type_name RPAREN - { let b1,d1 = $3 in - let b2,d2 = $5 in - CALL (VARIABLE "__builtin_types_compatible_p", - [TYPE_SIZEOF(b1,d1); TYPE_SIZEOF(b2,d2)]), $1 } -| BUILTIN_OFFSETOF LPAREN type_name COMMA offsetof_member_designator RPAREN - { transformOffsetOf $3 (fst $5), $1 } -| postfix_expression DOT id_or_typename - {MEMBEROF (fst $1, $3), snd $1} -| postfix_expression ARROW id_or_typename - {MEMBEROFPTR (fst $1, $3), snd $1} -| postfix_expression PLUS_PLUS - {UNARY (POSINCR, fst $1), snd $1} -| postfix_expression MINUS_MINUS - {UNARY (POSDECR, fst $1), snd $1} -/* (* We handle GCC constructor expressions *) */ -| LPAREN type_name RPAREN LBRACE initializer_list_opt RBRACE - { CAST($2, COMPOUND_INIT $5), $1 } -; - -offsetof_member_designator: /* GCC extension for __builtin_offsetof */ -| IDENT - { VARIABLE (fst $1), snd $1 } -| offsetof_member_designator DOT IDENT - { MEMBEROF (fst $1, fst $3), snd $1 } -| offsetof_member_designator bracket_comma_expression - { INDEX (fst $1, smooth_expression $2), snd $1 } -; - -unary_expression: /*(* 6.5.3 *)*/ -| postfix_expression - { $1 } -| PLUS_PLUS unary_expression - {UNARY (PREINCR, fst $2), $1} -| MINUS_MINUS unary_expression - {UNARY (PREDECR, fst $2), $1} -| SIZEOF unary_expression - {EXPR_SIZEOF (fst $2), $1} -| SIZEOF LPAREN type_name RPAREN - {let b, d = $3 in TYPE_SIZEOF (b, d), $1} -| ALIGNOF unary_expression - {EXPR_ALIGNOF (fst $2), $1} -| ALIGNOF LPAREN type_name RPAREN - {let b, d = $3 in TYPE_ALIGNOF (b, d), $1} -| PLUS cast_expression - {UNARY (PLUS, fst $2), $1} -| MINUS cast_expression - {UNARY (MINUS, fst $2), $1} -| STAR cast_expression - {UNARY (MEMOF, fst $2), $1} -| AND cast_expression - {UNARY (ADDROF, fst $2), $1} -| EXCLAM cast_expression - {UNARY (NOT, fst $2), $1} -| TILDE cast_expression - {UNARY (BNOT, fst $2), $1} -| AND_AND IDENT { LABELADDR (fst $2), $1 } -; - -cast_expression: /*(* 6.5.4 *)*/ -| unary_expression - { $1 } -| LPAREN type_name RPAREN cast_expression - { CAST($2, SINGLE_INIT (fst $4)), $1 } -; - -multiplicative_expression: /*(* 6.5.5 *)*/ -| cast_expression - { $1 } -| multiplicative_expression STAR cast_expression - {BINARY(MUL, fst $1, fst $3), snd $1} -| multiplicative_expression SLASH cast_expression - {BINARY(DIV, fst $1, fst $3), snd $1} -| multiplicative_expression PERCENT cast_expression - {BINARY(MOD, fst $1, fst $3), snd $1} -; - -additive_expression: /*(* 6.5.6 *)*/ -| multiplicative_expression - { $1 } -| additive_expression PLUS multiplicative_expression - {BINARY(ADD, fst $1, fst $3), snd $1} -| additive_expression MINUS multiplicative_expression - {BINARY(SUB, fst $1, fst $3), snd $1} -; - -shift_expression: /*(* 6.5.7 *)*/ -| additive_expression - { $1 } -| shift_expression INF_INF additive_expression - {BINARY(SHL, fst $1, fst $3), snd $1} -| shift_expression SUP_SUP additive_expression - {BINARY(SHR, fst $1, fst $3), snd $1} -; - - -relational_expression: /*(* 6.5.8 *)*/ -| shift_expression - { $1 } -| relational_expression INF shift_expression - {BINARY(LT, fst $1, fst $3), snd $1} -| relational_expression SUP shift_expression - {BINARY(GT, fst $1, fst $3), snd $1} -| relational_expression INF_EQ shift_expression - {BINARY(LE, fst $1, fst $3), snd $1} -| relational_expression SUP_EQ shift_expression - {BINARY(GE, fst $1, fst $3), snd $1} -; - -equality_expression: /*(* 6.5.9 *)*/ -| relational_expression - { $1 } -| equality_expression EQ_EQ relational_expression - {BINARY(EQ, fst $1, fst $3), snd $1} -| equality_expression EXCLAM_EQ relational_expression - {BINARY(NE, fst $1, fst $3), snd $1} -; - - -bitwise_and_expression: /*(* 6.5.10 *)*/ -| equality_expression - { $1 } -| bitwise_and_expression AND equality_expression - {BINARY(BAND, fst $1, fst $3), snd $1} -; - -bitwise_xor_expression: /*(* 6.5.11 *)*/ -| bitwise_and_expression - { $1 } -| bitwise_xor_expression CIRC bitwise_and_expression - {BINARY(XOR, fst $1, fst $3), snd $1} -; - -bitwise_or_expression: /*(* 6.5.12 *)*/ -| bitwise_xor_expression - { $1 } -| bitwise_or_expression PIPE bitwise_xor_expression - {BINARY(BOR, fst $1, fst $3), snd $1} -; - -logical_and_expression: /*(* 6.5.13 *)*/ -| bitwise_or_expression - { $1 } -| logical_and_expression AND_AND bitwise_or_expression - {BINARY(AND, fst $1, fst $3), snd $1} -; - -logical_or_expression: /*(* 6.5.14 *)*/ -| logical_and_expression - { $1 } -| logical_or_expression PIPE_PIPE logical_and_expression - {BINARY(OR, fst $1, fst $3), snd $1} -; - -conditional_expression: /*(* 6.5.15 *)*/ -| logical_or_expression - { $1 } -| logical_or_expression QUEST opt_expression COLON conditional_expression - {QUESTION (fst $1, $3, fst $5), snd $1} -; - -/*(* The C spec says that left-hand sides of assignment expressions are unary - * expressions. GCC allows cast expressions in there ! *)*/ - -assignment_expression: /*(* 6.5.16 *)*/ -| conditional_expression - { $1 } -| cast_expression EQ assignment_expression - {BINARY(ASSIGN, fst $1, fst $3), snd $1} -| cast_expression PLUS_EQ assignment_expression - {BINARY(ADD_ASSIGN, fst $1, fst $3), snd $1} -| cast_expression MINUS_EQ assignment_expression - {BINARY(SUB_ASSIGN, fst $1, fst $3), snd $1} -| cast_expression STAR_EQ assignment_expression - {BINARY(MUL_ASSIGN, fst $1, fst $3), snd $1} -| cast_expression SLASH_EQ assignment_expression - {BINARY(DIV_ASSIGN, fst $1, fst $3), snd $1} -| cast_expression PERCENT_EQ assignment_expression - {BINARY(MOD_ASSIGN, fst $1, fst $3), snd $1} -| cast_expression AND_EQ assignment_expression - {BINARY(BAND_ASSIGN, fst $1, fst $3), snd $1} -| cast_expression PIPE_EQ assignment_expression - {BINARY(BOR_ASSIGN, fst $1, fst $3), snd $1} -| cast_expression CIRC_EQ assignment_expression - {BINARY(XOR_ASSIGN, fst $1, fst $3), snd $1} -| cast_expression INF_INF_EQ assignment_expression - {BINARY(SHL_ASSIGN, fst $1, fst $3), snd $1} -| cast_expression SUP_SUP_EQ assignment_expression - {BINARY(SHR_ASSIGN, fst $1, fst $3), snd $1} -; - -expression: /*(* 6.5.17 *)*/ - assignment_expression - { $1 } -; - - -constant: - CST_INT {CONST_INT (fst $1), snd $1} -| CST_FLOAT {CONST_FLOAT (fst $1), snd $1} -| CST_CHAR {CONST_CHAR (fst $1), snd $1} -| CST_WCHAR {CONST_WCHAR (fst $1), snd $1} -| string_constant {CONST_STRING (fst $1), snd $1} -| wstring_list {CONST_WSTRING (fst $1), snd $1} -; - -string_constant: -/* Now that we know this constant isn't part of a wstring, convert it - back to a string for easy viewing. */ - string_list { - let queue, location = $1 in - let buffer = Buffer.create (Queue.length queue) in - Queue.iter - (List.iter - (fun value -> - let char = int64_to_char value in - Buffer.add_char buffer char)) - queue; - Buffer.contents buffer, location - } -; -one_string_constant: -/* Don't concat multiple strings. For asm templates. */ - CST_STRING {intlist_to_string (fst $1) } -; -string_list: - one_string { - let queue = Queue.create () in - Queue.add (fst $1) queue; - queue, snd $1 - } -| string_list one_string { - Queue.add (fst $2) (fst $1); - $1 - } -; - -wstring_list: - CST_WSTRING { $1 } -| wstring_list one_string { (fst $1) @ (fst $2), snd $1 } -| wstring_list CST_WSTRING { (fst $1) @ (fst $2), snd $1 } -/* Only the first string in the list needs an L, so L"a" "b" is the same - * as L"ab" or L"a" L"b". */ - -one_string: - CST_STRING {$1} -| FUNCTION__ {(Cabs.explodeStringToInts - !currentFunctionName), $1} -| PRETTY_FUNCTION__ {(Cabs.explodeStringToInts - !currentFunctionName), $1} -; - -init_expression: - expression { SINGLE_INIT (fst $1) } -| LBRACE initializer_list_opt RBRACE - { COMPOUND_INIT $2} - -initializer_list: /* ISO 6.7.8. Allow a trailing COMMA */ - initializer { [$1] } -| initializer COMMA initializer_list_opt { $1 :: $3 } -; -initializer_list_opt: - /* empty */ { [] } -| initializer_list { $1 } -; -initializer: - init_designators eq_opt init_expression { ($1, $3) } -| gcc_init_designators init_expression { ($1, $2) } -| init_expression { (NEXT_INIT, $1) } -; -eq_opt: - EQ { () } - /*(* GCC allows missing = *)*/ -| /*(* empty *)*/ { () } -; -init_designators: - DOT id_or_typename init_designators_opt { INFIELD_INIT($2, $3) } -| LBRACKET expression RBRACKET init_designators_opt - { ATINDEX_INIT(fst $2, $4) } -| LBRACKET expression ELLIPSIS expression RBRACKET - { ATINDEXRANGE_INIT(fst $2, fst $4) } -; -init_designators_opt: - /* empty */ { NEXT_INIT } -| init_designators { $1 } -; - -gcc_init_designators: /*(* GCC supports these strange things *)*/ - id_or_typename COLON { INFIELD_INIT($1, NEXT_INIT) } -; - -arguments: - /* empty */ { [] } -| comma_expression { fst $1 } -; - -opt_expression: - /* empty */ - {NOTHING} -| comma_expression - {smooth_expression (fst $1)} -; - -comma_expression: - expression {[fst $1], snd $1} -| expression COMMA comma_expression { fst $1 :: fst $3, snd $1 } -| error COMMA comma_expression { $3 } -; - -comma_expression_opt: - /* empty */ { NOTHING } -| comma_expression { smooth_expression (fst $1) } -; - -paren_comma_expression: - LPAREN comma_expression RPAREN { $2 } -| LPAREN error RPAREN { [], $1 } -; - -bracket_comma_expression: - LBRACKET comma_expression RBRACKET { fst $2 } -| LBRACKET error RBRACKET { [] } -; - - -/*** statements ***/ -block: /* ISO 6.8.2 */ - block_begin local_labels block_attrs block_element_list RBRACE - {!Lexerhack.pop_context(); - { blabels = $2; - battrs = $3; - bstmts = $4 }, - $1, $5 - } -| error location RBRACE { { blabels = []; - battrs = []; - bstmts = [] }, - $2, $3 - } -; -block_begin: - LBRACE {!Lexerhack.push_context (); $1} -; - -block_attrs: - /* empty */ { [] } -| BLOCKATTRIBUTE paren_attr_list_ne - { [("__blockattribute__", $2)] } -; - -/* statements and declarations in a block, in any order (for C99 support) */ -block_element_list: - /* empty */ { [] } -| declaration block_element_list { DEFINITION($1) :: $2 } -| statement block_element_list { $1 :: $2 } -/*(* GCC accepts a label at the end of a block *)*/ -| IDENT COLON { [ LABEL (fst $1, NOP (snd $1), - snd $1)] } -| pragma block_element_list { $2 } -; - -local_labels: - /* empty */ { [] } -| LABEL__ local_label_names SEMICOLON local_labels { $2 @ $4 } -; -local_label_names: - IDENT { [ fst $1 ] } -| IDENT COMMA local_label_names { fst $1 :: $3 } -; - - - -statement: - SEMICOLON {NOP ((*handleLoc*) $1) } -| comma_expression SEMICOLON - {COMPUTATION (smooth_expression (fst $1), (*handleLoc*)(snd $1))} -| block {BLOCK (fst3 $1, (*handleLoc*)(snd3 $1))} -| IF paren_comma_expression statement %prec IF - {IF (smooth_expression (fst $2), $3, NOP $1, $1)} -| IF paren_comma_expression statement ELSE statement - {IF (smooth_expression (fst $2), $3, $5, (*handleLoc*) $1)} -| SWITCH paren_comma_expression statement - {SWITCH (smooth_expression (fst $2), $3, (*handleLoc*) $1)} -| WHILE paren_comma_expression statement - {WHILE (smooth_expression (fst $2), $3, (*handleLoc*) $1)} -| DO statement WHILE paren_comma_expression SEMICOLON - {DOWHILE (smooth_expression (fst $4), $2, (*handleLoc*) $1)} -| FOR LPAREN for_clause opt_expression - SEMICOLON opt_expression RPAREN statement - {FOR ($3, $4, $6, $8, (*handleLoc*) $1)} -| IDENT COLON statement - {LABEL (fst $1, $3, (*handleLoc*) (snd $1))} -| CASE expression COLON statement - {CASE (fst $2, $4, (*handleLoc*) $1)} -| CASE expression ELLIPSIS expression COLON statement - {CASERANGE (fst $2, fst $4, $6, (*handleLoc*) $1)} -| DEFAULT COLON - {DEFAULT (NOP $1, (*handleLoc*) $1)} -| RETURN SEMICOLON {RETURN (NOTHING, (*handleLoc*) $1)} -| RETURN comma_expression SEMICOLON - {RETURN (smooth_expression (fst $2), (*handleLoc*) $1)} -| BREAK SEMICOLON {BREAK ((*handleLoc*) $1)} -| CONTINUE SEMICOLON {CONTINUE ((*handleLoc*) $1)} -| GOTO IDENT SEMICOLON - {GOTO (fst $2, (*handleLoc*) $1)} -| GOTO STAR comma_expression SEMICOLON - { COMPGOTO (smooth_expression (fst $3), (*handleLoc*) $1) } -| ASM asmattr LPAREN asmtemplate asmoutputs RPAREN SEMICOLON - { ASM ($2, $4, $5, (*handleLoc*) $1) } -| MSASM { ASM ([], [fst $1], None, (*handleLoc*)(snd $1))} -| TRY block EXCEPT paren_comma_expression block - { let b, _, _ = $2 in - let h, _, _ = $5 in - if not !Cprint.msvcMode then - parse_error "try/except in GCC code"; - TRY_EXCEPT (b, COMMA (fst $4), h, (*handleLoc*) $1) } -| TRY block FINALLY block - { let b, _, _ = $2 in - let h, _, _ = $4 in - if not !Cprint.msvcMode then - parse_error "try/finally in GCC code"; - TRY_FINALLY (b, h, (*handleLoc*) $1) } - -| error location SEMICOLON { (NOP $2)} -; - - -for_clause: - opt_expression SEMICOLON { FC_EXP $1 } -| declaration { FC_DECL $1 } -; - -declaration: /* ISO 6.7.*/ - decl_spec_list init_declarator_list SEMICOLON - { doDeclaration ((*handleLoc*)(snd $1)) (fst $1) $2 } -| decl_spec_list SEMICOLON - { doDeclaration ((*handleLoc*)(snd $1)) (fst $1) [] } -; -init_declarator_list: /* ISO 6.7 */ - init_declarator { [$1] } -| init_declarator COMMA init_declarator_list { $1 :: $3 } - -; -init_declarator: /* ISO 6.7 */ - declarator { ($1, NO_INIT) } -| declarator EQ init_expression - { ($1, $3) } -; - -decl_spec_list: /* ISO 6.7 */ - /* ISO 6.7.1 */ -| TYPEDEF decl_spec_list_opt { SpecTypedef :: $2, $1 } -| EXTERN decl_spec_list_opt { SpecStorage EXTERN :: $2, $1 } -| STATIC decl_spec_list_opt { SpecStorage STATIC :: $2, $1 } -| AUTO decl_spec_list_opt { SpecStorage AUTO :: $2, $1 } -| REGISTER decl_spec_list_opt { SpecStorage REGISTER :: $2, $1} - /* ISO 6.7.2 */ -| type_spec decl_spec_list_opt_no_named { SpecType (fst $1) :: $2, snd $1 } - /* ISO 6.7.4 */ -| INLINE decl_spec_list_opt { SpecInline :: $2, $1 } -| cvspec decl_spec_list_opt { (fst $1) :: $2, snd $1 } -| attribute_nocv decl_spec_list_opt { SpecAttr (fst $1) :: $2, snd $1 } -/* specifier pattern variable (must be last in spec list) */ -| AT_SPECIFIER LPAREN IDENT RPAREN { [ SpecPattern(fst $3) ], $1 } -; -/* (* In most cases if we see a NAMED_TYPE we must shift it. Thus we declare - * NAMED_TYPE to have right associativity *) */ -decl_spec_list_opt: - /* empty */ { [] } %prec NAMED_TYPE -| decl_spec_list { fst $1 } -; -/* (* We add this separate rule to handle the special case when an appearance - * of NAMED_TYPE should not be considered as part of the specifiers but as - * part of the declarator. IDENT has higher precedence than NAMED_TYPE *) - */ -decl_spec_list_opt_no_named: - /* empty */ { [] } %prec IDENT -| decl_spec_list { fst $1 } -; -type_spec: /* ISO 6.7.2 */ - VOID { Tvoid, $1} -| CHAR { Tchar, $1 } -| SHORT { Tshort, $1 } -| INT { Tint, $1 } -| LONG { Tlong, $1 } -| INT64 { Tint64, $1 } -| FLOAT { Tfloat, $1 } -| DOUBLE { Tdouble, $1 } -| SIGNED { Tsigned, $1 } -| UNSIGNED { Tunsigned, $1 } -| STRUCT id_or_typename - { Tstruct ($2, None, []), $1 } -| STRUCT just_attributes id_or_typename - { Tstruct ($3, None, $2), $1 } -| STRUCT id_or_typename LBRACE struct_decl_list RBRACE - { Tstruct ($2, Some $4, []), $1 } -| STRUCT LBRACE struct_decl_list RBRACE - { Tstruct ("", Some $3, []), $1 } -| STRUCT just_attributes id_or_typename LBRACE struct_decl_list RBRACE - { Tstruct ($3, Some $5, $2), $1 } -| STRUCT just_attributes LBRACE struct_decl_list RBRACE - { Tstruct ("", Some $4, $2), $1 } -| UNION id_or_typename - { Tunion ($2, None, []), $1 } -| UNION id_or_typename LBRACE struct_decl_list RBRACE - { Tunion ($2, Some $4, []), $1 } -| UNION LBRACE struct_decl_list RBRACE - { Tunion ("", Some $3, []), $1 } -| UNION just_attributes id_or_typename LBRACE struct_decl_list RBRACE - { Tunion ($3, Some $5, $2), $1 } -| UNION just_attributes LBRACE struct_decl_list RBRACE - { Tunion ("", Some $4, $2), $1 } -| ENUM id_or_typename - { Tenum ($2, None, []), $1 } -| ENUM id_or_typename LBRACE enum_list maybecomma RBRACE - { Tenum ($2, Some $4, []), $1 } -| ENUM LBRACE enum_list maybecomma RBRACE - { Tenum ("", Some $3, []), $1 } -| ENUM just_attributes id_or_typename LBRACE enum_list maybecomma RBRACE - { Tenum ($3, Some $5, $2), $1 } -| ENUM just_attributes LBRACE enum_list maybecomma RBRACE - { Tenum ("", Some $4, $2), $1 } -| NAMED_TYPE { Tnamed (fst $1), snd $1 } -| TYPEOF LPAREN expression RPAREN { TtypeofE (fst $3), $1 } -| TYPEOF LPAREN type_name RPAREN { let s, d = $3 in - TtypeofT (s, d), $1 } -; -struct_decl_list: /* (* ISO 6.7.2. Except that we allow empty structs. We - * also allow missing field names. *) - */ - /* empty */ { [] } -| decl_spec_list SEMICOLON struct_decl_list - { (fst $1, - [(missingFieldDecl, None)]) :: $3 } -/*(* GCC allows extra semicolons *)*/ -| SEMICOLON struct_decl_list - { $2 } -| decl_spec_list field_decl_list SEMICOLON struct_decl_list - { (fst $1, $2) - :: $4 } -/*(* MSVC allows pragmas in strange places *)*/ -| pragma struct_decl_list { $2 } - -| error SEMICOLON struct_decl_list - { $3 } -; -field_decl_list: /* (* ISO 6.7.2 *) */ - field_decl { [$1] } -| field_decl COMMA field_decl_list { $1 :: $3 } -; -field_decl: /* (* ISO 6.7.2. Except that we allow unnamed fields. *) */ -| declarator { ($1, None) } -| declarator COLON expression { ($1, Some (fst $3)) } -| COLON expression { (missingFieldDecl, Some (fst $2)) } -; - -enum_list: /* (* ISO 6.7.2.2 *) */ - enumerator {[$1]} -| enum_list COMMA enumerator {$1 @ [$3]} -| enum_list COMMA error { $1 } -; -enumerator: - IDENT {(fst $1, NOTHING, snd $1)} -| IDENT EQ expression {(fst $1, fst $3, snd $1)} -; - - -declarator: /* (* ISO 6.7.5. Plus Microsoft declarators.*) */ - pointer_opt direct_decl attributes_with_asm - { let (n, decl) = $2 in - (n, applyPointer (fst $1) decl, $3, (*(*handleLoc*)*)(snd $1)) } -; - - -direct_decl: /* (* ISO 6.7.5 *) */ - /* (* We want to be able to redefine named - * types as variable names *) */ -| id_or_typename { ($1, JUSTBASE) } - -| LPAREN attributes declarator RPAREN - { let (n,decl,al,loc) = $3 in - (n, PARENTYPE($2,decl,al)) } - -| direct_decl LBRACKET attributes comma_expression_opt RBRACKET - { let (n, decl) = $1 in - (n, ARRAY(decl, $3, $4)) } -| direct_decl LBRACKET attributes error RBRACKET - { let (n, decl) = $1 in - (n, ARRAY(decl, $3, NOTHING)) } -| direct_decl parameter_list_startscope rest_par_list RPAREN - { let (n, decl) = $1 in - let (params, isva) = $3 in - !Lexerhack.pop_context (); - (n, PROTO(decl, params, isva)) - } -; -parameter_list_startscope: - LPAREN { !Lexerhack.push_context () } -; -rest_par_list: -| /* empty */ { ([], false) } -| parameter_decl rest_par_list1 { let (params, isva) = $2 in - ($1 :: params, isva) - } -; -rest_par_list1: - /* empty */ { ([], false) } -| COMMA ELLIPSIS { ([], true) } -| COMMA parameter_decl rest_par_list1 { let (params, isva) = $3 in - ($2 :: params, isva) - } -; - - -parameter_decl: /* (* ISO 6.7.5 *) */ - decl_spec_list declarator { (fst $1, $2) } -| decl_spec_list abstract_decl { let d, a = $2 in - (fst $1, ("", d, a, cabslu)) } -| decl_spec_list { (fst $1, ("", JUSTBASE, [], cabslu)) } -| LPAREN parameter_decl RPAREN { $2 } -; - -/* (* Old style prototypes. Like a declarator *) */ -old_proto_decl: - pointer_opt direct_old_proto_decl { let (n, decl, a) = $2 in - (n, applyPointer (fst $1) decl, - a, snd $1) - } - -; - -direct_old_proto_decl: - direct_decl LPAREN old_parameter_list_ne RPAREN old_pardef_list - { let par_decl, isva = doOldParDecl $3 $5 in - let n, decl = $1 in - (n, PROTO(decl, par_decl, isva), []) - } -| direct_decl LPAREN RPAREN - { let n, decl = $1 in - (n, PROTO(decl, [], false), []) - } - -/* (* appears sometimesm but generates a shift-reduce conflict. *) -| LPAREN STAR direct_decl LPAREN old_parameter_list_ne RPAREN RPAREN LPAREN RPAREN old_pardef_list - { let par_decl, isva - = doOldParDecl $5 $10 in - let n, decl = $3 in - (n, PROTO(decl, par_decl, isva), []) - } -*/ -; - -old_parameter_list_ne: -| IDENT { [fst $1] } -| IDENT COMMA old_parameter_list_ne { let rest = $3 in - (fst $1 :: rest) } -; - -old_pardef_list: - /* empty */ { ([], false) } -| decl_spec_list old_pardef SEMICOLON ELLIPSIS - { ([(fst $1, $2)], true) } -| decl_spec_list old_pardef SEMICOLON old_pardef_list - { let rest, isva = $4 in - ((fst $1, $2) :: rest, isva) - } -; - -old_pardef: - declarator { [$1] } -| declarator COMMA old_pardef { $1 :: $3 } -| error { [] } -; - - -pointer: /* (* ISO 6.7.5 *) */ - STAR attributes pointer_opt { $2 :: fst $3, $1 } -; -pointer_opt: - /**/ { let l = currentLoc () in - ([], l) } -| pointer { $1 } -; - -type_name: /* (* ISO 6.7.6 *) */ - decl_spec_list abstract_decl { let d, a = $2 in - if a <> [] then begin - parse_error "attributes in type name"; - raise Parsing.Parse_error - end; - (fst $1, d) - } -| decl_spec_list { (fst $1, JUSTBASE) } -; -abstract_decl: /* (* ISO 6.7.6. *) */ - pointer_opt abs_direct_decl attributes { applyPointer (fst $1) $2, $3 } -| pointer { applyPointer (fst $1) JUSTBASE, [] } -; - -abs_direct_decl: /* (* ISO 6.7.6. We do not support optional declarator for - * functions. Plus Microsoft attributes. See the - * discussion for declarator. *) */ -| LPAREN attributes abstract_decl RPAREN - { let d, a = $3 in - PARENTYPE ($2, d, a) - } - -| LPAREN error RPAREN - { JUSTBASE } - -| abs_direct_decl_opt LBRACKET comma_expression_opt RBRACKET - { ARRAY($1, [], $3) } -/*(* The next should be abs_direct_decl_opt but we get conflicts *)*/ -| abs_direct_decl parameter_list_startscope rest_par_list RPAREN - { let (params, isva) = $3 in - !Lexerhack.pop_context (); - PROTO ($1, params, isva) - } -; -abs_direct_decl_opt: - abs_direct_decl { $1 } -| /* empty */ { JUSTBASE } -; -function_def: /* (* ISO 6.9.1 *) */ - function_def_start block - { let (loc, specs, decl) = $1 in - currentFunctionName := "<__FUNCTION__ used outside any functions>"; - !Lexerhack.pop_context (); (* The context pushed by - * announceFunctionName *) - doFunctionDef ((*handleLoc*) loc) (trd3 $2) specs decl (fst3 $2) - } - - -function_def_start: /* (* ISO 6.9.1 *) */ - decl_spec_list declarator - { announceFunctionName $2; - (snd $1, fst $1, $2) - } - -/* (* Old-style function prototype *) */ -| decl_spec_list old_proto_decl - { announceFunctionName $2; - (snd $1, fst $1, $2) - } -/* (* New-style function that does not have a return type *) */ -| IDENT parameter_list_startscope rest_par_list RPAREN - { let (params, isva) = $3 in - let fdec = - (fst $1, PROTO(JUSTBASE, params, isva), [], snd $1) in - announceFunctionName fdec; - (* Default is int type *) - let defSpec = [SpecType Tint] in - (snd $1, defSpec, fdec) - } - -/* (* No return type and old-style parameter list *) */ -| IDENT LPAREN old_parameter_list_ne RPAREN old_pardef_list - { (* Convert pardecl to new style *) - let pardecl, isva = doOldParDecl $3 $5 in - (* Make the function declarator *) - let fdec = (fst $1, - PROTO(JUSTBASE, pardecl,isva), - [], snd $1) in - announceFunctionName fdec; - (* Default is int type *) - let defSpec = [SpecType Tint] in - (snd $1, defSpec, fdec) - } -/* (* No return type and no parameters *) */ -| IDENT LPAREN RPAREN - { (* Make the function declarator *) - let fdec = (fst $1, - PROTO(JUSTBASE, [], false), - [], snd $1) in - announceFunctionName fdec; - (* Default is int type *) - let defSpec = [SpecType Tint] in - (snd $1, defSpec, fdec) - } -; - -/* const/volatile as type specifier elements */ -cvspec: - CONST { SpecCV(CV_CONST), $1 } -| VOLATILE { SpecCV(CV_VOLATILE), $1 } -| RESTRICT { SpecCV(CV_RESTRICT), $1 } -; - -/*** GCC attributes ***/ -attributes: - /* empty */ { []} -| attribute attributes { fst $1 :: $2 } -; - -/* (* In some contexts we can have an inline assembly to specify the name to - * be used for a global. We treat this as a name attribute *) */ -attributes_with_asm: - /* empty */ { [] } -| attribute attributes_with_asm { fst $1 :: $2 } -| ASM LPAREN string_constant RPAREN attributes - { ("__asm__", - [CONSTANT(CONST_STRING (fst $3))]) :: $5 } -; - -/* things like __attribute__, but no const/volatile */ -attribute_nocv: - ATTRIBUTE LPAREN paren_attr_list_ne RPAREN - { ("__attribute__", $3), $1 } -/*(* -| ATTRIBUTE_USED { ("__attribute__", - [ VARIABLE "used" ]), $1 } -*)*/ -| DECLSPEC paren_attr_list_ne { ("__declspec", $2), $1 } -| MSATTR { (fst $1, []), snd $1 } - /* ISO 6.7.3 */ -| THREAD { ("__thread",[]), $1 } -; - -/* __attribute__ plus const/volatile */ -attribute: - attribute_nocv { $1 } -| CONST { ("const", []), $1 } -| RESTRICT { ("restrict",[]), $1 } -| VOLATILE { ("volatile",[]), $1 } -; - -/* (* sm: I need something that just includes __attribute__ and nothing more, - * to support them appearing between the 'struct' keyword and the type name. - * Actually, a declspec can appear there as well (on MSVC) *) */ -just_attribute: - ATTRIBUTE LPAREN paren_attr_list_ne RPAREN - { ("__attribute__", $3) } -| DECLSPEC paren_attr_list_ne { ("__declspec", $2) } -; - -/* this can't be empty, b/c I folded that possibility into the calling - * productions to avoid some S/R conflicts */ -just_attributes: - just_attribute { [$1] } -| just_attribute just_attributes { $1 :: $2 } -; - -/** (* PRAGMAS and ATTRIBUTES *) ***/ -pragma: -| PRAGMA attr PRAGMA_EOL { PRAGMA ($2, $1) } -| PRAGMA attr SEMICOLON PRAGMA_EOL { PRAGMA ($2, $1) } -| PRAGMA_LINE { PRAGMA (VARIABLE (fst $1), - snd $1) } -; - -/* (* We want to allow certain strange things that occur in pragmas, so we - * cannot use directly the language of expressions *) */ -primary_attr: - IDENT { VARIABLE (fst $1) } - /*(* The NAMED_TYPE here creates conflicts with IDENT *)*/ -| NAMED_TYPE { VARIABLE (fst $1) } -| LPAREN attr RPAREN { $2 } -| IDENT IDENT { CALL(VARIABLE (fst $1), [VARIABLE (fst $2)]) } -| CST_INT { CONSTANT(CONST_INT (fst $1)) } -| string_constant { CONSTANT(CONST_STRING (fst $1)) } - /*(* Const when it appears in - * attribute lists, is translated - * to aconst *)*/ -| CONST { VARIABLE "aconst" } -| IDENT COLON CST_INT { VARIABLE (fst $1 ^ ":" ^ fst $3) } - -| CST_INT COLON CST_INT { VARIABLE (fst $1 ^ ":" ^ fst $3) } -| DEFAULT COLON CST_INT { VARIABLE ("default:" ^ fst $3) } - - /*(** GCC allows this as an - * attribute for functions, - * synonim for noreturn **)*/ -| VOLATILE { VARIABLE ("__noreturn__") } -; - -postfix_attr: - primary_attr { $1 } - /* (* use a VARIABLE "" so that the - * parentheses are printed *) */ -| IDENT LPAREN RPAREN { CALL(VARIABLE (fst $1), [VARIABLE ""]) } -| IDENT paren_attr_list_ne { CALL(VARIABLE (fst $1), $2) } - -| postfix_attr ARROW id_or_typename {MEMBEROFPTR ($1, $3)} -| postfix_attr DOT id_or_typename {MEMBEROF ($1, $3)} -; - -/*(* Since in attributes we use both IDENT and NAMED_TYPE as indentifiers, - * that leads to conflicts for SIZEOF and ALIGNOF. In those cases we require - * that their arguments be expressions, not attributes *)*/ -unary_attr: - postfix_attr { $1 } -| SIZEOF unary_expression {EXPR_SIZEOF (fst $2) } -| SIZEOF LPAREN type_name RPAREN - {let b, d = $3 in TYPE_SIZEOF (b, d)} - -| ALIGNOF unary_expression {EXPR_ALIGNOF (fst $2) } -| ALIGNOF LPAREN type_name RPAREN {let b, d = $3 in TYPE_ALIGNOF (b, d)} -| PLUS cast_attr {UNARY (PLUS, $2)} -| MINUS cast_attr {UNARY (MINUS, $2)} -| STAR cast_attr {UNARY (MEMOF, $2)} -| AND cast_attr - {UNARY (ADDROF, $2)} -| EXCLAM cast_attr {UNARY (NOT, $2)} -| TILDE cast_attr {UNARY (BNOT, $2)} -; - -cast_attr: - unary_attr { $1 } -; - -multiplicative_attr: - cast_attr { $1 } -| multiplicative_attr STAR cast_attr {BINARY(MUL ,$1 , $3)} -| multiplicative_attr SLASH cast_attr {BINARY(DIV ,$1 , $3)} -| multiplicative_attr PERCENT cast_attr {BINARY(MOD ,$1 , $3)} -; - - -additive_attr: - multiplicative_attr { $1 } -| additive_attr PLUS multiplicative_attr {BINARY(ADD ,$1 , $3)} -| additive_attr MINUS multiplicative_attr {BINARY(SUB ,$1 , $3)} -; - -shift_attr: - additive_attr { $1 } -| shift_attr INF_INF additive_attr {BINARY(SHL ,$1 , $3)} -| shift_attr SUP_SUP additive_attr {BINARY(SHR ,$1 , $3)} -; - -relational_attr: - shift_attr { $1 } -| relational_attr INF shift_attr {BINARY(LT ,$1 , $3)} -| relational_attr SUP shift_attr {BINARY(GT ,$1 , $3)} -| relational_attr INF_EQ shift_attr {BINARY(LE ,$1 , $3)} -| relational_attr SUP_EQ shift_attr {BINARY(GE ,$1 , $3)} -; - -equality_attr: - relational_attr { $1 } -| equality_attr EQ_EQ relational_attr {BINARY(EQ ,$1 , $3)} -| equality_attr EXCLAM_EQ relational_attr {BINARY(NE ,$1 , $3)} -; - - -bitwise_and_attr: - equality_attr { $1 } -| bitwise_and_attr AND equality_attr {BINARY(BAND ,$1 , $3)} -; - -bitwise_xor_attr: - bitwise_and_attr { $1 } -| bitwise_xor_attr CIRC bitwise_and_attr {BINARY(XOR ,$1 , $3)} -; - -bitwise_or_attr: - bitwise_xor_attr { $1 } -| bitwise_or_attr PIPE bitwise_xor_attr {BINARY(BOR ,$1 , $3)} -; - -logical_and_attr: - bitwise_or_attr { $1 } -| logical_and_attr AND_AND bitwise_or_attr {BINARY(AND ,$1 , $3)} -; - -logical_or_attr: - logical_and_attr { $1 } -| logical_or_attr PIPE_PIPE logical_and_attr {BINARY(OR ,$1 , $3)} -; - - -attr: logical_or_attr { $1 } -; - -attr_list_ne: -| attr { [$1] } -| attr COMMA attr_list_ne { $1 :: $3 } -| error COMMA attr_list_ne { $3 } -; -paren_attr_list_ne: - LPAREN attr_list_ne RPAREN { $2 } -| LPAREN error RPAREN { [] } -; -/*** GCC ASM instructions ***/ -asmattr: - /* empty */ { [] } -| VOLATILE asmattr { ("volatile", []) :: $2 } -| CONST asmattr { ("const", []) :: $2 } -; -asmtemplate: - one_string_constant { [$1] } -| one_string_constant asmtemplate { $1 :: $2 } -; -asmoutputs: - /* empty */ { None } -| COLON asmoperands asminputs - { let (ins, clobs) = $3 in - Some {aoutputs = $2; ainputs = ins; aclobbers = clobs} } -; -asmoperands: - /* empty */ { [] } -| asmoperandsne { List.rev $1 } -; -asmoperandsne: - asmoperand { [$1] } -| asmoperandsne COMMA asmoperand { $3 :: $1 } -; -asmoperand: - string_constant LPAREN expression RPAREN { (fst $1, fst $3) } -| string_constant LPAREN error RPAREN { (fst $1, NOTHING ) } -; -asminputs: - /* empty */ { ([], []) } -| COLON asmoperands asmclobber - { ($2, $3) } -; -asmclobber: - /* empty */ { [] } -| COLON asmcloberlst_ne { $2 } -; -asmcloberlst_ne: - one_string_constant { [$1] } -| one_string_constant COMMA asmcloberlst_ne { $1 :: $3 } -; - -%% - - - diff --git a/cil/src/frontc/cprint.ml b/cil/src/frontc/cprint.ml deleted file mode 100644 index 570945c0..00000000 --- a/cil/src/frontc/cprint.ml +++ /dev/null @@ -1,1014 +0,0 @@ -(* - * - * Copyright (c) 2001-2003, - * George C. Necula - * Scott McPeak - * Wes Weimer - * Ben Liblit - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) -(* cprint -- pretty printer of C program from abstract syntax -** -** Project: FrontC -** File: cprint.ml -** Version: 2.1e -** Date: 9.1.99 -** Author: Hugues Cassé -** -** 1.0 2.22.99 Hugues Cassé First version. -** 2.0 3.18.99 Hugues Cassé Compatible with Frontc 2.1, use of CAML -** pretty printer. -** 2.1 3.22.99 Hugues Cassé More efficient custom pretty printer used. -** 2.1a 4.12.99 Hugues Cassé Correctly handle: -** char *m, *m, *p; m + (n - p) -** 2.1b 4.15.99 Hugues Cassé x + (y + z) stays x + (y + z) for -** keeping computation order. -** 2.1c 7.23.99 Hugues Cassé Improvement of case and default display. -** 2.1d 8.25.99 Hugues Cassé Rebuild escape sequences in string and -** characters. -** 2.1e 9.1.99 Hugues Cassé Fix, recognize and correctly display '\0'. -*) - -(* George Necula: I changed this pretty dramatically since CABS changed *) -open Cabs -open Escape -let version = "Cprint 2.1e 9.1.99 Hugues Cassé" - -type loc = { line : int; file : string } - -let lu = {line = -1; file = "loc unknown";} -let cabslu = {lineno = -10; - filename = "cabs loc unknown"; - byteno = -10;} - -let curLoc = ref cabslu - -let msvcMode = ref false - -let printLn = ref true -let printLnComment = ref false - -let printCounters = ref false -let printComments = ref false - -(* -** FrontC Pretty printer -*) -let out = ref stdout -let width = ref 80 -let tab = ref 2 -let max_indent = ref 60 - -let line = ref "" -let line_len = ref 0 -let current = ref "" -let current_len = ref 0 -let spaces = ref 0 -let follow = ref 0 -let roll = ref 0 - -let print_tab size = - for i = 1 to size / 8 do - output_char !out '\t' - done; - for i = 1 to size mod 8 do - output_char !out ' ' - done - -let flush _ = - if !line <> "" then begin - print_tab (!spaces + !follow); - output_string !out !line; - line := ""; - line_len := 0 - end - -let commit _ = - if !current <> "" then begin - if !line = "" then begin - line := !current; - line_len := !current_len - end else begin - line := (!line ^ " " ^ !current); - line_len := !line_len + 1 + !current_len - end; - current := ""; - current_len := 0 - end - - -let addline () = - curLoc := {lineno = !curLoc.lineno+1; - filename = !curLoc.filename; - byteno = -1;} (*sfg: can we do better than this?*) - - -let new_line _ = - commit (); - if !line <> "" then begin - flush (); - addline(); - output_char !out '\n' - end; - follow := 0 - -let force_new_line _ = - commit (); - flush (); - addline(); - output_char !out '\n'; - follow := 0 - -let indent _ = - new_line (); - spaces := !spaces + !tab; - if !spaces >= !max_indent then begin - spaces := !tab; - roll := !roll + 1 - end - -let indentline _ = - new_line (); - if !spaces >= !max_indent then begin - spaces := !tab; - roll := !roll + 1 - end - -let unindent _ = - new_line (); - spaces := !spaces - !tab; - if (!spaces <= 0) && (!roll > 0) then begin - spaces := ((!max_indent - 1) / !tab) * !tab; - roll := !roll - 1 - end - -let space _ = commit () - -let print str = - current := !current ^ str; - current_len := !current_len + (String.length str); - if (!spaces + !follow + !line_len + 1 + !current_len) > !width - then begin - if !line_len = 0 then commit (); - flush (); - addline(); - output_char !out '\n'; - if !follow = 0 then follow := !tab - end - -(* sm: for some reason I couldn't just call print from frontc.... ? *) -let print_unescaped_string str = print str - -let setLoc (l : cabsloc) = - if !printLn then - if (l.lineno <> !curLoc.lineno) || l.filename <> !curLoc.filename then - begin - let oldspaces = !spaces in - (* sm: below, we had '//#' instead of '#', which means printLnComment was disregarded *) - if !printLnComment then print "//" else print "#"; - if !msvcMode then print "line"; - print " "; - print (string_of_int l.lineno); - if (l.filename <> !curLoc.filename) then begin - print (" \"" ^ l.filename ^ "\"") - end; - spaces := oldspaces; - new_line(); - curLoc := l - end - - - -(* -** Useful primitives -*) -let print_list print_sep print_elt lst = - let _ = List.fold_left - (fun com elt -> - if com then print_sep (); - print_elt elt; - true) - false - lst in - () - -let print_commas nl fct lst = - print_list (fun () -> print ","; if nl then new_line() else space()) fct lst - -let print_string (s:string) = - print ("\"" ^ escape_string s ^ "\"") - -let print_wstring (s: int64 list ) = - print ("L\"" ^ escape_wstring s ^ "\"") - -(* -** Base Type Printing -*) - -let rec print_specifiers (specs: spec_elem list) = - comprint "specifier("; - let print_spec_elem = function - SpecTypedef -> print "typedef " - | SpecInline -> print "__inline " - | SpecStorage sto -> - print (match sto with - NO_STORAGE -> (comstring "/*no storage*/") - | AUTO -> "auto " - | STATIC -> "static " - | EXTERN -> "extern " - | REGISTER -> "register ") - | SpecCV cv -> - print (match cv with - | CV_CONST -> "const " - | CV_VOLATILE -> "volatile " - | CV_RESTRICT -> "restrict ") - | SpecAttr al -> print_attribute al; space () - | SpecType bt -> print_type_spec bt - | SpecPattern name -> print ("@specifier(" ^ name ^ ") ") - in - List.iter print_spec_elem specs - ;comprint ")" - - -and print_type_spec = function - Tvoid -> print "void " - | Tchar -> print "char " - | Tshort -> print "short " - | Tint -> print "int " - | Tlong -> print "long " - | Tint64 -> print "__int64 " - | Tfloat -> print "float " - | Tdouble -> print "double " - | Tsigned -> print "signed " - | Tunsigned -> print "unsigned " - | Tnamed s -> comprint "tnamed"; print s; space (); - | Tstruct (n, None, _) -> print ("struct " ^ n ^ " ") - | Tstruct (n, Some flds, extraAttrs) -> - (print_struct_name_attr "struct" n extraAttrs); - (print_fields flds) - | Tunion (n, None, _) -> print ("union " ^ n ^ " ") - | Tunion (n, Some flds, extraAttrs) -> - (print_struct_name_attr "union" n extraAttrs); - (print_fields flds) - | Tenum (n, None, _) -> print ("enum " ^ n ^ " ") - | Tenum (n, Some enum_items, extraAttrs) -> - (print_struct_name_attr "enum" n extraAttrs); - (print_enum_items enum_items) - | TtypeofE e -> print "__typeof__("; print_expression e; print ") " - | TtypeofT (s,d) -> print "__typeof__("; print_onlytype (s, d); print ") " - - -(* print "struct foo", but with specified keyword and a list of - * attributes to put between keyword and name *) -and print_struct_name_attr (keyword: string) (name: string) (extraAttrs: attribute list) = -begin - if extraAttrs = [] then - print (keyword ^ " " ^ name) - else begin - (print (keyword ^ " ")); - (print_attributes extraAttrs); (* prints a final space *) - (print name); - end -end - - -(* This is the main printer for declarations. It is easy bacause the - * declarations are laid out as they need to be printed. *) -and print_decl (n: string) = function - JUSTBASE -> if n <> "___missing_field_name" then - print n - else - comprint "missing field name" - | PARENTYPE (al1, d, al2) -> - print "("; - print_attributes al1; space (); - print_decl n d; space (); - print_attributes al2; print ")" - | PTR (al, d) -> - print "* "; - print_attributes al; space (); - print_decl n d - | ARRAY (d, al, e) -> - print_decl n d; - print "["; - print_attributes al; - if e <> NOTHING then print_expression e; - print "]" - | PROTO(d, args, isva) -> - comprint "proto("; - print_decl n d; - print "("; - print_params args isva; - print ")"; - comprint ")" - - -and print_fields (flds : field_group list) = - if flds = [] then print " { } " - else begin - print " {"; - indent (); - List.iter - (fun fld -> print_field_group fld; print ";"; new_line ()) - flds; - unindent (); - print "} " - end - -and print_enum_items items = - if items = [] then print " { } " - else begin - print " {"; - indent (); - print_commas - true - (fun (id, exp, loc) -> print id; - if exp = NOTHING then () - else begin - space (); - print "= "; - print_expression exp - end) - items; - unindent (); - print "} "; - end - - -and print_onlytype (specs, dt) = - print_specifiers specs; - print_decl "" dt - -and print_name ((n, decl, attrs, _) : name) = - print_decl n decl; - space (); - print_attributes attrs - -and print_init_name ((n, i) : init_name) = - print_name n; - if i <> NO_INIT then begin - space (); - print "= "; - print_init_expression i - end - -and print_name_group (specs, names) = - print_specifiers specs; - print_commas false print_name names - -and print_field_group (specs, fields) = - print_specifiers specs; - print_commas false print_field fields - - -and print_field (name, widtho) = - print_name name; - (match widtho with - None -> () - | Some w -> print " : "; print_expression w) - -and print_init_name_group (specs, names) = - print_specifiers specs; - print_commas false print_init_name names - -and print_single_name (specs, name) = - print_specifiers specs; - print_name name - -and print_params (pars : single_name list) (ell : bool) = - print_commas false print_single_name pars; - if ell then print (if pars = [] then "..." else ", ...") else () - -and print_old_params pars ell = - print_commas false (fun id -> print id) pars; - if ell then print (if pars = [] then "..." else ", ...") else () - - -(* -** Expression printing -** Priorities -** 16 variables -** 15 . -> [] call() -** 14 ++, -- (post) -** 13 ++ -- (pre) ~ ! - + & *(cast) -** 12 * / % -** 11 + - -** 10 << >> -** 9 < <= > >= -** 8 == != -** 7 & -** 6 ^ -** 5 | -** 4 && -** 3 || -** 2 ? : -** 1 = ?= -** 0 , -*) -and get_operator exp = - match exp with - NOTHING -> ("", 16) - | UNARY (op, _) -> - (match op with - MINUS -> ("-", 13) - | PLUS -> ("+", 13) - | NOT -> ("!", 13) - | BNOT -> ("~", 13) - | MEMOF -> ("*", 13) - | ADDROF -> ("&", 13) - | PREINCR -> ("++", 13) - | PREDECR -> ("--", 13) - | POSINCR -> ("++", 14) - | POSDECR -> ("--", 14)) - | LABELADDR s -> ("", 16) (* Like a constant *) - | BINARY (op, _, _) -> - (match op with - MUL -> ("*", 12) - | DIV -> ("/", 12) - | MOD -> ("%", 12) - | ADD -> ("+", 11) - | SUB -> ("-", 11) - | SHL -> ("<<", 10) - | SHR -> (">>", 10) - | LT -> ("<", 9) - | LE -> ("<=", 9) - | GT -> (">", 9) - | GE -> (">=", 9) - | EQ -> ("==", 8) - | NE -> ("!=", 8) - | BAND -> ("&", 7) - | XOR -> ("^", 6) - | BOR -> ("|", 5) - | AND -> ("&&", 4) - | OR -> ("||", 3) - | ASSIGN -> ("=", 1) - | ADD_ASSIGN -> ("+=", 1) - | SUB_ASSIGN -> ("-=", 1) - | MUL_ASSIGN -> ("*=", 1) - | DIV_ASSIGN -> ("/=", 1) - | MOD_ASSIGN -> ("%=", 1) - | BAND_ASSIGN -> ("&=", 1) - | BOR_ASSIGN -> ("|=", 1) - | XOR_ASSIGN -> ("^=", 1) - | SHL_ASSIGN -> ("<<=", 1) - | SHR_ASSIGN -> (">>=", 1)) - | QUESTION _ -> ("", 2) - | CAST _ -> ("", 13) - | CALL _ -> ("", 15) - | COMMA _ -> ("", 0) - | CONSTANT _ -> ("", 16) - | VARIABLE name -> ("", 16) - | EXPR_SIZEOF exp -> ("", 16) - | TYPE_SIZEOF _ -> ("", 16) - | EXPR_ALIGNOF exp -> ("", 16) - | TYPE_ALIGNOF _ -> ("", 16) - | INDEX (exp, idx) -> ("", 15) - | MEMBEROF (exp, fld) -> ("", 15) - | MEMBEROFPTR (exp, fld) -> ("", 15) - | GNU_BODY _ -> ("", 17) - | EXPR_PATTERN _ -> ("", 16) (* sm: not sure about this *) - -and print_comma_exps exps = - print_commas false print_expression exps - -and print_init_expression (iexp: init_expression) : unit = - match iexp with - NO_INIT -> () - | SINGLE_INIT e -> print_expression e - | COMPOUND_INIT initexps -> - let doinitexp = function - NEXT_INIT, e -> print_init_expression e - | i, e -> - let rec doinit = function - NEXT_INIT -> () - | INFIELD_INIT (fn, i) -> print ("." ^ fn); doinit i - | ATINDEX_INIT (e, i) -> - print "["; - print_expression e; - print "]"; - doinit i - | ATINDEXRANGE_INIT (s, e) -> - print "["; - print_expression s; - print " ... "; - print_expression e; - print "]" - in - doinit i; print " = "; - print_init_expression e - in - print "{"; - print_commas false doinitexp initexps; - print "}" - -and print_expression (exp: expression) = print_expression_level 1 exp - -and print_expression_level (lvl: int) (exp : expression) = - let (txt, lvl') = get_operator exp in - let _ = if lvl > lvl' then print "(" else () in - let _ = match exp with - NOTHING -> () - | UNARY (op, exp') -> - (match op with - POSINCR | POSDECR -> - print_expression_level lvl' exp'; - print txt - | _ -> - print txt; space (); (* Print the space to avoid --5 *) - print_expression_level lvl' exp') - | LABELADDR l -> print ("&& " ^ l) - | BINARY (op, exp1, exp2) -> - (*if (op = SUB) && (lvl <= lvl') then print "(";*) - print_expression_level lvl' exp1; - space (); - print txt; - space (); - (*print_expression exp2 (if op = SUB then (lvl' + 1) else lvl');*) - print_expression_level (lvl' + 1) exp2 - (*if (op = SUB) && (lvl <= lvl') then print ")"*) - | QUESTION (exp1, exp2, exp3) -> - print_expression_level 2 exp1; - space (); - print "? "; - print_expression_level 2 exp2; - space (); - print ": "; - print_expression_level 2 exp3; - | CAST (typ, iexp) -> - print "("; - print_onlytype typ; - print ")"; - (* Always print parentheses. In a small number of cases when we print - * constants we don't need them *) - (match iexp with - SINGLE_INIT e -> print_expression_level 15 e - | COMPOUND_INIT _ -> (* print "("; *) - print_init_expression iexp - (* ; print ")" *) - | NO_INIT -> print "") - - | CALL (VARIABLE "__builtin_va_arg", [arg; TYPE_SIZEOF (bt, dt)]) -> - comprint "variable"; - print "__builtin_va_arg"; - print "("; - print_expression_level 1 arg; - print ","; - print_onlytype (bt, dt); - print ")" - | CALL (exp, args) -> - print_expression_level 16 exp; - print "("; - print_comma_exps args; - print ")" - | COMMA exps -> - print_comma_exps exps - | CONSTANT cst -> - (match cst with - CONST_INT i -> print i - | CONST_FLOAT r -> print r - | CONST_CHAR c -> print ("'" ^ escape_wstring c ^ "'") - | CONST_WCHAR c -> print ("L'" ^ escape_wstring c ^ "'") - | CONST_STRING s -> print_string s - | CONST_WSTRING ws -> print_wstring ws) - | VARIABLE name -> - comprint "variable"; - print name - | EXPR_SIZEOF exp -> - print "sizeof("; - print_expression_level 0 exp; - print ")" - | TYPE_SIZEOF (bt,dt) -> - print "sizeof("; - print_onlytype (bt, dt); - print ")" - | EXPR_ALIGNOF exp -> - print "__alignof__("; - print_expression_level 0 exp; - print ")" - | TYPE_ALIGNOF (bt,dt) -> - print "__alignof__("; - print_onlytype (bt, dt); - print ")" - | INDEX (exp, idx) -> - print_expression_level 16 exp; - print "["; - print_expression_level 0 idx; - print "]" - | MEMBEROF (exp, fld) -> - print_expression_level 16 exp; - print ("." ^ fld) - | MEMBEROFPTR (exp, fld) -> - print_expression_level 16 exp; - print ("->" ^ fld) - | GNU_BODY (blk) -> - print "("; - print_block blk; - print ")" - | EXPR_PATTERN (name) -> - print ("@expr(" ^ name ^ ") ") - in - if lvl > lvl' then print ")" else () - - -(* -** Statement printing -*) -and print_statement stat = - match stat with - NOP (loc) -> - setLoc(loc); - print ";"; - new_line () - | COMPUTATION (exp, loc) -> - setLoc(loc); - print_expression exp; - print ";"; - new_line () - | BLOCK (blk, loc) -> print_block blk - - | SEQUENCE (s1, s2, loc) -> - setLoc(loc); - print_statement s1; - print_statement s2; - | IF (exp, s1, s2, loc) -> - setLoc(loc); - print "if("; - print_expression_level 0 exp; - print ")"; - print_substatement s1; - (match s2 with - | NOP(_) -> () - | _ -> begin - print "else"; - print_substatement s2; - end) - | WHILE (exp, stat, loc) -> - setLoc(loc); - print "while("; - print_expression_level 0 exp; - print ")"; - print_substatement stat - | DOWHILE (exp, stat, loc) -> - setLoc(loc); - print "do"; - print_substatement stat; - print "while("; - print_expression_level 0 exp; - print ");"; - new_line (); - | FOR (fc1, exp2, exp3, stat, loc) -> - setLoc(loc); - print "for("; - (match fc1 with - FC_EXP exp1 -> print_expression_level 0 exp1; print ";" - | FC_DECL dec1 -> print_def dec1); - space (); - print_expression_level 0 exp2; - print ";"; - space (); - print_expression_level 0 exp3; - print ")"; - print_substatement stat - | BREAK (loc)-> - setLoc(loc); - print "break;"; new_line () - | CONTINUE (loc) -> - setLoc(loc); - print "continue;"; new_line () - | RETURN (exp, loc) -> - setLoc(loc); - print "return"; - if exp = NOTHING - then () - else begin - print " "; - print_expression_level 1 exp - end; - print ";"; - new_line () - | SWITCH (exp, stat, loc) -> - setLoc(loc); - print "switch("; - print_expression_level 0 exp; - print ")"; - print_substatement stat - | CASE (exp, stat, loc) -> - setLoc(loc); - unindent (); - print "case "; - print_expression_level 1 exp; - print ":"; - indent (); - print_substatement stat - | CASERANGE (expl, exph, stat, loc) -> - setLoc(loc); - unindent (); - print "case "; - print_expression expl; - print " ... "; - print_expression exph; - print ":"; - indent (); - print_substatement stat - | DEFAULT (stat, loc) -> - setLoc(loc); - unindent (); - print "default :"; - indent (); - print_substatement stat - | LABEL (name, stat, loc) -> - setLoc(loc); - print (name ^ ":"); - space (); - print_substatement stat - | GOTO (name, loc) -> - setLoc(loc); - print ("goto " ^ name ^ ";"); - new_line () - | COMPGOTO (exp, loc) -> - setLoc(loc); - print ("goto *"); print_expression exp; print ";"; new_line () - | DEFINITION d -> - print_def d - | ASM (attrs, tlist, details, loc) -> - setLoc(loc); - let print_asm_operand (cnstr, e) = - print_string cnstr; space (); print_expression_level 100 e - in - if !msvcMode then begin - print "__asm {"; - print_list (fun () -> new_line()) print tlist; (* templates *) - print "};" - end else begin - print "__asm__ "; - print_attributes attrs; - print "("; - print_list (fun () -> new_line()) print_string tlist; (* templates *) - begin - match details with - | None -> () - | Some { aoutputs = outs; ainputs = ins; aclobbers = clobs } -> - print ":"; space (); - print_commas false print_asm_operand outs; - if ins <> [] || clobs <> [] then begin - print ":"; space (); - print_commas false print_asm_operand ins; - if clobs <> [] then begin - print ":"; space (); - print_commas false print_string clobs - end; - end - end; - print ");" - end; - new_line () - | TRY_FINALLY (b, h, loc) -> - setLoc loc; - print "__try "; - print_block b; - print "__finally "; - print_block h - - | TRY_EXCEPT (b, e, h, loc) -> - setLoc loc; - print "__try "; - print_block b; - print "__except("; print_expression e; print ")"; - print_block h - -and print_block blk = - new_line(); - print "{"; - indent (); - if blk.blabels <> [] then begin - print "__label__ "; - print_commas false print blk.blabels; - print ";"; - new_line (); - end; - if blk.battrs <> [] then begin - List.iter print_attribute blk.battrs; - new_line (); - end; - List.iter print_statement blk.bstmts; - unindent (); - print "}"; - new_line () - -and print_substatement stat = - match stat with - IF _ - | SEQUENCE _ - | DOWHILE _ -> - new_line (); - print "{"; - indent (); - print_statement stat; - unindent (); - print "}"; - new_line (); - | BLOCK _ -> - print_statement stat - | _ -> - indent (); - print_statement stat; - unindent () - - -(* -** GCC Attributes -*) -and print_attribute (name,args) = - if args = [] then print ( - match name with - "restrict" -> "__restrict" - (* weimer: Fri Dec 7 17:12:35 2001 - * must not print 'restrict' and the code below does allows some - * plain 'restrict's to slip though! *) - | x -> x) - else begin - print name; - print "("; if name = "__attribute__" then print "("; - (match args with - [VARIABLE "aconst"] -> print "const" - | [VARIABLE "restrict"] -> print "__restrict" - | _ -> print_commas false (fun e -> print_expression e) args); - print ")"; if name = "__attribute__" then print ")" - end - -(* Print attributes. *) -and print_attributes attrs = - List.iter (fun a -> print_attribute a; space ()) attrs - -(* -** Declaration printing -*) -and print_defs defs = - let prev = ref false in - List.iter - (fun def -> - (match def with - DECDEF _ -> prev := false - | _ -> - if not !prev then force_new_line (); - prev := true); - print_def def) - defs - -and print_def def = - match def with - FUNDEF (proto, body, loc, _) -> - comprint "fundef"; - if !printCounters then begin - try - let fname = - match proto with - (_, (n, _, _, _)) -> n - in - print_def (DECDEF (([SpecType Tint], - [(fname ^ "__counter", JUSTBASE, [], cabslu), - NO_INIT]), loc)); - with Not_found -> print "/* can't print the counter */" - end; - setLoc(loc); - print_single_name proto; - print_block body; - force_new_line (); - - | DECDEF (names, loc) -> - comprint "decdef"; - setLoc(loc); - print_init_name_group names; - print ";"; - new_line () - - | TYPEDEF (names, loc) -> - comprint "typedef"; - setLoc(loc); - print_name_group names; - print ";"; - new_line (); - force_new_line () - - | ONLYTYPEDEF (specs, loc) -> - comprint "onlytypedef"; - setLoc(loc); - print_specifiers specs; - print ";"; - new_line (); - force_new_line () - - | GLOBASM (asm, loc) -> - setLoc(loc); - print "__asm__ ("; print_string asm; print ");"; - new_line (); - force_new_line () - - | PRAGMA (a,loc) -> - setLoc(loc); - force_new_line (); - print "#pragma "; - let oldwidth = !width in - width := 1000000; (* Do not wrap pragmas *) - print_expression a; - width := oldwidth; - force_new_line () - - | LINKAGE (n, loc, dl) -> - setLoc (loc); - force_new_line (); - print "extern "; print_string n; print_string " {"; - List.iter print_def dl; - print_string "}"; - force_new_line () - - | TRANSFORMER(srcdef, destdeflist, loc) -> - setLoc(loc); - print "@transform {"; - force_new_line(); - print "{"; - force_new_line(); - indent (); - print_def srcdef; - unindent(); - print "}"; - force_new_line(); - print "to {"; - force_new_line(); - indent(); - List.iter print_def destdeflist; - unindent(); - print "}"; - force_new_line() - - | EXPRTRANSFORMER(srcexpr, destexpr, loc) -> - setLoc(loc); - print "@transformExpr { "; - print_expression srcexpr; - print " } to { "; - print_expression destexpr; - print " }"; - force_new_line() - - -(* sm: print a comment if the printComments flag is set *) -and comprint (str : string) : unit = -begin - if (!printComments) then ( - print "/*"; - print str; - print "*/ " - ) - else - () -end - -(* sm: yield either the given string, or "", depending on printComments *) -and comstring (str : string) : string = -begin - if (!printComments) then - str - else - "" -end - - -(* print abstrac_syntax -> () -** Pretty printing the given abstract syntax program. -*) -let printFile (result : out_channel) ((fname, defs) : file) = - out := result; - print_defs defs; - flush () (* sm: should do this here *) - -let set_tab t = tab := t -let set_width w = width := w - diff --git a/cil/src/frontc/frontc.ml b/cil/src/frontc/frontc.ml deleted file mode 100644 index 459ae2c3..00000000 --- a/cil/src/frontc/frontc.ml +++ /dev/null @@ -1,256 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - - -module E = Errormsg -open Trace -open Pretty - -(* Output management *) -let out : out_channel option ref = ref None -let close_me = ref false - -let close_output _ = - match !out with - None -> () - | Some o -> begin - flush o; - if !close_me then close_out o else (); - close_me := false - end - -let set_output filename = - close_output (); - (try out := Some (open_out filename) - with (Sys_error msg) -> - output_string stderr ("Error while opening output: " ^ msg); exit 1); - close_me := true - - (* Signal that we are in MS VC mode *) -let setMSVCMode () = - Cprint.msvcMode := true - -(* filename for patching *) -let patchFileName : string ref = ref "" (* by default do no patching *) - -(* patching file contents *) -let patchFile : Cabs.file option ref = ref None - -(* whether to print the patched CABS files *) -let printPatchedFiles : bool ref = ref false - -(* whether to print a file of prototypes after parsing *) -let doPrintProtos : bool ref = ref false - -(* this seems like something that should be built-in.. *) -let isNone (o : 'a option) : bool = -begin - match o with - | Some _ -> false - | None -> true -end - -(* -** Argument definition -*) -let args : (string * Arg.spec * string) list = -[ - "--cabsonly", Arg.String set_output, ": CABS output file name"; - "--printComments", Arg.Unit (fun _ -> Cprint.printComments := true), - ": print cabs tree structure in comments in cabs output"; - "--patchFile", Arg.String (fun pf -> patchFileName := pf), - ": name the file containing patching transformations"; - "--printPatched", Arg.Unit (fun _ -> printPatchedFiles := true), - ": print patched CABS files after patching, to *.patched"; - "--printProtos", Arg.Unit (fun _ -> doPrintProtos := true), - ": print prototypes to safec.proto.h after parsing"; -] - -exception ParseError of string -exception CabsOnly - -(* parse, and apply patching *) -let rec parse_to_cabs fname = -begin - (* parse the patch file if it isn't parsed already *) - if ((!patchFileName <> "") && (isNone !patchFile)) then ( - (* parse the patch file *) - patchFile := Some(parse_to_cabs_inner !patchFileName); - if !E.hadErrors then - (failwith "There were parsing errors in the patch file") - ); - - (* now parse the file we came here to parse *) - let cabs = parse_to_cabs_inner fname in - if !E.hadErrors then - E.s (E.error "There were parsing errors in %s\n" fname); - - (* and apply the patch file, return transformed file *) - let patched = match !patchFile with - - | Some(pf) -> ( - (* save old value of out so I can use it for debugging during patching *) - let oldOut = !out in - - (* reset out so we don't try to print the patch file to it *) - out := None; - - (trace "patch" (dprintf "newpatching %s\n" fname)); - let result = (Stats.time "newpatch" (Patch.applyPatch pf) cabs) in - - if (!printPatchedFiles) then begin - let outFname:string = fname ^ ".patched" in - (trace "patch" (dprintf "printing patched version of %s to %s\n" - fname outFname)); - let o = (open_out outFname) in - (Cprint.printFile o result); - (close_out o) - end; - - (* restore out *) - Cprint.flush (); - out := oldOut; - - result - ) - | None -> cabs - in - - (* print it ... *) - (match !out with - Some o -> begin - (trace "sm" (dprintf "writing the cabs output\n")); - output_string o ("/* Generated by Frontc */\n"); - Stats.time "printCABS" (Cprint.printFile o) patched; - close_output (); - raise CabsOnly - end - | None -> ()); - if !E.hadErrors then - raise Parsing.Parse_error; - - (* and return the patched source *) - patched -end - - -(* just parse *) -and parse_to_cabs_inner (fname : string) = - try - if !E.verboseFlag then ignore (E.log "Frontc is parsing %s\n" fname); - flush !E.logChannel; - E.hadErrors := false; - let lexbuf = Clexer.init fname in - let cabs = Stats.time "parse" (Cparser.file Clexer.initial) lexbuf in - Clexer.finish (); - (fname, cabs) - with (Sys_error msg) -> begin - ignore (E.log "Cannot open %s : %s\n" fname msg); - Clexer.finish (); - close_output (); - raise (ParseError("Cannot open " ^ fname ^ ": " ^ msg ^ "\n")) - end - | Parsing.Parse_error -> begin - ignore (E.log "Parsing error\n"); - Clexer.finish (); - close_output (); - raise (ParseError("Parse error")) - end - | e -> begin - ignore (E.log "Caught %s while parsing\n" (Printexc.to_string e)); - Clexer.finish (); - raise e - end - - -(* print to safec.proto.h the prototypes of all functions that are defined *) -let printPrototypes ((fname, file) : Cabs.file) : unit = -begin - (*ignore (E.log "file has %d defns\n" (List.length file));*) - - let chan = open_out "safec.proto.h" in - ignore (fprintf chan "/* generated prototypes file, %d defs */\n" (List.length file)); - Cprint.out := chan; - - let counter : int ref = ref 0 in - - let rec loop (d : Cabs.definition) = begin - match d with - | Cabs.FUNDEF(name, _, loc, _) -> ( - match name with - | (_, (funcname, Cabs.PROTO(_,_,_), _, _)) -> ( - incr counter; - ignore (fprintf chan "\n/* %s from %s:%d */\n" - funcname loc.Cabs.filename loc.Cabs.lineno); - flush chan; - Cprint.print_single_name name; - Cprint.print_unescaped_string ";"; - Cprint.force_new_line (); - Cprint.flush () - ) - | _ -> () - ) - - | _ -> () - end in - (List.iter loop file); - - ignore (fprintf chan "\n/* wrote %d prototypes */\n" !counter); - close_out chan; - ignore (E.log "printed %d prototypes from %d defns to safec.proto.h\n" - !counter (List.length file)) -end - - - -let parse fname = - (trace "sm" (dprintf "parsing %s to Cabs\n" fname)); - let cabs = parse_to_cabs fname in - (* Now (return a function that will) convert to CIL *) - fun _ -> - (trace "sm" (dprintf "converting %s from Cabs to CIL\n" fname)); - let cil = Stats.time "conv" Cabs2cil.convFile cabs in - if !doPrintProtos then (printPrototypes cabs); - cil - - - - - - - - diff --git a/cil/src/frontc/frontc.mli b/cil/src/frontc/frontc.mli deleted file mode 100644 index 50ad799c..00000000 --- a/cil/src/frontc/frontc.mli +++ /dev/null @@ -1,55 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - - - (* Signal that we are in MS VC mode *) -val setMSVCMode: unit -> unit - - - (* Parse a file in *) -exception ParseError of string - - (* Raised when the front-end is requested to print the CABS and return *) -exception CabsOnly - - (* additional command line arguments *) -val args: (string * Arg.spec * string) list - - (* the main command to parse a file. Return a thunk that can be used to - * convert the AST to CIL. *) -val parse: string -> (unit -> Cil.file) - diff --git a/cil/src/frontc/lexerhack.ml b/cil/src/frontc/lexerhack.ml deleted file mode 100755 index ecae28ef..00000000 --- a/cil/src/frontc/lexerhack.ml +++ /dev/null @@ -1,22 +0,0 @@ - -module E = Errormsg - -(* We provide here a pointer to a function. It will be set by the lexer and - * used by the parser. In Ocaml lexers depend on parsers, so we we have put - * such functions in a separate module. *) -let add_identifier: (string -> unit) ref = - ref (fun _ -> E.s (E.bug "You called an uninitialized add_identifier")) - -let add_type: (string -> unit) ref = - ref (fun _ -> E.s (E.bug "You called an uninitialized add_type")) - -let push_context: (unit -> unit) ref = - ref (fun _ -> E.s (E.bug "You called an uninitialized push_context")) - -let pop_context: (unit -> unit) ref = - ref (fun _ -> E.s (E.bug "You called an uninitialized pop_context")) - - -(* Keep here the current pattern for formatparse *) -let currentPattern = ref "" - diff --git a/cil/src/frontc/patch.ml b/cil/src/frontc/patch.ml deleted file mode 100644 index fcb4ba62..00000000 --- a/cil/src/frontc/patch.ml +++ /dev/null @@ -1,837 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - - -(* patch.ml *) -(* CABS file patching *) - -open Cabs -open Trace -open Pretty -open Cabsvisit - -(* binding of a unification variable to a syntactic construct *) -type binding = - | BSpecifier of string * spec_elem list - | BName of string * string - | BExpr of string * expression - -(* thrown when unification fails *) -exception NoMatch - -(* thrown when an attempt to find the associated binding fails *) -exception BadBind of string - -(* trying to isolate performance problems; will hide all the *) -(* potentially expensive debugging output behind "if verbose .." *) -let verbose : bool = true - - -(* raise NoMatch if x and y are not equal *) -let mustEq (x : 'a) (y : 'a) : unit = -begin - if (x <> y) then ( - if verbose then - (trace "patchDebug" (dprintf "mismatch by structural disequality\n")); - raise NoMatch - ) -end - -(* why isn't this in the core Ocaml library? *) -let identity x = x - - -let isPatternVar (s : string) : bool = -begin - ((String.length s) >= 1) && ((String.get s 0) = '@') -end - -(* 's' is actually "@name(blah)"; extract the 'blah' *) -let extractPatternVar (s : string) : string = - (*(trace "patch" (dprintf "extractPatternVar %s\n" s));*) - (String.sub s 6 ((String.length s) - 7)) - - -(* a few debugging printers.. *) -let printExpr (e : expression) = -begin - if (verbose && traceActive "patchDebug") then ( - Cprint.print_expression e; Cprint.force_new_line (); - Cprint.flush () - ) -end - -let printSpec (spec: spec_elem list) = -begin - if (verbose && traceActive "patchDebug") then ( - Cprint.print_specifiers spec; Cprint.force_new_line (); - Cprint.flush () - ) -end - -let printSpecs (pat : spec_elem list) (tgt : spec_elem list) = -begin - (printSpec pat); - (printSpec tgt) -end - -let printDecl (pat : name) (tgt : name) = -begin - if (verbose && traceActive "patchDebug") then ( - Cprint.print_name pat; Cprint.force_new_line (); - Cprint.print_name tgt; Cprint.force_new_line (); - Cprint.flush () - ) -end - -let printDeclType (pat : decl_type) (tgt : decl_type) = -begin - if (verbose && traceActive "patchDebug") then ( - Cprint.print_decl "__missing_field_name" pat; Cprint.force_new_line (); - Cprint.print_decl "__missing_field_name" tgt; Cprint.force_new_line (); - Cprint.flush () - ) -end - -let printDefn (d : definition) = -begin - if (verbose && traceActive "patchDebug") then ( - Cprint.print_def d; - Cprint.flush () - ) -end - - -(* class to describe how to modify the tree for subtitution *) -class substitutor (bindings : binding list) = object(self) - inherit nopCabsVisitor as super - - (* look in the binding list for a given name *) - method findBinding (name : string) : binding = - begin - try - (List.find - (fun b -> - match b with - | BSpecifier(n, _) -> n=name - | BName(n, _) -> n=name - | BExpr(n, _) -> n=name) - bindings) - with - Not_found -> raise (BadBind ("name not found: " ^ name)) - end - - method vexpr (e:expression) : expression visitAction = - begin - match e with - | EXPR_PATTERN(name) -> ( - match (self#findBinding name) with - | BExpr(_, expr) -> ChangeTo(expr) (* substitute bound expression *) - | _ -> raise (BadBind ("wrong type: " ^ name)) - ) - | _ -> DoChildren - end - - (* use of a name *) - method vvar (s:string) : string = - begin - if (isPatternVar s) then ( - let nameString = (extractPatternVar s) in - match (self#findBinding nameString) with - | BName(_, str) -> str (* substitute *) - | _ -> raise (BadBind ("wrong type: " ^ nameString)) - ) - else - s - end - - (* binding introduction of a name *) - method vname (k: nameKind) (spec: specifier) (n: name) : name visitAction = - begin - match n with (s (*variable name*), dtype, attrs, loc) -> ( - let replacement = (self#vvar s) in (* use replacer from above *) - if (s <> replacement) then - ChangeTo(replacement, dtype, attrs, loc) - else - DoChildren (* no replacement *) - ) - end - - method vspec (specList: specifier) : specifier visitAction = - begin - if verbose then (trace "patchDebug" (dprintf "substitutor: vspec\n")); - (printSpec specList); - - (* are any of the specifiers SpecPatterns? we have to check the entire *) - (* list, not just the head, because e.g. "typedef @specifier(foo)" has *) - (* "typedef" as the head of the specifier list *) - if (List.exists (fun elt -> match elt with - | SpecPattern(_) -> true - | _ -> false) - specList) then begin - (* yes, replace the existing list with one got by *) - (* replacing all occurrences of SpecPatterns *) - (trace "patchDebug" (dprintf "at least one spec pattern\n")); - ChangeTo - (List.flatten - (List.map - (* for each specifier element, yield the specifier list *) - (* to which it maps; then we'll flatten the final result *) - (fun elt -> - match elt with - | SpecPattern(name) -> ( - match (self#findBinding name) with - | BSpecifier(_, replacement) -> ( - (trace "patchDebug" (dprintf "replacing pattern %s\n" name)); - replacement - ) - | _ -> raise (BadBind ("wrong type: " ^ name)) - ) - | _ -> [elt] (* leave this one alone *) - ) - specList - ) - ) - end - else - (* none of the specifiers in specList are patterns *) - DoChildren - end - - method vtypespec (tspec: typeSpecifier) : typeSpecifier visitAction = - begin - match tspec with - | Tnamed(str) when (isPatternVar str) -> - ChangeTo(Tnamed(self#vvar str)) - | Tstruct(str, fields, extraAttrs) when (isPatternVar str) -> ( - (trace "patchDebug" (dprintf "substituting %s\n" str)); - ChangeDoChildrenPost(Tstruct((self#vvar str), fields, extraAttrs), identity) - ) - | Tunion(str, fields, extraAttrs) when (isPatternVar str) -> - (trace "patchDebug" (dprintf "substituting %s\n" str)); - ChangeDoChildrenPost(Tunion((self#vvar str), fields, extraAttrs), identity) - | _ -> DoChildren - end - -end - - -(* why can't I have forward declarations in the language?!! *) -let unifyExprFwd : (expression -> expression -> binding list) ref - = ref (fun e e -> []) - - -(* substitution for expressions *) -let substExpr (bindings : binding list) (expr : expression) : expression = -begin - if verbose then - (trace "patchDebug" (dprintf "substExpr with %d bindings\n" (List.length bindings))); - (printExpr expr); - - (* apply the transformation *) - let result = (visitCabsExpression (new substitutor bindings :> cabsVisitor) expr) in - (printExpr result); - - result -end - -let d_loc (_:unit) (loc: cabsloc) : doc = - text loc.filename ++ chr ':' ++ num loc.lineno - - -(* class to describe how to modify the tree when looking for places *) -(* to apply expression transformers *) -class exprTransformer (srcpattern : expression) (destpattern : expression) - (patchline : int) (srcloc : cabsloc) = object(self) - inherit nopCabsVisitor as super - - method vexpr (e:expression) : expression visitAction = - begin - (* see if the source pattern matches this subexpression *) - try ( - let bindings = (!unifyExprFwd srcpattern e) in - - (* match! *) - (trace "patch" (dprintf "expr match: patch line %d, src %a\n" - patchline d_loc srcloc)); - ChangeTo(substExpr bindings destpattern) - ) - - with NoMatch -> ( - (* doesn't apply *) - DoChildren - ) - end - - (* other constructs left unchanged *) -end - - -let unifyList (pat : 'a list) (tgt : 'a list) - (unifyElement : 'a -> 'a -> binding list) : binding list = -begin - if verbose then - (trace "patchDebug" (dprintf "unifyList (pat len %d, tgt len %d)\n" - (List.length pat) (List.length tgt))); - - (* walk down the lists *) - let rec loop pat tgt : binding list = - match pat, tgt with - | [], [] -> [] - | (pelt :: prest), (telt :: trest) -> - (unifyElement pelt telt) @ - (loop prest trest) - | _,_ -> ( - (* no match *) - if verbose then ( - (trace "patchDebug" (dprintf "mismatching list length\n")); - ); - raise NoMatch - ) - in - (loop pat tgt) -end - - -let gettime () : float = - (Unix.times ()).Unix.tms_utime - -let rec applyPatch (patchFile : file) (srcFile : file) : file = -begin - let patch : definition list = (snd patchFile) in - let srcFname : string = (fst srcFile) in - let src : definition list = (snd srcFile) in - - (trace "patchTime" (dprintf "applyPatch start: %f\n" (gettime ()))); - if (traceActive "patchDebug") then - Cprint.out := stdout (* hack *) - else (); - - (* more hackery *) - unifyExprFwd := unifyExpr; - - (* patch a single source definition, yield transformed *) - let rec patchDefn (patch : definition list) (d : definition) : definition list = - begin - match patch with - | TRANSFORMER(srcpattern, destpattern, loc) :: rest -> ( - if verbose then - (trace "patchDebug" - (dprintf "considering applying defn pattern at line %d to src at %a\n" - loc.lineno d_loc (get_definitionloc d))); - - (* see if the source pattern matches the definition 'd' we have *) - try ( - let bindings = (unifyDefn srcpattern d) in - - (* we have a match! apply the substitutions *) - (trace "patch" (dprintf "defn match: patch line %d, src %a\n" - loc.lineno d_loc (get_definitionloc d))); - - (List.map (fun destElt -> (substDefn bindings destElt)) destpattern) - ) - - with NoMatch -> ( - (* no match, continue down list *) - (*(trace "patch" (dprintf "no match\n"));*) - (patchDefn rest d) - ) - ) - - | EXPRTRANSFORMER(srcpattern, destpattern, loc) :: rest -> ( - if verbose then - (trace "patchDebug" - (dprintf "considering applying expr pattern at line %d to src at %a\n" - loc.lineno d_loc (get_definitionloc d))); - - (* walk around in 'd' looking for expressions to modify *) - let dList = (visitCabsDefinition - ((new exprTransformer srcpattern destpattern - loc.lineno (get_definitionloc d)) - :> cabsVisitor) - d - ) in - - (* recursively invoke myself to try additional patches *) - (* since visitCabsDefinition might return a list, I'll try my *) - (* addtional patches on every yielded definition, then collapse *) - (* all of them into a single list *) - (List.flatten (List.map (fun d -> (patchDefn rest d)) dList)) - ) - - | _ :: rest -> ( - (* not a transformer; just keep going *) - (patchDefn rest d) - ) - | [] -> ( - (* reached the end of the patch file with no match *) - [d] (* have to wrap it in a list ... *) - ) - end in - - (* transform all the definitions *) - let result : definition list = - (List.flatten (List.map (fun d -> (patchDefn patch d)) src)) in - - (*Cprint.print_defs result;*) - - if (traceActive "patchDebug") then ( - (* avoid flush bug? yes *) - Cprint.force_new_line (); - Cprint.flush () - ); - - (trace "patchTime" (dprintf "applyPatch finish: %f\n" (gettime ()))); - (srcFname, result) -end - - -(* given a definition pattern 'pat', and a target concrete defintion 'tgt', *) -(* determine if they can be unified; if so, return the list of bindings of *) -(* unification variables in pat; otherwise raise NoMatch *) -and unifyDefn (pat : definition) (tgt : definition) : binding list = -begin - match pat, tgt with - | DECDEF((pspecifiers, pdeclarators), _), - DECDEF((tspecifiers, tdeclarators), _) -> ( - if verbose then - (trace "patchDebug" (dprintf "unifyDefn of DECDEFs\n")); - (unifySpecifiers pspecifiers tspecifiers) @ - (unifyInitDeclarators pdeclarators tdeclarators) - ) - - | TYPEDEF((pspec, pdecl), _), - TYPEDEF((tspec, tdecl), _) -> ( - if verbose then - (trace "patchDebug" (dprintf "unifyDefn of TYPEDEFs\n")); - (unifySpecifiers pspec tspec) @ - (unifyDeclarators pdecl tdecl) - ) - - | ONLYTYPEDEF(pspec, _), - ONLYTYPEDEF(tspec, _) -> ( - if verbose then - (trace "patchDebug" (dprintf "unifyDefn of ONLYTYPEDEFs\n")); - (unifySpecifiers pspec tspec) - ) - - | _, _ -> ( - if verbose then - (trace "patchDebug" (dprintf "mismatching definitions\n")); - raise NoMatch - ) -end - -and unifySpecifier (pat : spec_elem) (tgt : spec_elem) : binding list = -begin - if verbose then - (trace "patchDebug" (dprintf "unifySpecifier\n")); - (printSpecs [pat] [tgt]); - - if (pat = tgt) then [] else - - match pat, tgt with - | SpecType(tspec1), SpecType(tspec2) -> - (unifyTypeSpecifier tspec1 tspec2) - | SpecPattern(name), _ -> - (* record that future occurrances of @specifier(name) will yield this specifier *) - if verbose then - (trace "patchDebug" (dprintf "found specifier match for %s\n" name)); - [BSpecifier(name, [tgt])] - | _,_ -> ( - (* no match *) - if verbose then ( - (trace "patchDebug" (dprintf "mismatching specifiers\n")); - ); - raise NoMatch - ) -end - -and unifySpecifiers (pat : spec_elem list) (tgt : spec_elem list) : binding list = -begin - if verbose then - (trace "patchDebug" (dprintf "unifySpecifiers\n")); - (printSpecs pat tgt); - - (* canonicalize the specifiers by sorting them *) - let pat' = (List.stable_sort compare pat) in - let tgt' = (List.stable_sort compare tgt) in - - (* if they are equal, they match with no further checking *) - if (pat' = tgt') then [] else - - (* walk down the lists; don't walk the sorted lists because the *) - (* pattern must always be last, if it occurs *) - let rec loop pat tgt : binding list = - match pat, tgt with - | [], [] -> [] - | [SpecPattern(name)], _ -> - (* final SpecPattern matches anything which comes after *) - (* record that future occurrences of @specifier(name) will yield this specifier *) - if verbose then - (trace "patchDebug" (dprintf "found specifier match for %s\n" name)); - [BSpecifier(name, tgt)] - | (pspec :: prest), (tspec :: trest) -> - (unifySpecifier pspec tspec) @ - (loop prest trest) - | _,_ -> ( - (* no match *) - if verbose then ( - (trace "patchDebug" (dprintf "mismatching specifier list length\n")); - ); - raise NoMatch - ) - in - (loop pat tgt) -end - -and unifyTypeSpecifier (pat: typeSpecifier) (tgt: typeSpecifier) : binding list = -begin - if verbose then - (trace "patchDebug" (dprintf "unifyTypeSpecifier\n")); - - if (pat = tgt) then [] else - - match pat, tgt with - | Tnamed(s1), Tnamed(s2) -> (unifyString s1 s2) - | Tstruct(name1, None, _), Tstruct(name2, None, _) -> - (unifyString name1 name2) - | Tstruct(name1, Some(fields1), _), Tstruct(name2, Some(fields2), _) -> - (* ignoring extraAttrs b/c we're just trying to come up with a list - * of substitutions, and there's no unify_attributes function, and - * I don't care at this time about checking that they are equal .. *) - (unifyString name1 name2) @ - (unifyList fields1 fields2 unifyField) - | Tunion(name1, None, _), Tstruct(name2, None, _) -> - (unifyString name1 name2) - | Tunion(name1, Some(fields1), _), Tunion(name2, Some(fields2), _) -> - (unifyString name1 name2) @ - (unifyList fields1 fields2 unifyField) - | Tenum(name1, None, _), Tenum(name2, None, _) -> - (unifyString name1 name2) - | Tenum(name1, Some(items1), _), Tenum(name2, Some(items2), _) -> - (mustEq items1 items2); (* enum items *) - (unifyString name1 name2) - | TtypeofE(exp1), TtypeofE(exp2) -> - (unifyExpr exp1 exp2) - | TtypeofT(spec1, dtype1), TtypeofT(spec2, dtype2) -> - (unifySpecifiers spec1 spec2) @ - (unifyDeclType dtype1 dtype2) - | _ -> ( - if verbose then (trace "patchDebug" (dprintf "mismatching typeSpecifiers\n")); - raise NoMatch - ) -end - -and unifyField (pat : field_group) (tgt : field_group) : binding list = -begin - match pat,tgt with (spec1, list1), (spec2, list2) -> ( - (unifySpecifiers spec1 spec2) @ - (unifyList list1 list2 unifyNameExprOpt) - ) -end - -and unifyNameExprOpt (pat : name * expression option) - (tgt : name * expression option) : binding list = -begin - match pat,tgt with - | (name1, None), (name2, None) -> (unifyName name1 name2) - | (name1, Some(exp1)), (name2, Some(exp2)) -> - (unifyName name1 name2) @ - (unifyExpr exp1 exp2) - | _,_ -> [] -end - -and unifyName (pat : name) (tgt : name) : binding list = -begin - match pat,tgt with (pstr, pdtype, pattrs, ploc), (tstr, tdtype, tattrs, tloc) -> - (mustEq pattrs tattrs); - (unifyString pstr tstr) @ - (unifyDeclType pdtype tdtype) -end - -and unifyInitDeclarators (pat : init_name list) (tgt : init_name list) : binding list = -begin - (* - if verbose then - (trace "patchDebug" (dprintf "unifyInitDeclarators, pat %d, tgt %d\n" - (List.length pat) (List.length tgt))); - *) - - match pat, tgt with - | ((pdecl, piexpr) :: prest), - ((tdecl, tiexpr) :: trest) -> - (unifyDeclarator pdecl tdecl) @ - (unifyInitExpr piexpr tiexpr) @ - (unifyInitDeclarators prest trest) - | [], [] -> [] - | _, _ -> ( - if verbose then - (trace "patchDebug" (dprintf "mismatching init declarators\n")); - raise NoMatch - ) -end - -and unifyDeclarators (pat : name list) (tgt : name list) : binding list = - (unifyList pat tgt unifyDeclarator) - -and unifyDeclarator (pat : name) (tgt : name) : binding list = -begin - if verbose then - (trace "patchDebug" (dprintf "unifyDeclarator\n")); - (printDecl pat tgt); - - match pat, tgt with - | (pname, pdtype, pattr, ploc), - (tname, tdtype, tattr, tloc) -> - (mustEq pattr tattr); - (unifyDeclType pdtype tdtype) @ - (unifyString pname tname) -end - -and unifyDeclType (pat : decl_type) (tgt : decl_type) : binding list = -begin - if verbose then - (trace "patchDebug" (dprintf "unifyDeclType\n")); - (printDeclType pat tgt); - - match pat, tgt with - | JUSTBASE, JUSTBASE -> [] - | PARENTYPE(pattr1, ptype, pattr2), - PARENTYPE(tattr1, ttype, tattr2) -> - (mustEq pattr1 tattr1); - (mustEq pattr2 tattr2); - (unifyDeclType ptype ttype) - | ARRAY(ptype, pattr, psz), - ARRAY(ttype, tattr, tsz) -> - (mustEq pattr tattr); - (unifyDeclType ptype ttype) @ - (unifyExpr psz tsz) - | PTR(pattr, ptype), - PTR(tattr, ttype) -> - (mustEq pattr tattr); - (unifyDeclType ptype ttype) - | PROTO(ptype, pformals, pva), - PROTO(ttype, tformals, tva) -> - (mustEq pva tva); - (unifyDeclType ptype ttype) @ - (unifySingleNames pformals tformals) - | _ -> ( - if verbose then - (trace "patchDebug" (dprintf "mismatching decl_types\n")); - raise NoMatch - ) -end - -and unifySingleNames (pat : single_name list) (tgt : single_name list) : binding list = -begin - if verbose then - (trace "patchDebug" (dprintf "unifySingleNames, pat %d, tgt %d\n" - (List.length pat) (List.length tgt))); - - match pat, tgt with - | [], [] -> [] - | (pspec, pdecl) :: prest, - (tspec, tdecl) :: trest -> - (unifySpecifiers pspec tspec) @ - (unifyDeclarator pdecl tdecl) @ - (unifySingleNames prest trest) - | _, _ -> ( - if verbose then - (trace "patchDebug" (dprintf "mismatching single_name lists\n")); - raise NoMatch - ) -end - -and unifyString (pat : string) (tgt : string) : binding list = -begin - (* equal? match with no further ado *) - if (pat = tgt) then [] else - - (* is the pattern a variable? *) - if (isPatternVar pat) then - (* pat is actually "@name(blah)"; extract the 'blah' *) - let varname = (extractPatternVar pat) in - - (* when substituted, this name becomes 'tgt' *) - if verbose then - (trace "patchDebug" (dprintf "found name match for %s\n" varname)); - [BName(varname, tgt)] - - else ( - if verbose then - (trace "patchDebug" (dprintf "mismatching names: %s and %s\n" pat tgt)); - raise NoMatch - ) -end - -and unifyExpr (pat : expression) (tgt : expression) : binding list = -begin - (* if they're equal, that's good enough *) - if (pat = tgt) then [] else - - (* shorter name *) - let ue = unifyExpr in - - (* because of the equality check above, I can omit some cases *) - match pat, tgt with - | UNARY(pop, pexpr), - UNARY(top, texpr) -> - (mustEq pop top); - (ue pexpr texpr) - | BINARY(pop, pexp1, pexp2), - BINARY(top, texp1, texp2) -> - (mustEq pop top); - (ue pexp1 texp1) @ - (ue pexp2 texp2) - | QUESTION(p1, p2, p3), - QUESTION(t1, t2, t3) -> - (ue p1 t1) @ - (ue p2 t2) @ - (ue p3 t3) - | CAST((pspec, ptype), piexpr), - CAST((tspec, ttype), tiexpr) -> - (mustEq ptype ttype); - (unifySpecifiers pspec tspec) @ - (unifyInitExpr piexpr tiexpr) - | CALL(pfunc, pargs), - CALL(tfunc, targs) -> - (ue pfunc tfunc) @ - (unifyExprs pargs targs) - | COMMA(pexprs), - COMMA(texprs) -> - (unifyExprs pexprs texprs) - | EXPR_SIZEOF(pexpr), - EXPR_SIZEOF(texpr) -> - (ue pexpr texpr) - | TYPE_SIZEOF(pspec, ptype), - TYPE_SIZEOF(tspec, ttype) -> - (mustEq ptype ttype); - (unifySpecifiers pspec tspec) - | EXPR_ALIGNOF(pexpr), - EXPR_ALIGNOF(texpr) -> - (ue pexpr texpr) - | TYPE_ALIGNOF(pspec, ptype), - TYPE_ALIGNOF(tspec, ttype) -> - (mustEq ptype ttype); - (unifySpecifiers pspec tspec) - | INDEX(parr, pindex), - INDEX(tarr, tindex) -> - (ue parr tarr) @ - (ue pindex tindex) - | MEMBEROF(pexpr, pfield), - MEMBEROF(texpr, tfield) -> - (mustEq pfield tfield); - (ue pexpr texpr) - | MEMBEROFPTR(pexpr, pfield), - MEMBEROFPTR(texpr, tfield) -> - (mustEq pfield tfield); - (ue pexpr texpr) - | GNU_BODY(pblock), - GNU_BODY(tblock) -> - (mustEq pblock tblock); - [] - | EXPR_PATTERN(name), _ -> - (* match, and contribute binding *) - if verbose then - (trace "patchDebug" (dprintf "found expr match for %s\n" name)); - [BExpr(name, tgt)] - | a, b -> - if (verbose && traceActive "patchDebug") then ( - (trace "patchDebug" (dprintf "mismatching expression\n")); - (printExpr a); - (printExpr b) - ); - raise NoMatch -end - -and unifyInitExpr (pat : init_expression) (tgt : init_expression) : binding list = -begin - (* - Cprint.print_init_expression pat; Cprint.force_new_line (); - Cprint.print_init_expression tgt; Cprint.force_new_line (); - Cprint.flush (); - *) - - match pat, tgt with - | NO_INIT, NO_INIT -> [] - | SINGLE_INIT(pe), SINGLE_INIT(te) -> - (unifyExpr pe te) - | COMPOUND_INIT(plist), - COMPOUND_INIT(tlist) -> ( - let rec loop plist tlist = - match plist, tlist with - | ((pwhat, piexpr) :: prest), - ((twhat, tiexpr) :: trest) -> - (mustEq pwhat twhat); - (unifyInitExpr piexpr tiexpr) @ - (loop prest trest) - | [], [] -> [] - | _, _ -> ( - if verbose then - (trace "patchDebug" (dprintf "mismatching compound init exprs\n")); - raise NoMatch - ) - in - (loop plist tlist) - ) - | _,_ -> ( - if verbose then - (trace "patchDebug" (dprintf "mismatching init exprs\n")); - raise NoMatch - ) -end - -and unifyExprs (pat : expression list) (tgt : expression list) : binding list = - (unifyList pat tgt unifyExpr) - - -(* given the list of bindings 'b', substitute them into 'd' to yield a new definition *) -and substDefn (bindings : binding list) (defn : definition) : definition = -begin - if verbose then - (trace "patchDebug" (dprintf "substDefn with %d bindings\n" (List.length bindings))); - (printDefn defn); - - (* apply the transformation *) - match (visitCabsDefinition (new substitutor bindings :> cabsVisitor) defn) with - | [d] -> d (* expect a singleton list *) - | _ -> (failwith "didn't get a singleton list where I expected one") -end - - -(* end of file *) diff --git a/cil/src/frontc/patch.mli b/cil/src/frontc/patch.mli deleted file mode 100644 index 4f32870e..00000000 --- a/cil/src/frontc/patch.mli +++ /dev/null @@ -1,42 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - - -(* patch.mli *) -(* interface for patch.ml *) - -val applyPatch : Cabs.file -> Cabs.file -> Cabs.file -- cgit