aboutsummaryrefslogtreecommitdiffstats
path: root/cil/src/frontc
diff options
context:
space:
mode:
authorxleroy <xleroy@fca1b0fc-160b-0410-b1d3-a4f43f01ea2e>2010-03-03 10:25:25 +0000
committerxleroy <xleroy@fca1b0fc-160b-0410-b1d3-a4f43f01ea2e>2010-03-03 10:25:25 +0000
commit93d89c2b5e8497365be152fb53cb6cd4c5764d34 (patch)
tree0de8d05bbd0eeaeb5e4b85395f8dd576984b6a9e /cil/src/frontc
parent891377ce1962cdb31357d6580d6546ec22df2b4f (diff)
downloadcompcert-93d89c2b5e8497365be152fb53cb6cd4c5764d34.tar.gz
compcert-93d89c2b5e8497365be152fb53cb6cd4c5764d34.zip
Getting rid of CIL
git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@1270 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e
Diffstat (limited to 'cil/src/frontc')
-rw-r--r--cil/src/frontc/cabs.ml396
-rw-r--r--cil/src/frontc/cabs2cil.ml6238
-rw-r--r--cil/src/frontc/cabs2cil.mli49
-rw-r--r--cil/src/frontc/cabsvisit.ml577
-rw-r--r--cil/src/frontc/cabsvisit.mli115
-rw-r--r--cil/src/frontc/clexer.mli55
-rw-r--r--cil/src/frontc/clexer.mll666
-rw-r--r--cil/src/frontc/cparser.mly1521
-rw-r--r--cil/src/frontc/cprint.ml1014
-rw-r--r--cil/src/frontc/frontc.ml256
-rw-r--r--cil/src/frontc/frontc.mli55
-rwxr-xr-xcil/src/frontc/lexerhack.ml22
-rw-r--r--cil/src/frontc/patch.ml837
-rw-r--r--cil/src/frontc/patch.mli42
14 files changed, 0 insertions, 11843 deletions
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 <necula@cs.berkeley.edu>
- * Scott McPeak <smcpeak@cs.berkeley.edu>
- * Wes Weimer <weimer@cs.berkeley.edu>
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are
- * met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- *
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in the
- * documentation and/or other materials provided with the distribution.
- *
- * 3. The names of the contributors may not be used to endorse or promote
- * products derived from this software without specific prior written
- * permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
- * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
- * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
- * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
- * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
- * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
- * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
- * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
- * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
- * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
- * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- *
- *)
-
-(** 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 <necula@cs.berkeley.edu>
- * Scott McPeak <smcpeak@cs.berkeley.edu>
- * Wes Weimer <weimer@cs.berkeley.edu>
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are
- * met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- *
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in the
- * documentation and/or other materials provided with the distribution.
- *
- * 3. The names of the contributors may not be used to endorse or promote
- * products derived from this software without specific prior written
- * permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
- * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
- * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
- * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
- * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
- * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
- * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
- * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
- * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
- * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
- * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- *
- *)
-
-(* 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
- [] -> "<missing name>"
- | (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 <necula@cs.berkeley.edu>
- * Scott McPeak <smcpeak@cs.berkeley.edu>
- * Wes Weimer <weimer@cs.berkeley.edu>
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are
- * met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- *
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in the
- * documentation and/or other materials provided with the distribution.
- *
- * 3. The names of the contributors may not be used to endorse or promote
- * products derived from this software without specific prior written
- * permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
- * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
- * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
- * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
- * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
- * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
- * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
- * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
- * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
- * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
- * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- *
- *)
-
-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 <necula@cs.berkeley.edu>
- * Scott McPeak <smcpeak@cs.berkeley.edu>
- * Wes Weimer <weimer@cs.berkeley.edu>
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are
- * met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- *
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in the
- * documentation and/or other materials provided with the distribution.
- *
- * 3. The names of the contributors may not be used to endorse or promote
- * products derived from this software without specific prior written
- * permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
- * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
- * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
- * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
- * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
- * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
- * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
- * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
- * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
- * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
- * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- *
- *)
-
-(* 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 <necula@cs.berkeley.edu>
- * Scott McPeak <smcpeak@cs.berkeley.edu>
- * Wes Weimer <weimer@cs.berkeley.edu>
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are
- * met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- *
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in the
- * documentation and/or other materials provided with the distribution.
- *
- * 3. The names of the contributors may not be used to endorse or promote
- * products derived from this software without specific prior written
- * permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
- * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
- * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
- * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
- * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
- * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
- * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
- * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
- * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
- * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
- * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- *
- *)
-
-(* 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 <necula@cs.berkeley.edu>
- * Scott McPeak <smcpeak@cs.berkeley.edu>
- * Wes Weimer <weimer@cs.berkeley.edu>
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are
- * met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- *
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in the
- * documentation and/or other materials provided with the distribution.
- *
- * 3. The names of the contributors may not be used to endorse or promote
- * products derived from this software without specific prior written
- * permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
- * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
- * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
- * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
- * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
- * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
- * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
- * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
- * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
- * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
- * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- *
- *)
-
-
-(* 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 <necula@cs.berkeley.edu>
- * Scott McPeak <smcpeak@cs.berkeley.edu>
- * Wes Weimer <weimer@cs.berkeley.edu>
- * Ben Liblit <liblit@cs.berkeley.edu>
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are
- * met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- *
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in the
- * documentation and/or other materials provided with the distribution.
- *
- * 3. The names of the contributors may not be used to endorse or promote
- * products derived from this software without specific prior written
- * permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
- * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
- * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
- * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
- * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
- * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
- * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
- * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
- * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
- * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
- * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- *
- *)
-(* 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 }
-
-(* # <line number> <file name> ... *)
-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 <necula@cs.berkeley.edu>
- * Scott McPeak <smcpeak@cs.berkeley.edu>
- * Wes Weimer <weimer@cs.berkeley.edu>
- * Ben Liblit <liblit@cs.berkeley.edu>
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are
- * met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- *
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in the
- * documentation and/or other materials provided with the distribution.
- *
- * 3. The names of the contributors may not be used to endorse or promote
- * products derived from this software without specific prior written
- * permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
- * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
- * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
- * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
- * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
- * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
- * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
- * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
- * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
- * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
- * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- *
- **)
-(**
-** 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 "<outside any function>"
-
-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 <string * Cabs.cabsloc> IDENT
-%token <int64 list * Cabs.cabsloc> CST_CHAR
-%token <int64 list * Cabs.cabsloc> CST_WCHAR
-%token <string * Cabs.cabsloc> CST_INT
-%token <string * Cabs.cabsloc> CST_FLOAT
-%token <string * Cabs.cabsloc> NAMED_TYPE
-
-/* Each character is its own list element, and the terminating nul is not
- included in this list. */
-%token <int64 list * Cabs.cabsloc> CST_STRING
-%token <int64 list * Cabs.cabsloc> CST_WSTRING
-
-%token EOF
-%token<Cabs.cabsloc> CHAR INT DOUBLE FLOAT VOID INT64 INT32
-%token<Cabs.cabsloc> ENUM STRUCT TYPEDEF UNION
-%token<Cabs.cabsloc> SIGNED UNSIGNED LONG SHORT
-%token<Cabs.cabsloc> VOLATILE EXTERN STATIC CONST RESTRICT AUTO REGISTER
-%token<Cabs.cabsloc> THREAD
-
-%token<Cabs.cabsloc> 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<Cabs.cabsloc> PLUS MINUS STAR
-%token SLASH PERCENT
-%token<Cabs.cabsloc> TILDE AND
-%token PIPE CIRC
-%token<Cabs.cabsloc> EXCLAM AND_AND
-%token PIPE_PIPE
-%token INF_INF SUP_SUP
-%token<Cabs.cabsloc> PLUS_PLUS MINUS_MINUS
-
-%token RPAREN
-%token<Cabs.cabsloc> LPAREN RBRACE
-%token<Cabs.cabsloc> LBRACE
-%token LBRACKET RBRACKET
-%token COLON
-%token<Cabs.cabsloc> SEMICOLON
-%token COMMA ELLIPSIS QUEST
-
-%token<Cabs.cabsloc> BREAK CONTINUE GOTO RETURN
-%token<Cabs.cabsloc> SWITCH CASE DEFAULT
-%token<Cabs.cabsloc> WHILE DO FOR
-%token<Cabs.cabsloc> IF TRY EXCEPT FINALLY
-%token ELSE
-
-%token<Cabs.cabsloc> ATTRIBUTE INLINE ASM TYPEOF FUNCTION__ PRETTY_FUNCTION__
-%token LABEL__
-%token<Cabs.cabsloc> BUILTIN_VA_ARG ATTRIBUTE_USED
-%token BUILTIN_VA_LIST
-%token BLOCKATTRIBUTE
-%token<Cabs.cabsloc> BUILTIN_TYPES_COMPAT BUILTIN_OFFSETOF
-%token<Cabs.cabsloc> DECLSPEC
-%token<string * Cabs.cabsloc> MSASM MSATTR
-%token<string * Cabs.cabsloc> PRAGMA_LINE
-%token<Cabs.cabsloc> PRAGMA
-%token PRAGMA_EOL
-
-/* sm: cabs tree transformation specification keywords */
-%token<Cabs.cabsloc> 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 <Cabs.definition list> file interpret globals
-
-%type <Cabs.definition> global
-
-
-%type <Cabs.attribute list> attributes attributes_with_asm asmattr
-%type <Cabs.statement> statement
-%type <Cabs.constant * cabsloc> constant
-%type <string * cabsloc> string_constant
-%type <Cabs.expression * cabsloc> expression
-%type <Cabs.expression> opt_expression
-%type <Cabs.init_expression> init_expression
-%type <Cabs.expression list * cabsloc> comma_expression
-%type <Cabs.expression list * cabsloc> paren_comma_expression
-%type <Cabs.expression list> arguments
-%type <Cabs.expression list> bracket_comma_expression
-%type <int64 list Queue.t * cabsloc> string_list
-%type <int64 list * cabsloc> wstring_list
-
-%type <Cabs.initwhat * Cabs.init_expression> initializer
-%type <(Cabs.initwhat * Cabs.init_expression) list> initializer_list
-%type <Cabs.initwhat> init_designators init_designators_opt
-
-%type <spec_elem list * cabsloc> decl_spec_list
-%type <typeSpecifier * cabsloc> type_spec
-%type <Cabs.field_group list> struct_decl_list
-
-
-%type <Cabs.name> old_proto_decl
-%type <Cabs.single_name> parameter_decl
-%type <Cabs.enum_item> enumerator
-%type <Cabs.enum_item list> enum_list
-%type <Cabs.definition> declaration function_def
-%type <cabsloc * spec_elem list * name> function_def_start
-%type <Cabs.spec_elem list * Cabs.decl_type> type_name
-%type <Cabs.block * cabsloc * cabsloc> block
-%type <Cabs.statement list> block_element_list
-%type <string list> local_labels local_label_names
-%type <string list> old_parameter_list_ne
-
-%type <Cabs.init_name> init_declarator
-%type <Cabs.init_name list> init_declarator_list
-%type <Cabs.name> declarator
-%type <Cabs.name * expression option> field_decl
-%type <(Cabs.name * expression option) list> field_decl_list
-%type <string * Cabs.decl_type> direct_decl
-%type <Cabs.decl_type> abs_direct_decl abs_direct_decl_opt
-%type <Cabs.decl_type * Cabs.attribute list> abstract_decl
-
- /* (* Each element is a "* <type_quals_opt>". *) */
-%type <attribute list list * cabsloc> pointer pointer_opt
-%type <Cabs.cabsloc> location
-%type <Cabs.spec_elem * cabsloc> 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 <necula@cs.berkeley.edu>
- * Scott McPeak <smcpeak@cs.berkeley.edu>
- * Wes Weimer <weimer@cs.berkeley.edu>
- * Ben Liblit <liblit@cs.berkeley.edu>
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are
- * met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- *
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in the
- * documentation and/or other materials provided with the distribution.
- *
- * 3. The names of the contributors may not be used to endorse or promote
- * products derived from this software without specific prior written
- * permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
- * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
- * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
- * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
- * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
- * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
- * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
- * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
- * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
- * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
- * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- *
- *)
-(* 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 "<NO_INIT in cast. Should never arise>")
-
- | 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 <necula@cs.berkeley.edu>
- * Scott McPeak <smcpeak@cs.berkeley.edu>
- * Wes Weimer <weimer@cs.berkeley.edu>
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are
- * met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- *
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in the
- * documentation and/or other materials provided with the distribution.
- *
- * 3. The names of the contributors may not be used to endorse or promote
- * products derived from this software without specific prior written
- * permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
- * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
- * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
- * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
- * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
- * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
- * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
- * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
- * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
- * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
- * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- *
- *)
-
-
-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, "<fname>: 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),
- "<fname>: 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 <necula@cs.berkeley.edu>
- * Scott McPeak <smcpeak@cs.berkeley.edu>
- * Wes Weimer <weimer@cs.berkeley.edu>
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are
- * met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- *
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in the
- * documentation and/or other materials provided with the distribution.
- *
- * 3. The names of the contributors may not be used to endorse or promote
- * products derived from this software without specific prior written
- * permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
- * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
- * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
- * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
- * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
- * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
- * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
- * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
- * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
- * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
- * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- *
- *)
-
-
- (* 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 <necula@cs.berkeley.edu>
- * Scott McPeak <smcpeak@cs.berkeley.edu>
- * Wes Weimer <weimer@cs.berkeley.edu>
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are
- * met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- *
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in the
- * documentation and/or other materials provided with the distribution.
- *
- * 3. The names of the contributors may not be used to endorse or promote
- * products derived from this software without specific prior written
- * permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
- * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
- * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
- * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
- * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
- * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
- * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
- * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
- * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
- * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
- * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- *
- *)
-
-
-(* 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 <necula@cs.berkeley.edu>
- * Scott McPeak <smcpeak@cs.berkeley.edu>
- * Wes Weimer <weimer@cs.berkeley.edu>
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are
- * met:
- *
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- *
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in the
- * documentation and/or other materials provided with the distribution.
- *
- * 3. The names of the contributors may not be used to endorse or promote
- * products derived from this software without specific prior written
- * permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
- * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
- * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
- * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
- * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
- * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
- * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
- * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
- * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
- * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
- * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- *
- *)
-
-
-(* patch.mli *)
-(* interface for patch.ml *)
-
-val applyPatch : Cabs.file -> Cabs.file -> Cabs.file
generated by cgit (git 2.34.1) at 2024-07-07 04:22:58 +0000