3. Cil package
Start data section to licences/cil_licence.txt[1
/1
]
1: Copyright (c) 2001-2002,
2: George C. Necula <necula@cs.berkeley.edu>
3: Scott McPeak <smcpeak@cs.berkeley.edu>
4: Wes Weimer <weimer@cs.berkeley.edu>
5: Ben Liblit <liblit@cs.berkeley.edu>
6: All rights reserved.
7:
8: Redistribution and use in source and binary forms, with or without
9: modification, are permitted provided that the following conditions are met:
10:
11: 1. Redistributions of source code must retain the above copyright notice,
12: this list of conditions and the following disclaimer.
13:
14: 2. Redistributions in binary form must reproduce the above copyright notice,
15: this list of conditions and the following disclaimer in the documentation
16: and/or other materials provided with the distribution.
17:
18: 3. The names of the contributors may not be used to endorse or promote
19: products derived from this software without specific prior written
20: permission.
21:
22: THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
23: AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
24: IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
25: ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
26: LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
27: CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
28: SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
29: INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
30: CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
31: ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
32: POSSIBILITY OF SUCH DAMAGE.
33:
34: (See http://www.opensource.org/licenses/bsd-license.php)
35:
Start ocaml section to src/flx_cil_cilversion.mli[1
/1
]
1: # 40 "./lpsrc/flx_cil.ipk"
2: val cilVersionMajor:int
3: val cilVersionMinor:int
4: val cilVersionRev:int
5: val cilVersion:string
6:
7:
Start ocaml section to src/flx_cil_cilversion.ml[1
/1
]
1: # 48 "./lpsrc/flx_cil.ipk"
2: let cilVersionMajor = 1
3: let cilVersionMinor = 2
4: let cilVersionRev = 5
5: let cilVersion = "1.2.5"
6:
Start ocaml section to src/flx_cil_machdep_type.mli[1
/1
]
1: # 84 "./lpsrc/flx_cil.ipk"
2: type mach = {
3: version_major: int; (* Major version number *)
4: version_minor: int; (* Minor version number *)
5: version: string; (* version number *)
6: underscore_name: bool; (* If assembly names have leading underscore *)
7:
8: sizeof_bool : int;
9: # 90 "./lpsrc/flx_cil.ipk"
10: alignof_bool : int;
11: # 90 "./lpsrc/flx_cil.ipk"
12: sizeof_cbool : int;
13: # 90 "./lpsrc/flx_cil.ipk"
14: alignof_cbool : int;
15: # 90 "./lpsrc/flx_cil.ipk"
16: sizeof_int : int;
17: # 90 "./lpsrc/flx_cil.ipk"
18: alignof_int : int;
19: # 90 "./lpsrc/flx_cil.ipk"
20: sizeof_short : int;
21: # 90 "./lpsrc/flx_cil.ipk"
22: alignof_short : int;
23: # 90 "./lpsrc/flx_cil.ipk"
24: sizeof_long : int;
25: # 90 "./lpsrc/flx_cil.ipk"
26: alignof_long : int;
27: # 90 "./lpsrc/flx_cil.ipk"
28: sizeof_longlong : int;
29: # 90 "./lpsrc/flx_cil.ipk"
30: alignof_longlong : int;
31: # 90 "./lpsrc/flx_cil.ipk"
32: sizeof_enum : int;
33: # 90 "./lpsrc/flx_cil.ipk"
34: alignof_enum : int;
35: # 90 "./lpsrc/flx_cil.ipk"
36: sizeof_wchar : int;
37: # 90 "./lpsrc/flx_cil.ipk"
38: alignof_wchar : int;
39: # 90 "./lpsrc/flx_cil.ipk"
40: sizeof_size : int;
41: # 90 "./lpsrc/flx_cil.ipk"
42: alignof_size : int;
43: # 90 "./lpsrc/flx_cil.ipk"
44: sizeof_float : int;
45: # 90 "./lpsrc/flx_cil.ipk"
46: alignof_float : int;
47: # 90 "./lpsrc/flx_cil.ipk"
48: sizeof_double : int;
49: # 90 "./lpsrc/flx_cil.ipk"
50: alignof_double : int;
51: # 90 "./lpsrc/flx_cil.ipk"
52: sizeof_longdouble : int;
53: # 90 "./lpsrc/flx_cil.ipk"
54: alignof_longdouble : int;
55: # 90 "./lpsrc/flx_cil.ipk"
56: sizeof_complex : int;
57: # 90 "./lpsrc/flx_cil.ipk"
58: alignof_complex : int;
59: # 90 "./lpsrc/flx_cil.ipk"
60: sizeof_doublecomplex : int;
61: # 90 "./lpsrc/flx_cil.ipk"
62: alignof_doublecomplex : int;
63: # 90 "./lpsrc/flx_cil.ipk"
64: sizeof_longdoublecomplex : int;
65: # 90 "./lpsrc/flx_cil.ipk"
66: alignof_longdoublecomplex : int;
67: # 90 "./lpsrc/flx_cil.ipk"
68: sizeof_imaginary : int;
69: # 90 "./lpsrc/flx_cil.ipk"
70: alignof_imaginary : int;
71: # 90 "./lpsrc/flx_cil.ipk"
72: sizeof_doubleimaginary : int;
73: # 90 "./lpsrc/flx_cil.ipk"
74: alignof_doubleimaginary : int;
75: # 90 "./lpsrc/flx_cil.ipk"
76: sizeof_longdoubleimaginary : int;
77: # 90 "./lpsrc/flx_cil.ipk"
78: alignof_longdoubleimaginary : int;
79:
80: sizeof_ptr: int; (* Size of pointers *)
81: sizeof_void: int; (* Size of "void" *)
82: sizeof_fun: int; (* Size of function *)
83:
84: alignof_str: int; (* Alignment of strings *)
85: alignof_fun: int; (* Alignment of function *)
86: char_is_unsigned: bool; (* Whether "char" is unsigned *)
87: const_string_literals: bool; (* Whether string literals have const chars *)
88: little_endian: bool; (* whether the machine is little endian *)
89: }
90:
Start ocaml section to src/flx_cil_machdep.mli[1
/1
]
1: # 105 "./lpsrc/flx_cil.ipk"
2: open Flx_cil_machdep_type
3: val gcc:mach
4: val msvc:mach
5: val hasMSVC:bool
6: val gccHas__builtin_va_list:bool
7: val __thread_is_keyword:bool
8:
Start ocaml section to src/flx_cil_machdep.ml[1
/1
]
1: # 114 "./lpsrc/flx_cil.ipk"
2: open Flx_cil_machdep_type
3:
4: let gcc:mach = {
5: version_major = 3;
6: version_minor = 2;
7: version = "3.2.2 20030222 (Red Hat Linux 3.2.2-5)";
8: underscore_name = true;
9:
10: alignof_str = 1;
11: alignof_fun = 1;
12: sizeof_void = 1;
13: sizeof_fun = 1;
14: sizeof_ptr = 4;
15:
16: # 135 "./lpsrc/flx_cil.ipk"
17: sizeof_bool = 1;
18: # 135 "./lpsrc/flx_cil.ipk"
19: alignof_bool = 1;
20: # 135 "./lpsrc/flx_cil.ipk"
21: sizeof_cbool = 0;
22: # 135 "./lpsrc/flx_cil.ipk"
23: alignof_cbool = 0;
24: # 135 "./lpsrc/flx_cil.ipk"
25: sizeof_int = 4;
26: # 135 "./lpsrc/flx_cil.ipk"
27: alignof_int = 4;
28: # 135 "./lpsrc/flx_cil.ipk"
29: sizeof_short = 2;
30: # 135 "./lpsrc/flx_cil.ipk"
31: alignof_short = 2;
32: # 135 "./lpsrc/flx_cil.ipk"
33: sizeof_long = 4;
34: # 135 "./lpsrc/flx_cil.ipk"
35: alignof_long = 4;
36: # 135 "./lpsrc/flx_cil.ipk"
37: sizeof_longlong = 8;
38: # 135 "./lpsrc/flx_cil.ipk"
39: alignof_longlong = 8;
40: # 135 "./lpsrc/flx_cil.ipk"
41: sizeof_enum = 4;
42: # 135 "./lpsrc/flx_cil.ipk"
43: alignof_enum = 4;
44: # 135 "./lpsrc/flx_cil.ipk"
45: sizeof_wchar = 4;
46: # 135 "./lpsrc/flx_cil.ipk"
47: alignof_wchar = 4;
48: # 135 "./lpsrc/flx_cil.ipk"
49: sizeof_size = 4;
50: # 135 "./lpsrc/flx_cil.ipk"
51: alignof_size = 4;
52: # 135 "./lpsrc/flx_cil.ipk"
53: sizeof_float = 4;
54: # 135 "./lpsrc/flx_cil.ipk"
55: alignof_float = 4;
56: # 135 "./lpsrc/flx_cil.ipk"
57: sizeof_double = 8;
58: # 135 "./lpsrc/flx_cil.ipk"
59: alignof_double = 8;
60: # 135 "./lpsrc/flx_cil.ipk"
61: sizeof_longdouble = 16;
62: # 135 "./lpsrc/flx_cil.ipk"
63: alignof_longdouble = 8;
64: # 135 "./lpsrc/flx_cil.ipk"
65: sizeof_complex = 8;
66: # 135 "./lpsrc/flx_cil.ipk"
67: alignof_complex = 4;
68: # 135 "./lpsrc/flx_cil.ipk"
69: sizeof_doublecomplex = 16;
70: # 135 "./lpsrc/flx_cil.ipk"
71: alignof_doublecomplex = 8;
72: # 135 "./lpsrc/flx_cil.ipk"
73: sizeof_longdoublecomplex = 32;
74: # 135 "./lpsrc/flx_cil.ipk"
75: alignof_longdoublecomplex = 8;
76: # 135 "./lpsrc/flx_cil.ipk"
77: sizeof_imaginary = 0;
78: # 135 "./lpsrc/flx_cil.ipk"
79: alignof_imaginary = 0;
80: # 135 "./lpsrc/flx_cil.ipk"
81: sizeof_doubleimaginary = 0;
82: # 135 "./lpsrc/flx_cil.ipk"
83: alignof_doubleimaginary = 0;
84: # 135 "./lpsrc/flx_cil.ipk"
85: sizeof_longdoubleimaginary = 0;
86: # 135 "./lpsrc/flx_cil.ipk"
87: alignof_longdoubleimaginary = 0;
88:
89: # 141 "./lpsrc/flx_cil.ipk"
90: char_is_unsigned = false;
91: # 141 "./lpsrc/flx_cil.ipk"
92: const_string_literals = true;
93: # 146 "./lpsrc/flx_cil.ipk"
94: little_endian = false;
95: # 146 "./lpsrc/flx_cil.ipk"
96: }
97: # 152 "./lpsrc/flx_cil.ipk"
98: let hasMSVC = false
99: # 152 "./lpsrc/flx_cil.ipk"
100: let msvc = gcc (* hackery .. *)
101: let gccHas__builtin_va_list = true
102: let __thread_is_keyword = true
103:
104:
Start ocaml section to src/flx_cil_check.ml[1
/1
]
1: # 159 "./lpsrc/flx_cil.ipk"
2:
3: (* A consistency checker for CIL *)
4: open Flx_cil_cil
5: module E = Flx_cil_errormsg
6: module H = Hashtbl
7: open Flx_cil_pretty
8:
9:
10: (* A few parameters to customize the checking *)
11: type checkFlags =
12: NoFlx_cil_checkGlobalIds (* Do not check that the global ids have the proper
13: * hash value *)
14:
15: let checkGlobalIds = ref true
16:
17: (* Attributes must be sorted *)
18: type ctxAttr =
19: CALocal (* Attribute of a local variable *)
20: | CAGlobal (* Attribute of a global variable *)
21: | CAType (* Attribute of a type *)
22:
23: let valid = ref true
24:
25: let warn fmt =
26: valid := false;
27: Flx_cil_cil.warn fmt
28:
29: let warnContext fmt =
30: valid := false;
31: Flx_cil_cil.warnContext fmt
32:
33: let checkAttributes (attrs: attribute list) : unit =
34: let rec loop lastname = function
35: [] -> ()
36: | (Attr(an, _) as a) :: resta ->
37: if an < lastname then
38: ignore (warn "Attributes not sorted");
39: loop an resta
40: in
41: loop "" attrs
42:
43:
44: (* Keep track of defined types *)
45: let typeDefs : (string, typ) H.t = H.create 117
46:
47:
48: (* Keep track of all variables names, enum tags and type names *)
49: let varNamesEnv : (string, unit) H.t = H.create 117
50:
51: (* We also keep a map of variables indexed by id, to ensure that only one
52: * varinfo has a given id *)
53: let varIdsEnv: (int, varinfo) H.t = H.create 117
54:
55: (* And keep track of all varinfo's to check the uniqueness of the
56: * identifiers *)
57: let allVarIds: (int, varinfo) H.t = H.create 117
58:
59: (* Also keep a list of environments. We place an empty string in the list to
60: * mark the start of a local environment (i.e. a function) *)
61: let varNamesList : (string * int) list ref = ref []
62: let defineName s =
63: if s = "" then
64: E.s (bug "Empty name\n");
65: if H.mem varNamesEnv s then
66: ignore (warn "Multiple definitions for %s\n" s);
67: H.add varNamesEnv s ()
68:
69: let defineVariable vi =
70: defineName vi.vname;
71: varNamesList := (vi.vname, vi.vid) :: !varNamesList;
72: (* Flx_cil_check the id *)
73: if H.mem allVarIds vi.vid then
74: ignore (warn "Id %d is already defined (%s)\n" vi.vid vi.vname);
75: H.add allVarIds vi.vid vi;
76: (* And register it in the current scope also *)
77: H.add varIdsEnv vi.vid vi
78:
79: (* Flx_cil_check that a varinfo has already been registered *)
80: let checkVariable vi =
81: try
82: (* Flx_cil_check in the current scope only *)
83: if vi != H.find varIdsEnv vi.vid then
84: ignore (warnContext "varinfos for %s not shared\n" vi.vname);
85: with Not_found ->
86: ignore (warn "Unknown id (%d) for %s\n" vi.vid vi.vname)
87:
88:
89: let startEnv () =
90: varNamesList := ("", -1) :: !varNamesList
91:
92: let endEnv () =
93: let rec loop = function
94: [] -> E.s (bug "Cannot find start of env")
95: | ("", _) :: rest -> varNamesList := rest
96: | (s, id) :: rest -> begin
97: H.remove varNamesEnv s;
98: H.remove varIdsEnv id;
99: loop rest
100: end
101: in
102: loop !varNamesList
103:
104:
105:
106: (* The current function being checked *)
107: let currentReturnType : typ ref = ref voidType
108:
109: (* A map of labels in the current function *)
110: let labels: (string, unit) H.t = H.create 17
111:
112: (* A list of statements seen in the current function *)
113: let statements: stmt list ref = ref []
114:
115: (* A list of the targets of Gotos *)
116: let gotoTargets: (string * stmt) list ref = ref []
117:
118: (*** TYPES ***)
119: (* Cetain types can only occur in some contexts, so keep a list of context *)
120: type ctxType =
121: CTStruct (* In a composite type *)
122: | CTUnion
123: | CTFArg (* In a function argument type *)
124: | CTFRes (* In a function result type *)
125: | CTArray (* In an array type *)
126: | CTPtr (* In a pointer type *)
127: | CTExp (* In an expression, as the type of
128: * the result of binary operators, or
129: * in a cast *)
130: | CTSizeof (* In a sizeof *)
131: | CTDecl (* In a typedef, or a declaration *)
132:
133: let d_context () = function
134: CTStruct -> text "CTStruct"
135: | CTUnion -> text "CTUnion"
136: | CTFArg -> text "CTFArg"
137: | CTFRes -> text "CTFRes"
138: | CTArray -> text "CTArray"
139: | CTPtr -> text "CTPtr"
140: | CTExp -> text "CTExp"
141: | CTSizeof -> text "CTSizeof"
142: | CTDecl -> text "CTDecl"
143:
144:
145: (* Keep track of all tags that we use. For each tag remember also the info
146: * structure and a flag whether it was actually defined or just used. A
147: * forward declaration acts as a definition. *)
148: type defuse =
149: Defined (* We actually have seen a definition of this tag *)
150: | Forward (* We have seen a forward declaration for it. This is done using
151: * a GType with an empty type name *)
152: | Used (* Only uses *)
153: let compUsed : (int, compinfo * defuse ref) H.t = H.create 117
154: let enumUsed : (string, enuminfo * defuse ref) H.t = H.create 117
155: let typUsed : (string, typeinfo * defuse ref) H.t = H.create 117
156:
157: (* For composite types we also check that the names are unique *)
158: let compNames : (string, unit) H.t = H.create 17
159:
160:
161: (* Flx_cil_check a type *)
162: let rec checkType (t: typ) (ctx: ctxType) =
163: (* Flx_cil_check that it appears in the right context *)
164: let rec checkContext = function
165: TVoid _ -> ctx = CTPtr || ctx = CTFRes || ctx = CTDecl
166: | TNamed (ti, a) -> checkContext ti.ttype
167: | TArray _ ->
168: (ctx = CTStruct || ctx = CTUnion
169: || ctx = CTSizeof || ctx = CTDecl || ctx = CTArray || ctx = CTPtr)
170: | TComp _ -> ctx <> CTExp
171: | _ -> true
172: in
173: if not (checkContext t) then
174: ignore (warn "Type (%a) used in wrong context. Expected context: %a"
175: d_plaintype t d_context ctx);
176: match t with
177: (TVoid a | TBuiltin_va_list a) -> checkAttributes a
178: | TInt (ik, a) -> checkAttributes a
179: | TFloat (_, a) -> checkAttributes a
180: | TPtr (t, a) -> checkAttributes a; checkType t CTPtr
181:
182: | TNamed (ti, a) ->
183: checkAttributes a;
184: if ti.tname = "" then
185: ignore (warnContext "Using a typeinfo for an empty-named type\n");
186: checkTypeInfo Used ti
187:
188: | TComp (comp, a) ->
189: checkAttributes a;
190: (* Mark it as a forward. We'll check it later. If we try to check it
191: * now we might encounter undefined types *)
192: checkCompInfo Used comp
193:
194:
195: | TEnum (enum, a) -> begin
196: checkAttributes a;
197: checkEnumInfo Used enum
198: end
199:
200: | TArray(bt, len, a) ->
201: checkAttributes a;
202: checkType bt CTArray;
203: (match len with
204: None -> ()
205: | Some l -> begin
206: let t = checkExp true l in
207: match t with
208: TInt((IInt|IUInt), _) -> ()
209: | _ -> E.s (bug "Type of array length is not integer")
210: end)
211:
212: | TFun (rt, targs, isva, a) ->
213: checkAttributes a;
214: checkType rt CTFRes;
215: List.iter
216: (fun (an, at, aa) ->
217: checkType at CTFArg;
218: checkAttributes aa) (argsToList targs)
219:
220: (* Flx_cil_check that a type is a promoted integral type *)
221: and checkIntegralType (t: typ) =
222: checkType t CTExp;
223: match unrollType t with
224: TInt _ -> ()
225: | _ -> ignore (warn "Non-integral type")
226:
227: (* Flx_cil_check that a type is a promoted arithmetic type *)
228: and checkArithmeticType (t: typ) =
229: checkType t CTExp;
230: match unrollType t with
231: TInt _ | TFloat _ -> ()
232: | _ -> ignore (warn "Non-arithmetic type")
233:
234: (* Flx_cil_check that a type is a promoted boolean type *)
235: and checkBooleanType (t: typ) =
236: checkType t CTExp;
237: match unrollType t with
238: TInt _ | TFloat _ | TPtr _ -> ()
239: | _ -> ignore (warn "Non-boolean type")
240:
241:
242: (* Flx_cil_check that a type is a pointer type *)
243: and checkPointerType (t: typ) =
244: checkType t CTExp;
245: match unrollType t with
246: TPtr _ -> ()
247: | _ -> ignore (warn "Non-pointer type")
248:
249:
250: and typeMatch (t1: typ) (t2: typ) =
251: if typeSig t1 <> typeSig t2 then
252: match unrollType t1, unrollType t2 with
253: (* Allow free interchange of TInt and TEnum *)
254: TInt (IInt, _), TEnum _ -> ()
255: | TEnum _, TInt (IInt, _) -> ()
256:
257: | _, _ -> ignore (warn "Type mismatch:@! %a@!and %a@!"
258: d_type t1 d_type t2)
259:
260: and checkCompInfo (isadef: defuse) comp =
261: let fullname = compFullName comp in
262: try
263: let oldci, olddef = H.find compUsed comp.ckey in
264: (* Flx_cil_check that it is the same *)
265: if oldci != comp then
266: ignore (warnContext "compinfo for %s not shared\n" fullname);
267: (match !olddef, isadef with
268: | Defined, Defined ->
269: ignore (warnContext "Multiple definition of %s\n" fullname)
270: | _, Defined -> olddef := Defined
271: | Defined, _ -> ()
272: | _, Forward -> olddef := Forward
273: | _, _ -> ())
274: with Not_found -> begin (* This is the first time we see it *)
275: (* Flx_cil_check that the name is not empty *)
276: if comp.cname = "" then
277: E.s (bug "Compinfo with empty name");
278: (* Flx_cil_check that the name is unique *)
279: if H.mem compNames fullname then
280: ignore (warn "Duplicate name %s" fullname);
281: (* Add it to the map before we go on *)
282: H.add compUsed comp.ckey (comp, ref isadef);
283: H.add compNames fullname ();
284: (* Do not check the compinfo unless this is a definition. Otherwise you
285: * might run into undefined types. *)
286: if isadef = Defined then begin
287: checkAttributes comp.cattr;
288: let fctx = if comp.cstruct then CTStruct else CTUnion in
289: let rec checkField f =
290: if not
291: (f.fcomp == comp && (* Each field must share the self cell of
292: * the host *)
293: f.fname <> "") then
294: ignore (warn "Self pointer not set in field %s of %s"
295: f.fname fullname);
296: checkType f.ftype fctx;
297: (* Flx_cil_check the bitfields *)
298: (match unrollType f.ftype, f.fbitfield with
299: | TInt (ik, a), Some w ->
300: checkAttributes a;
301: if w < 0 || w >= bitsSizeOf (TInt(ik, a)) then
302: ignore (warn "Wrong width (%d) in bitfield" w)
303: | _, Some w ->
304: ignore (E.error "Bitfield on a non integer type\n")
305: | _ -> ());
306: checkAttributes f.fattr
307: in
308: List.iter checkField comp.cfields
309: end
310: end
311:
312:
313: and checkEnumInfo (isadef: defuse) enum =
314: if enum.ename = "" then
315: E.s (bug "Enuminfo with empty name");
316: try
317: let oldei, olddef = H.find enumUsed enum.ename in
318: (* Flx_cil_check that it is the same *)
319: if oldei != enum then
320: ignore (warnContext "enuminfo for %s not shared\n" enum.ename);
321: (match !olddef, isadef with
322: Defined, Defined ->
323: ignore (warnContext "Multiple definition of enum %s\n" enum.ename)
324: | _, Defined -> olddef := Defined
325: | Defined, _ -> ()
326: | _, Forward -> olddef := Forward
327: | _, _ -> ())
328: with Not_found -> begin (* This is the first time we see it *)
329: (* Add it to the map before we go on *)
330: H.add enumUsed enum.ename (enum, ref isadef);
331: checkAttributes enum.eattr;
332: List.iter (fun (tn, _, _) -> defineName tn) enum.eitems;
333: end
334:
335: and checkTypeInfo (isadef: defuse) ti =
336: try
337: let oldti, olddef = H.find typUsed ti.tname in
338: (* Flx_cil_check that it is the same *)
339: if oldti != ti then
340: ignore (warnContext "typeinfo for %s not shared\n" ti.tname);
341: (match !olddef, isadef with
342: Defined, Defined ->
343: ignore (warnContext "Multiple definition of type %s\n" ti.tname)
344: | Defined, Used -> ()
345: | Used, Defined ->
346: ignore (warnContext "Use of type %s before its definition\n" ti.tname)
347: | _, _ ->
348: ignore (warnContext "Bug in checkTypeInfo for %s\n" ti.tname))
349: with Not_found -> begin (* This is the first time we see it *)
350: if ti.tname = "" then
351: ignore (warnContext "typeinfo with empty name");
352: checkType ti.ttype CTDecl;
353: (* Add it to the map before we go on *)
354: H.add typUsed ti.tname (ti, ref isadef);
355: end
356:
357: (* Flx_cil_check an lvalue. If isconst then the lvalue appears in a context where
358: * only a compile-time constant can appear. Return the type of the lvalue.
359: * See the typing rule from cil.mli *)
360: and checkLval (isconst: bool) (lv: lval) : typ =
361: match lv with
362: Var vi, off ->
363: checkVariable vi;
364: checkOffset vi.vtype off
365:
366: | Mem addr, off -> begin
367: if isconst then
368: ignore (warn "Memory operation in constant");
369: let ta = checkExp false addr in
370: match unrollType ta with
371: TPtr (t, _) -> checkOffset t off
372: | _ -> E.s (bug "Mem on a non-pointer")
373: end
374:
375: (* Flx_cil_check an offset. The basetype is the type of the object referenced by the
376: * base. Return the type of the lvalue constructed from a base value of right
377: * type and the offset. See the typing rules from cil.mli *)
378: and checkOffset basetyp : offset -> typ = function
379: NoOffset -> basetyp
380: | Index (ei, o) ->
381: checkExpType false ei intType;
382: begin
383: match unrollType basetyp with
384: TArray (t, _, _) -> checkOffset t o
385: | t -> E.s (bug "typeOffset: Index on a non-array: %a" d_plaintype t)
386: end
387:
388: | Field (fi, o) ->
389: (* Now check that the host is shared propertly *)
390: checkCompInfo Used fi.fcomp;
391: (* Flx_cil_check that this exact field is part of the host *)
392: if not (List.exists (fun f -> f == fi) fi.fcomp.cfields) then
393: ignore (warn "Field %s not part of %s"
394: fi.fname (compFullName fi.fcomp));
395: checkOffset fi.ftype o
396:
397: and checkExpType (isconst: bool) (e: exp) (t: typ) =
398: let t' = checkExp isconst e in (* compute the type *)
399: if isconst then begin (* For initializers allow a string to initialize an
400: * array of characters *)
401: if typeSig t' <> typeSig t then
402: match e, t with
403: | _ -> typeMatch t' t
404: end else
405: typeMatch t' t
406:
407: (* Flx_cil_check an expression. isconst specifies if the expression occurs in a
408: * context where only a compile-time constant can occur. Return the computed
409: * type of the expression *)
410: and checkExp (isconst: bool) (e: exp) : typ =
411: E.withContext
412: (fun _ -> dprintf "check%s: %a"
413: (if isconst then "Const" else "Exp") d_exp e)
414: (fun _ ->
415: match e with
416: | Const(CInt64 (_, ik, _)) -> TInt(ik, [])
417: | Const(CChr _) -> charType
418: | Const(CStr s) -> charPtrType
419: | Const(CWStr s) -> TPtr(!wcharType,[])
420: | Const(CReal (_, fk, _)) -> TFloat(fk, [])
421: | Lval(lv) ->
422: if isconst then
423: ignore (warn "Lval in constant");
424: checkLval isconst lv
425:
426: | SizeOf(t) -> begin
427: (* Sizeof cannot be applied to certain types *)
428: checkType t CTSizeof;
429: (match unrollType t with
430: (TFun _ | TVoid _) ->
431: ignore (warn "Invalid operand for sizeof")
432: | _ ->());
433: uintType
434: end
435: | SizeOfE(e) ->
436: (* The expression in a sizeof can be anything *)
437: let te = checkExp false e in
438: checkExp isconst (SizeOf(te))
439:
440: | SizeOfStr s -> uintType
441:
442: | AlignOf(t) -> begin
443: (* Sizeof cannot be applied to certain types *)
444: checkType t CTSizeof;
445: (match unrollType t with
446: (TFun _ | TVoid _) ->
447: ignore (warn "Invalid operand for sizeof")
448: | _ ->());
449: uintType
450: end
451: | AlignOfE(e) ->
452: (* The expression in an AlignOfE can be anything *)
453: let te = checkExp false e in
454: checkExp isconst (AlignOf(te))
455:
456: | UnOp (Neg, e, tres) ->
457: checkArithmeticType tres; checkExpType isconst e tres; tres
458:
459: | UnOp (BNot, e, tres) ->
460: checkIntegralType tres; checkExpType isconst e tres; tres
461:
462: | UnOp (LNot, e, tres) ->
463: let te = checkExp isconst e in
464: checkBooleanType te;
465: checkIntegralType tres; (* Must check that t is well-formed *)
466: typeMatch tres intType;
467: tres
468:
469: | BinOp (bop, e1, e2, tres) -> begin
470: let t1 = checkExp isconst e1 in
471: let t2 = checkExp isconst e2 in
472: match bop with
473: (Mult | Div) ->
474: typeMatch t1 t2; checkArithmeticType tres;
475: typeMatch t1 tres; tres
476: | (Eq|Ne|Lt|Le|Ge|Gt) ->
477: typeMatch t1 t2; checkArithmeticType t1;
478: typeMatch tres intType; tres
479: | Mod|BAnd|BOr|BXor ->
480: typeMatch t1 t2; checkIntegralType tres;
481: typeMatch t1 tres; tres
482: | LAnd | LOr ->
483: typeMatch t1 t2; checkBooleanType tres;
484: typeMatch t1 tres; tres
485: | Shiftlt | Shiftrt ->
486: typeMatch t1 tres; checkIntegralType t1;
487: checkIntegralType t2; tres
488: | (PlusA | MinusA) ->
489: typeMatch t1 t2; typeMatch t1 tres;
490: checkArithmeticType tres; tres
491: | (PlusPI | MinusPI | IndexPI) ->
492: checkPointerType tres;
493: typeMatch t1 tres;
494: checkIntegralType t2;
495: tres
496: | MinusPP ->
497: checkPointerType t1; checkPointerType t2;
498: typeMatch t1 t2;
499: typeMatch tres intType;
500: tres
501: end
502: | AddrOf (lv) -> begin
503: let tlv = checkLval isconst lv in
504: (* Only certain types can be in AddrOf *)
505: match unrollType tlv with
506: | TVoid _ ->
507: E.s (bug "AddrOf on improper type");
508:
509: | (TInt _ | TFloat _ | TPtr _ | TComp _ | TFun _ | TArray _ ) ->
510: TPtr(tlv, [])
511:
512: | TEnum _ -> intPtrType
513: | _ -> E.s (bug "AddrOf on unknown type")
514: end
515:
516: | StartOf lv -> begin
517: let tlv = checkLval isconst lv in
518: match unrollType tlv with
519: TArray (t,_, _) -> TPtr(t, [])
520: | _ -> E.s (bug "StartOf on a non-array")
521: end
522:
523: | CastE (tres, e) -> begin
524: let et = checkExp isconst e in
525: checkType tres CTExp;
526: (* Not all types can be cast *)
527: match unrollType et with
528: TArray _ -> E.s (bug "Cast of an array type")
529: | TFun _ -> E.s (bug "Cast of a function type")
530: | TComp _ -> E.s (bug "Cast of a composite type")
531: | TVoid _ -> E.s (bug "Cast of a void type")
532: | _ -> tres
533: end)
534: () (* The argument of withContext *)
535:
536: and checkInit (i: init) : typ =
537: E.withContext
538: (fun _ -> dprintf "checkInit: %a" d_init i)
539: (fun _ ->
540: match i with
541: SingleInit e -> checkExp true e
542: (*
543: | ArrayInit (bt, len, initl) -> begin
544: checkType bt CTSizeof;
545: if List.length initl > len then
546: ignore (warn "Too many initializers in array");
547: List.iter (fun i -> checkInitType i bt) initl;
548: TArray(bt, Some (integer len), [])
549: end
550: *)
551: | CompoundInit (ct, initl) -> begin
552: checkType ct CTSizeof;
553: (match unrollType ct with
554: TArray(bt, Some (Const(CInt64(len, _, _))), _) ->
555: let rec loopIndex i = function
556: [] ->
557: if i <> len then
558: ignore (warn "Wrong number of initializers in array")
559:
560: | (Index(Const(CInt64(i', _, _)), NoOffset), ei) :: rest ->
561: if i' <> i then
562: ignore (warn "Initializer for index %s when %s was expected\n"
563: (Int64.format "%d" i') (Int64.format "%d" i));
564: checkInitType ei bt;
565: loopIndex (Int64.succ i) rest
566: | _ :: rest ->
567: ignore (warn "Malformed initializer for array element")
568: in
569: loopIndex Int64.zero initl
570: | TArray(_, _, _) ->
571: ignore (warn "Malformed initializer for array")
572: | TComp (comp, _) ->
573: if comp.cstruct then
574: let rec loopFields
575: (nextflds: fieldinfo list)
576: (initl: (offset * init) list) : unit =
577: match nextflds, initl with
578: [], [] -> () (* We are done *)
579: | f :: restf, (Field(f', NoOffset), i) :: resti ->
580: if f.fname <> f'.fname then
581: ignore (warn "Expected initializer for field %s and found one for %s\n" f.fname f'.fname);
582: checkInitType i f.ftype;
583: loopFields restf resti
584: | [], _ :: _ ->
585: ignore (warn "Too many initializers for struct")
586: | _ :: _, [] ->
587: ignore (warn "Too few initializers for struct")
588: | _, _ ->
589: ignore (warn "Malformed initializer for struct")
590: in
591: loopFields
592: (List.filter (fun f -> f.fname <> missingFieldName)
593: comp.cfields)
594: initl
595:
596: else (* UNION *)
597: if comp.cfields == [] then begin
598: if initl != [] then
599: ignore (warn "Initializer for empty union not empty");
600: end else begin
601: match initl with
602: [(Field(f, NoOffset), ei)] ->
603: if f.fcomp != comp then
604: ignore (bug "Wrong designator for union initializer");
605: if !msvcMode && f != List.hd comp.cfields then
606: ignore (warn "On MSVC you can only initialize the first field of a union");
607: checkInitType ei f.ftype
608:
609: | _ ->
610: ignore (warn "Malformed initializer for union")
611: end
612: | _ ->
613: E.s (warn "Type of Compound is not array or struct or union"));
614: ct
615: end)
616: () (* The arguments of withContext *)
617:
618:
619: and checkInitType (i: init) (t: typ) : unit =
620: let it = checkInit i in
621: typeMatch it t
622:
623: and checkStmt (s: stmt) =
624: E.withContext
625: (fun _ ->
626: (* Print context only for certain small statements *)
627: match s.skind with
628: Loop _ | If _ | Switch _ -> nil
629: | _ -> dprintf "checkStmt: %a" d_stmt s)
630: (fun _ ->
631: (* Flx_cil_check the labels *)
632: let checkLabel = function
633: Label (ln, l, _) ->
634: if H.mem labels ln then
635: ignore (warn "Multiply defined label %s" ln);
636: H.add labels ln ()
637: | Case (e, _) -> checkExpType true e intType
638: | _ -> () (* Not yet implemented *)
639: in
640: List.iter checkLabel s.labels;
641: (* See if we have seen this statement before *)
642: if List.memq s !statements then
643: ignore (warn "Statement is shared");
644: (* Remember that we have seen this one *)
645: statements := s :: !statements;
646: match s.skind with
647: Break _ | Continue _ -> ()
648: | Goto (gref, l) ->
649: currentLoc := l;
650: (* Find a label *)
651: let lab =
652: match List.filter (function Label _ -> true | _ -> false)
653: !gref.labels with
654: Label (lab, _, _) :: _ -> lab
655: | _ ->
656: ignore (warn "Goto to block without a label\n");
657: "<missing label>"
658: in
659: (* Remember it as a target *)
660: gotoTargets := (lab, !gref) :: !gotoTargets
661:
662:
663: | Return (re,l) -> begin
664: currentLoc := l;
665: match re, !currentReturnType with
666: None, TVoid _ -> ()
667: | _, TVoid _ -> ignore (warn "Invalid return value")
668: | None, _ -> ignore (warn "Invalid return value")
669: | Some re', rt' -> checkExpType false re' rt'
670: end
671: | Loop (b, l, _, _) -> checkBlock b
672: | Block b -> checkBlock b
673: | If (e, bt, bf, l) ->
674: currentLoc := l;
675: let te = checkExp false e in
676: checkBooleanType te;
677: checkBlock bt;
678: checkBlock bf
679: | Switch (e, b, cases, l) ->
680: currentLoc := l;
681: checkExpType false e intType;
682: (* Remember the statements so far *)
683: let prevStatements = !statements in
684: checkBlock b;
685: (* Now make sure that all the cases do occur in that block *)
686: List.iter
687: (fun c ->
688: if not (List.exists (function Case _ -> true | _ -> false)
689: c.labels) then
690: ignore (warn "Case in switch statment without a \"case\"\n");
691: (* Make sure it is in there *)
692: let rec findCase = function
693: | l when l == prevStatements -> (* Not found *)
694: ignore (warnContext
695: "Cannot find target of switch statement")
696: | [] -> E.s (E.bug "Flx_cil_check: findCase")
697: | c' :: rest when c == c' -> () (* Found *)
698: | _ :: rest -> findCase rest
699: in
700: findCase !statements)
701: cases;
702: | TryFinally (b, h, l) ->
703: currentLoc := l;
704: checkBlock b;
705: checkBlock h
706:
707: | TryExcept (b, (il, e), h, l) ->
708: currentLoc := l;
709: checkBlock b;
710: List.iter checkInstr il;
711: checkExpType false e intType;
712: checkBlock h
713:
714: | Instr il -> List.iter checkInstr il)
715: () (* argument of withContext *)
716:
717: and checkBlock (b: block) : unit =
718: List.iter checkStmt b.bstmts
719:
720:
721: and checkInstr (i: instr) =
722: match i with
723: | Set (dest, e, l) ->
724: currentLoc := l;
725: let t = checkLval false dest in
726: (* Not all types can be assigned to *)
727: (match unrollType t with
728: TFun _ -> ignore (warn "Assignment to a function type")
729: | TArray _ -> ignore (warn "Assignment to an array type")
730: | TVoid _ -> ignore (warn "Assignment to a void type")
731: | _ -> ());
732: checkExpType false e t
733:
734: | Call(dest, what, args, l) ->
735: currentLoc := l;
736: let (rt, formals, isva) =
737: match checkExp false what with
738: TFun(rt, formals, isva, _) -> rt, formals, isva
739: | _ -> E.s (bug "Call to a non-function")
740: in
741: (* Now check the return value*)
742: (match dest, unrollType rt with
743: None, TVoid _ -> ()
744: | Some _, TVoid _ -> ignore (warn "void value is assigned")
745: | None, _ -> () (* "Call of function is not assigned" *)
746: | Some destlv, rt' ->
747: let desttyp = checkLval false destlv in
748: if typeSig desttyp <> typeSig rt then begin
749: (* Not all types can be assigned to *)
750: (match unrollType desttyp with
751: TFun _ -> ignore (warn "Assignment to a function type")
752: | TArray _ -> ignore (warn "Assignment to an array type")
753: | TVoid _ -> ignore (warn "Assignment to a void type")
754: | _ -> ());
755: (* Not all types can be cast *)
756: (match rt' with
757: TArray _ -> ignore (warn "Cast of an array type")
758: | TFun _ -> ignore (warn "Cast of a function type")
759: | TComp _ -> ignore (warn "Cast of a composite type")
760: | TVoid _ -> ignore (warn "Cast of a void type")
761:
762: | _ -> ())
763: end);
764: (* Now check the arguments *)
765: let rec loopArgs formals args =
766: match formals, args with
767: [], _ when (isva || args = []) -> ()
768: | (fn,ft,_) :: formals, a :: args ->
769: checkExpType false a ft;
770: loopArgs formals args
771: | _, _ -> ignore (warn "Not enough arguments")
772: in
773: if formals = None then
774: ignore (warn "Call to function without prototype\n")
775: else
776: loopArgs (argsToList formals) args
777:
778: | Asm _ -> () (* Not yet implemented *)
779:
780: let rec checkGlobal = function
781: GAsm _ -> ()
782: | GPragma _ -> ()
783: | GText _ -> ()
784: | GType (ti, l) ->
785: currentLoc := l;
786: E.withContext (fun _ -> dprintf "GType(%s)" ti.tname)
787: (fun _ ->
788: checkTypeInfo Defined ti;
789: if ti.tname <> "" then defineName ti.tname)
790: ()
791:
792: | GCompTag (comp, l) ->
793: currentLoc := l;
794: checkCompInfo Defined comp;
795:
796: | GCompTagDecl (comp, l) ->
797: currentLoc := l;
798: checkCompInfo Forward comp;
799:
800: | GEnumTag (enum, l) ->
801: currentLoc := l;
802: checkEnumInfo Defined enum
803:
804: | GEnumTagDecl (enum, l) ->
805: currentLoc := l;
806: checkEnumInfo Forward enum
807:
808: | GVarDecl (vi, l) ->
809: currentLoc := l;
810: (* We might have seen it already *)
811: E.withContext (fun _ -> dprintf "GVarDecl(%s)" vi.vname)
812: (fun _ ->
813: (* If we have seen this vid already then it must be for the exact
814: * same varinfo *)
815: if H.mem varIdsEnv vi.vid then
816: checkVariable vi
817: else begin
818: defineVariable vi;
819: checkAttributes vi.vattr;
820: checkType vi.vtype CTDecl;
821: if not (vi.vglob &&
822: vi.vstorage <> Register) then
823: E.s (bug "Invalid declaration of %s" vi.vname)
824: end)
825: ()
826:
827: | GVar (vi, init, l) ->
828: currentLoc := l;
829: (* Maybe this is the first occurrence *)
830: E.withContext (fun _ -> dprintf "GVar(%s)" vi.vname)
831: (fun _ ->
832: checkGlobal (GVarDecl (vi, l));
833: (* Flx_cil_check the initializer *)
834: begin match init.init with
835: None -> ()
836: | Some i -> ignore (checkInitType i vi.vtype)
837: end;
838: (* Cannot be a function *)
839: if isFunctionType vi.vtype then
840: E.s (bug "GVar for a function (%s)\n" vi.vname);
841: )
842: ()
843:
844:
845: | GFun (fd, l) -> begin
846: currentLoc := l;
847: (* Flx_cil_check if this is the first occurrence *)
848: let vi = fd.svar in
849: let fname = vi.vname in
850: E.withContext (fun _ -> dprintf "GFun(%s)" fname)
851: (fun _ ->
852: checkGlobal (GVarDecl (vi, l));
853: (* Flx_cil_check that the argument types in the type are identical to the
854: * formals *)
855: let rec loopArgs targs formals =
856: match targs, formals with
857: [], [] -> ()
858: | (fn, ft, fa) :: targs, fo :: formals ->
859: if fn <> fo.vname || ft != fo.vtype || fa != fo.vattr then
860: ignore (warnContext
861: "Formal %s not shared (type + locals) in %s"
862: fo.vname fname);
863: loopArgs targs formals
864:
865: | _ ->
866: E.s (bug "Type has different number of formals for %s"
867: fname)
868: in
869: begin match vi.vtype with
870: TFun (rt, args, isva, a) -> begin
871: currentReturnType := rt;
872: loopArgs (argsToList args) fd.sformals
873: end
874: | _ -> E.s (bug "Function %s does not have a function type"
875: fname)
876: end;
877: ignore (fd.smaxid >= 0 || E.s (bug "smaxid < 0 for %s" fname));
878: (* Now start a new environment, in a finally clause *)
879: begin try
880: startEnv ();
881: (* Do the locals *)
882: let doLocal tctx v =
883: if v.vglob then
884: ignore (warnContext
885: "Local %s has the vglob flag set" v.vname);
886: if v.vstorage <> NoStorage && v.vstorage <> Register then
887: ignore (warnContext
888: "Local %s has storage %a\n" v.vname
889: d_storage v.vstorage);
890: checkType v.vtype tctx;
891: checkAttributes v.vattr;
892: defineVariable v
893: in
894: List.iter (doLocal CTFArg) fd.sformals;
895: List.iter (doLocal CTDecl) fd.slocals;
896: statements := [];
897: gotoTargets := [];
898: checkBlock fd.sbody;
899: H.clear labels;
900: (* Now verify that we have scanned all targets *)
901: List.iter
902: (fun (lab, t) -> if not (List.memq t !statements) then
903: ignore (warnContext
904: "Target of \"goto %s\" statement does not appear in function body" lab))
905: !gotoTargets;
906: statements := [];
907: gotoTargets := [];
908: (* Done *)
909: endEnv ()
910: with e ->
911: endEnv ();
912: raise e
913: end;
914: ())
915: () (* final argument of withContext *)
916: end
917:
918:
919: let checkFile flags fl =
920: if !E.verboseFlag then ignore (E.log "Flx_cil_checking file %s\n" fl.fileName);
921: valid := true;
922: List.iter
923: (function
924: NoFlx_cil_checkGlobalIds -> checkGlobalIds := false)
925: flags;
926: iterGlobals fl (fun g -> try checkGlobal g with _ -> ());
927: (* Flx_cil_check that for all struct/union tags there is a definition *)
928: H.iter
929: (fun k (comp, isadef) ->
930: if !isadef = Used then
931: begin
932: valid := false;
933: ignore (E.warn "Compinfo %s is referenced but not defined"
934: (compFullName comp))
935: end)
936: compUsed;
937: (* Flx_cil_check that for all enum tags there is a definition *)
938: H.iter
939: (fun k (enum, isadef) ->
940: if !isadef = Used then
941: begin
942: valid := false;
943: ignore (E.warn "Enuminfo %s is referenced but not defined"
944: enum.ename)
945: end)
946: enumUsed;
947: (* Clean the hashes to let the GC do its job *)
948: H.clear typeDefs;
949: H.clear varNamesEnv;
950: H.clear varIdsEnv;
951: H.clear allVarIds;
952: H.clear compNames;
953: H.clear compUsed;
954: H.clear enumUsed;
955: H.clear typUsed;
956: varNamesList := [];
957: if !E.verboseFlag then
958: ignore (E.log "Finished checking file %s\n" fl.fileName);
959: !valid
960:
Start ocaml section to src/flx_cil_check.mli[1
/1
]
1: # 1120 "./lpsrc/flx_cil.ipk"
2:
3: (* Flx_cil_checks the well-formedness of the file. Prints warnings and
4: * returns false if errors are found *)
5:
6: type checkFlags =
7: NoFlx_cil_checkGlobalIds (* Do not check that the global ids have the proper
8: * hash value *)
9:
10: val checkFile: checkFlags list -> Flx_cil_cil.file -> bool
Start ocaml section to src/flx_cil_cil.ml[1
/1
]
1: # 1131 "./lpsrc/flx_cil.ipk"
2:
3: open Flx_cil_escape
4: open Flx_cil_pretty
5: open Flx_cil_trace (* sm: 'trace' function *)
6: open Flx_cil_machdep_type
7: module E = Flx_cil_errormsg
8: module H = Hashtbl
9:
10: (*
11: * CIL: An intermediate language for analyzing C progams.
12: *
13: * Version Tue Dec 12 15:21:52 PST 2000
14: * Scott McPeak, George Necula, Wes Weimer
15: *
16: *)
17:
18:
19: module M = Flx_cil_machdep
20:
21: (* The module Flx_cil_cilversion is generated automatically by Makefile from
22: * information in configure.in *)
23: let cilVersion = Flx_cil_cilversion.cilVersion
24: let cilVersionMajor = Flx_cil_cilversion.cilVersionMajor
25: let cilVersionMinor = Flx_cil_cilversion.cilVersionMinor
26: let cilVersionRevision = Flx_cil_cilversion.cilVersionRev
27:
28: (* A few globals that control the interpretation of C source *)
29: let msvcMode = ref false (* Whether the pretty printer should
30: * print output for the MS VC
31: * compiler. Default is GCC *)
32:
33: let useLogicalOperators = ref false
34:
35: (* Flx_cil_cil.initFlx_cil_cil will set this to the current machine description *)
36: let theMachine : Flx_cil_machdep_type.mach ref = ref M.gcc
37:
38: let little_endian = ref true
39: let char_is_unsigned = ref false
40:
41: type lineDirectiveStyle =
42: | LineComment
43: | LinePreprocessorInput
44: | LinePreprocessorOutput
45:
46: let lineDirectiveStyle = ref (Some LinePreprocessorInput)
47:
48: let print_CIL_Input = ref false
49:
50: let printCilAsIs = ref false
51:
52: (* sm: return the string 's' if we're printing output for gcc, suppres
53: * it if we're printing for CIL to parse back in. the purpose is to
54: * hide things from gcc that it complains about, but still be able
55: * to do lossless transformations when CIL is the consumer *)
56: let forgcc (s: string) : string =
57: if (!print_CIL_Input) then "" else s
58:
59:
60: let debugConstFold = false
61:
62: (** The Abstract Syntax of CIL *)
63:
64:
65: (** The top-level representation of a CIL source file. Its main contents is
66: the list of global declarations and definitions. *)
67: type file =
68: { mutable fileName: string; (** The complete file name *)
69: mutable globals: global list; (** List of globals as they will appear
70: in the printed file *)
71: mutable globinit: fundec option;
72: (** An optional global initializer function. This is a function where
73: * you can put stuff that must be executed before the program is
74: * started. This function, is conceptually at the end of the file,
75: * although it is not part of the globals list. Use {!Flx_cil_cil.getGlobInit}
76: * to create/get one. *)
77: mutable globinitcalled: bool;
78: (** Whether the global initialization function is called in main. This
79: should always be false if there is no global initializer. When
80: you create a global initialization CIL will try to insert code in
81: main to call it. *)
82: }
83:
84:
85: (** The main type for representing global declarations and definitions. A list
86: of these form a CIL file. The order of globals in the file is generally
87: important. *)
88: and global =
89: | GType of typeinfo * location
90: (** A typedef. All uses of type names (through the [TNamed] constructor)
91: must be preceeded in the file by a definition of the name. The string
92: is the defined name and always not-empty. *)
93:
94: | GCompTag of compinfo * location
95: (** Defines a struct/union tag with some fields. There must be one of
96: these for each struct/union tag that you use (through the [TComp]
97: constructor) since this is the only context in which the fields are
98: printed. Consequently nested structure tag definitions must be
99: broken into individual definitions with the innermost structure
100: defined first. *)
101:
102: | GCompTagDecl of compinfo * location
103: (** Declares a struct/union tag. Use as a forward declaration. This is
104: * printed without the fields. *)
105:
106: | GEnumTag of enuminfo * location
107: (** Declares an enumeration tag with some fields. There must be one of
108: these for each enumeration tag that you use (through the [TEnum]
109: constructor) since this is the only context in which the items are
110: printed. *)
111:
112: | GEnumTagDecl of enuminfo * location
113: (** Declares an enumeration tag. Use as a forward declaration. This is
114: * printed without the items. *)
115:
116: | GVarDecl of varinfo * location
117: (** A variable declaration (not a definition). If the variable has a
118: function type then this is a prototype. There can be several
119: declarations and at most one definition for a given variable. If both
120: forms appear then they must share the same varinfo structure. A
121: prototype shares the varinfo with the fundec of the definition. Either
122: has storage Extern or there must be a definition in this file *)
123:
124: | GVar of varinfo * initinfo * location
125: (** A variable definition. Can have an initializer. The initializer is
126: * updateable so that you can change it without requiring to recreate
127: * the list of globals. There can be at most one definition for a
128: * variable in an entire program. Cannot have storage Extern or function
129: * type. *)
130:
131:
132: | GFun of fundec * location
133: (** A function definition. *)
134:
135: | GAsm of string * location (** Global asm statement. These ones
136: can contain only a template *)
137: | GPragma of attribute * location (** Pragmas at top level. Use the same
138: syntax as attributes *)
139: | GText of string (** Some text (printed verbatim) at
140: top level. E.g., this way you can
141: put comments in the output. *)
142:
143:
144: (** The various types available. Every type is associated with a list of
145: * attributes, which are always kept in sorted order. Use {!Flx_cil_cil.addAttribute}
146: * and {!Flx_cil_cil.addAttributes} to construct list of attributes. If you want to
147: * inspect a type, you should use {!Flx_cil_cil.unrollType} to see through the uses
148: * of named types. *)
149: and typ =
150: TVoid of attributes (** Void type *)
151: | TInt of ikind * attributes (** An integer type. The kind specifies
152: the sign and width. *)
153: | TFloat of fkind * attributes (** A floating-point type. The kind
154: specifies the precision. *)
155:
156: | TPtr of typ * attributes
157: (** Pointer type. *)
158:
159: | TArray of typ * exp option * attributes
160: (** Array type. It indicates the base type and the array length. *)
161:
162: | TFun of typ * (string * typ * attributes) list option * bool * attributes
163: (** Function type. Indicates the type of the result, the name, type
164: * and name attributes of the formal arguments ([None] if no
165: * arguments were specified, as in a function whose definition or
166: * prototype we have not seen; [Some \[\]] means void). Use
167: * {!Flx_cil_cil.argsToList} to obtain a list of arguments. The boolean
168: * indicates if it is a variable-argument function. If this is the
169: * type of a varinfo for which we have a function declaration then
170: * the information for the formals must match that in the
171: * function's sformals. *)
172:
173: | TNamed of typeinfo * attributes
174: (* The use of a named type. All uses of the same type name must
175: * share the typeinfo. Each such type name must be preceeded
176: * in the file by a [GType] global. This is printed as just the
177: * type name. The actual referred type is not printed here and is
178: * carried only to simplify processing. To see through a sequence
179: * of named type references, use {!Flx_cil_cil.unrollType}. The attributes
180: * are in addition to those given when the type name was defined. *)
181:
182: | TComp of compinfo * attributes
183: (** A reference to a struct or a union type. All references to the
184: same struct or union must share the same compinfo among them and
185: with a [GCompTag] global that preceeds all uses (except maybe
186: those that are pointers to the composite type). The attributes
187: given are those pertaining to this use of the type and are in
188: addition to the attributes that were given at the definition of
189: the type and which are stored in the compinfo. *)
190:
191: | TEnum of enuminfo * attributes
192: (** A reference to an enumeration type. All such references must
193: share the enuminfo among them and with a [GEnumTag] global that
194: preceeds all uses. The attributes refer to this use of the
195: enumeration and are in addition to the attributes of the
196: enumeration itself, which are stored inside the enuminfo *)
197:
198:
199:
200: | TBuiltin_va_list of attributes
201: (** This is the same as the gcc's type with the same name *)
202:
203: (** Various kinds of integers *)
204: and ikind =
205: | IBool (** [_Bool] *)
206: | IChar (** [char] *)
207: | ISChar (** [signed char] *)
208: | IUChar (** [unsigned char] *)
209: | IInt (** [int] *)
210: | IUInt (** [unsigned int] *)
211: | IShort (** [short] *)
212: | IUShort (** [unsigned short] *)
213: | ILong (** [long] *)
214: | IULong (** [unsigned long] *)
215: | ILongLong (** [long long] (or [_int64] on Microsoft Visual C) *)
216: | IULongLong (** [unsigned long long] (or [unsigned _int64] on Microsoft
217: Visual C) *)
218:
219: (** Various kinds of floating-point numbers*)
220: and fkind =
221: FFloat (** [float] *)
222: | FDouble (** [double] *)
223: | FLongDouble (** [long double] *)
224:
225: | CFloat (** [_Complex] *)
226: | CDouble (** [double _Complex] *)
227: | CLongDouble (** [long double _Complex] *)
228:
229: | IFloat (** [_Imaginary] *)
230: | IDouble (** [double _Imaginary] *)
231: | ILongDouble (** [long double _Imaginary] *)
232:
233: (** An attribute has a name and some optional parameters *)
234: and attribute = Attr of string * attrparam list
235:
236: (** Attributes are lists sorted by the attribute name *)
237: and attributes = attribute list
238:
239: (** The type of parameters in attributes *)
240: and attrparam =
241: | AInt of int (** An integer constant *)
242: | AStr of string (** A string constant *)
243: | ACons of string * attrparam list (** Constructed attributes. These
244: are printed [foo(a1,a2,...,an)].
245: The list of parameters can be
246: empty and in that case the
247: parentheses are not printed. *)
248: | ASizeOf of typ (** A way to talk about types *)
249: | ASizeOfE of attrparam
250: | AAlignOf of typ
251: | AAlignOfE of attrparam
252: | AUnOp of unop * attrparam
253: | ABinOp of binop * attrparam * attrparam
254: | ADot of attrparam * string (** a.foo **)
255:
256:
257: (** Information about a composite type (a struct or a union). Use
258: {!Flx_cil_cil.mkCompInfo}
259: to create non-recursive or (potentially) recursive versions of this. Make
260: sure you have a [GCompTag] for each one of these. *)
261: and compinfo = {
262: mutable cstruct: bool; (** True if struct, False if union *)
263: mutable cname: string; (** The name. Always non-empty. Use
264: * {!Flx_cil_cil.compFullName} to get the
265: * full name of a comp (along with
266: * the struct or union) *)
267: mutable ckey: int; (** A unique integer constructed from
268: * the name. Use {!Hashtbl.hash} on
269: * the string returned by
270: * {!Flx_cil_cil.compFullName}. All compinfo
271: * for a given key are shared. *)
272: mutable cfields: fieldinfo list; (** Information about the fields *)
273: mutable cattr: attributes; (** The attributes that are defined at
274: the same time as the composite
275: type *)
276: mutable cdefined: bool; (** Whether this is a defined
277: * compinfo. *)
278: mutable creferenced: bool; (** True if used. Initially set to
279: * false *)
280: }
281:
282: (** Information about a struct/union field *)
283: and fieldinfo = {
284: mutable fcomp: compinfo; (** The compinfo of the host. Note
285: that this must be shared with the
286: host since there can be only one
287: compinfo for a given id *)
288: mutable fname: string; (** The name of the field. Might be
289: * the value of
290: * {!Flx_cil_cil.missingFieldName} in which
291: * case it must be a bitfield and is
292: * not printed and it does not
293: * participate in initialization *)
294: mutable ftype: typ; (** The type *)
295: mutable fbitfield: int option; (** If a bitfield then ftype should be
296: an integer type *)
297: mutable fattr: attributes; (** The attributes for this field
298: * (not for its type) *)
299: mutable floc: location; (** The location where this field
300: * is defined *)
301: mutable fstorage: storage; (** Must be NoStorage or Static,
302: * indicates nonstatic or static member *)
303: }
304:
305:
306:
307: (** Information about an enumeration. This is shared by all references to an
308: enumeration. Make sure you have a [GEnumTag] for each of of these. *)
309: and enuminfo = {
310: mutable ename: string; (** The name. Always non-empty *)
311: mutable eitems: (string * exp * location) list; (** Items with names
312: and values. This list
313: should be
314: non-empty. The item
315: values must be
316: compile-time
317: constants. *)
318: mutable eattr: attributes; (** Attributes *)
319: mutable ereferenced: bool; (** True if used. Initially set to false*)
320: }
321:
322: (** Information about a defined type *)
323: and typeinfo = {
324: mutable tname: string;
325: (** The name. Can be empty only in a [GType] when introducing a composite
326: * or enumeration tag. If empty cannot be refered to from the file *)
327: mutable ttype: typ;
328: (** The actual type. *)
329: mutable treferenced: bool;
330: (** True if used. Initially set to false*)
331: }
332:
333:
334: (** Information about a variable. These structures are shared by all
335: * references to the variable. So, you can change the name easily, for
336: * example. Use one of the {!Flx_cil_cil.makeLocalVar}, {!Flx_cil_cil.makeTempVar} or
337: * {!Flx_cil_cil.makeGlobalVar} to create instances of this data structure. *)
338: and varinfo = {
339: mutable vname: string; (** The name of the variable. Cannot
340: * be empty. *)
341: mutable vtype: typ; (** The declared type of the
342: * variable. *)
343: mutable vattr: attributes; (** A list of attributes associated
344: * with the variable. *)
345: mutable vstorage: storage; (** The storage-class *)
346: (* The other fields are not used in varinfo when they appear in the formal
347: * argument list in a [TFun] type *)
348:
349:
350: mutable vglob: bool; (** True if this is a global variable*)
351:
352: (** Whether this varinfo is for an inline function. *)
353: mutable vinline: bool;
354:
355: mutable vdecl: location; (** Location of variable declaration *)
356:
357: mutable vid: int; (** A unique integer identifier. *)
358: mutable vaddrof: bool; (** True if the address of this
359: variable is taken. CIL will set
360: * these flags when it parses C, but
361: * you should make sure to set the
362: * flag whenever your transformation
363: * create [AddrOf] expression. *)
364:
365: mutable vreferenced: bool; (** True if this variable is ever
366: referenced. This is computed by
367: [removeUnusedVars]. It is safe to
368: just initialize this to False *)
369: }
370:
371: (** Storage-class information *)
372: and storage =
373: | NoStorage (** The default storage. Nothing is
374: * printed *)
375: | Static
376: | Register
377: | Extern
378:
379:
380: (** Expressions (Side-effect free)*)
381: and exp =
382: | Const of constant (** Constant *)
383: | Lval of lval (** Lvalue *)
384: | SizeOf of typ (** sizeof(<type>). Has [unsigned
385: * int] type (ISO 6.5.3.4). This is
386: * not turned into a constant because
387: * some transformations might want to
388: * change types *)
389:
390: | SizeOfE of exp (** sizeof(<expression>) *)
391: | SizeOfStr of string
392: (** sizeof(string_literal). We separate this case out because this is the
393: * only instance in which a string literal should not be treated as
394: * having type pointer to character. *)
395:
396: | AlignOf of typ (** Has [unsigned int] type *)
397: | AlignOfE of exp
398:
399:
400: | UnOp of unop * exp * typ (** Unary operation. Includes
401: the type of the result *)
402:
403: | BinOp of binop * exp * exp * typ
404: (** Binary operation. Includes the
405: type of the result. The arithemtic
406: conversions are made explicit
407: for the arguments *)
408: | CastE of typ * exp (** Use {!Flx_cil_cil.mkCast} to make casts *)
409:
410: | AddrOf of lval (** Always use {!Flx_cil_cil.mkAddrOf} to
411: * construct one of these. Apply to an
412: * lvalue of type [T] yields an
413: * expression of type [TPtr(T)] *)
414:
415: | StartOf of lval (** There is no C correspondent for this. C has
416: * implicit coercions from an array to the address
417: * of the first element. [StartOf] is used in CIL to
418: * simplify type checking and is just an explicit
419: * form of the above mentioned implicit conversion.
420: * It is not printed. Given an lval of type
421: * [TArray(T)] produces an expression of type
422: * [TPtr(T)]. *)
423:
424:
425: (** Literal constants *)
426: and constant =
427: | CInt64 of int64 * ikind * string option
428: (** Integer constant. Give the ikind (see ISO9899 6.1.3.2)
429: * and the textual representation, if available. Use
430: * {!Flx_cil_cil.integer} or {!Flx_cil_cil.kinteger} to create these. Watch
431: * out for integers that cannot be represented on 64 bits.
432: * OCAML does not give Overflow exceptions. *)
433: | CStr of string (** String constant (of pointer type) *)
434: | CWStr of int64 list (** Wide string constant (of type "wchar_t *") *)
435: | CChr of char (** Character constant *)
436: | CReal of float * fkind * string option (** Floating point constant. Give
437: the fkind (see ISO 6.4.4.2) and
438: also the textual representation,
439: if available *)
440:
441: (** Unary operators *)
442: and unop =
443: Neg (** Unary minus *)
444: | BNot (** Bitwise complement (~) *)
445: | LNot (** Logical Not (!) *)
446:
447: (** Binary operations *)
448: and binop =
449: PlusA (** arithmetic + *)
450: | PlusPI (** pointer + integer *)
451: | IndexPI (** pointer + integer but only when
452: * it arises from an expression
453: * [e\[i\]] when [e] is a pointer and
454: * not an array. This is semantically
455: * the same as PlusPI but CCured uses
456: * this as a hint that the integer is
457: * probably positive. *)
458: | MinusA (** arithmetic - *)
459: | MinusPI (** pointer - integer *)
460: | MinusPP (** pointer - pointer *)
461: | Mult (** * *)
462: | Div (** / *)
463: | Mod (** % *)
464: | Shiftlt (** shift left *)
465: | Shiftrt (** shift right *)
466:
467: | Lt (** < (arithmetic comparison) *)
468: | Gt (** > (arithmetic comparison) *)
469: | Le (** <= (arithmetic comparison) *)
470: | Ge (** > (arithmetic comparison) *)
471: | Eq (** == (arithmetic comparison) *)
472: | Ne (** != (arithmetic comparison) *)
473: | BAnd (** bitwise and *)
474: | BXor (** exclusive-or *)
475: | BOr (** inclusive-or *)
476:
477: | LAnd (** logical and *)
478: | LOr (** logical or *)
479:
480:
481:
482:
483: (** An lvalue denotes the contents of a range of memory addresses. This range
484: * is denoted as a host object along with an offset within the object. The
485: * host object can be of two kinds: a local or global variable, or an object
486: * whose address is in a pointer expression. We distinguish the two cases so
487: * that we can tell quickly whether we are accessing some component of a
488: * variable directly or we are accessing a memory location through a pointer.*)
489: and lval =
490: lhost * offset
491:
492: (** The host part of an {!Flx_cil_cil.lval}. *)
493: and lhost =
494: | Var of varinfo
495: (** The host is a variable. *)
496:
497: | Mem of exp
498: (** The host is an object of type [T] when the expression has pointer
499: * [TPtr(T)]. *)
500:
501:
502: (** The offset part of an {!Flx_cil_cil.lval}. Each offset can be applied to certain
503: * kinds of lvalues and its effect is that it advances the starting address
504: * of the lvalue and changes the denoted type, essentially focussing to some
505: * smaller lvalue that is contained in the original one. *)
506: and offset =
507: | NoOffset (** No offset. Can be applied to any lvalue and does
508: * not change either the starting address or the type.
509: * This is used when the lval consists of just a host
510: * or as a terminator in a list of other kinds of
511: * offsets. *)
512:
513: | Field of fieldinfo * offset
514: (** A field offset. Can be applied only to an lvalue
515: * that denotes a structure or a union that contains
516: * the mentioned field. This advances the offset to the
517: * beginning of the mentioned field and changes the
518: * type to the type of the mentioned field. *)
519:
520: | Index of exp * offset
521: (** An array index offset. Can be applied only to an
522: * lvalue that denotes an array. This advances the
523: * starting address of the lval to the beginning of the
524: * mentioned array element and changes the denoted type
525: * to be the type of the array element *)
526:
527:
528:
529: (* The following equivalences hold *)
530: (* Mem(AddrOf(Mem a, aoff)), off = Mem a, aoff + off *)
531: (* Mem(AddrOf(Var v, aoff)), off = Var v, aoff + off *)
532: (* AddrOf (Mem a, NoOffset) = a *)
533:
534: (** Initializers for global variables. You can create an initializer with
535: * {!Flx_cil_cil.makeZeroInit}. *)
536: and init =
537: | SingleInit of exp (** A single initializer *)
538: | CompoundInit of typ * (offset * init) list
539: (** Used only for initializers of structures, unions and arrays.
540: * The offsets are all of the form [Field(f, NoOffset)] or
541: * [Index(i, NoOffset)] and specify the field or the index being
542: * initialized. For structures all fields
543: * must have an initializer (except the unnamed bitfields), in
544: * the proper order. This is necessary since the offsets are not
545: * printed. For arrays the list must contain a prefix of the
546: * initializers; the rest are 0-initialized.
547: * For unions there must be exactly one initializer. If
548: * the initializer is not for the first field then a field
549: * designator is printed, so you better be on GCC since MSVC does
550: * not understand this. You can scan an initializer list with
551: * {!Flx_cil_cil.foldLeftCompound}. *)
552:
553: (** We want to be able to update an initializer in a global variable, so we
554: * define it as a mutable field *)
555: and initinfo = {
556: mutable init : init option;
557: }
558:
559:
560: (** Function definitions. *)
561: and fundec =
562: { mutable svar: varinfo;
563: (** Holds the name and type as a variable, so we can refer to it
564: * easily from the program. All references to this function either
565: * in a function call or in a prototype must point to the same
566: * varinfo. *)
567: mutable sformals: varinfo list;
568: (** Formals. These must be shared with the formals that appear in the
569: * type of the function. Use {!Flx_cil_cil.setFormals} or
570: * {!Flx_cil_cil.setFunctionType} to set these
571: * formals and ensure that they are reflected in the function type.
572: * Do not make copies of these because the body refers to them. *)
573: mutable slocals: varinfo list;
574: (** Locals. Does not include the sformals. Do not make copies of
575: * these because the body refers to them. *)
576: mutable smaxid: int; (** Max local id. Starts at 0. *)
577: mutable sbody: block; (** The function body. *)
578: mutable smaxstmtid: int option; (** max id of a (reachable) statement
579: * in this function, if we have
580: * computed it. range = 0 ...
581: * (smaxstmtid-1) *)
582: }
583:
584:
585: (** A block is a sequence of statements with the control falling through from
586: one element to the next *)
587: and block =
588: { mutable battrs: attributes; (** Attributes for the block *)
589: mutable bstmts: stmt list; (** The statements comprising the block*)
590: }
591:
592:
593: (** Statements.
594: The statement is the structural unit in the control flow graph. Use mkStmt
595: to make a statement and then fill in the fields. *)
596: and stmt = {
597: mutable labels: label list; (** Whether the statement starts with
598: some labels, case statements or
599: default statement *)
600: mutable skind: stmtkind; (** The kind of statement *)
601:
602: (* Now some additional control flow information. Initially this is not
603: * filled in. *)
604: mutable sid: int; (** A number (>= 0) that is unique
605: in a function. *)
606: mutable succs: stmt list; (** The successor statements. They can
607: always be computed from the skind
608: and the context in which this
609: statement appears *)
610: mutable preds: stmt list; (** The inverse of the succs function*)
611: }
612:
613: (** Labels *)
614: and label =
615: Label of string * location * bool
616: (** A real label. If the bool is "true", the label is from the
617: * input source program. If the bool is "false", the label was
618: * created by CIL or some other transformation *)
619: | Case of exp * location (** A case statement *)
620: | Default of location (** A default statement *)
621:
622:
623:
624: (* The various kinds of statements *)
625: and stmtkind =
626: | Instr of instr list (** A group of instructions that do not
627: contain control flow. Control
628: implicitly falls through. *)
629: | Return of exp option * location (** The return statement. This is a
630: leaf in the CFG. *)
631:
632: | Goto of stmt ref * location (** A goto statement. Appears from
633: actual goto's in the code. *)
634: | Break of location (** A break to the end of the nearest
635: enclosing Loop or Switch *)
636: | Continue of location (** A continue to the start of the
637: nearest enclosing [Loop] *)
638: | If of exp * block * block * location (** A conditional.
639: Two successors, the "then" and
640: the "else" branches. Both
641: branches fall-through to the
642: successor of the If statement *)
643: | Switch of exp * block * (stmt list) * location
644: (** A switch statement. The block
645: contains within all of the cases.
646: We also have direct pointers to the
647: statements that implement the
648: cases. Which cases they implement
649: you can get from the labels of the
650: statement *)
651:
652: | Loop of block * location * (stmt option) * (stmt option)
653: (** A [while(1)] loop *)
654:
655: | Block of block (** Just a block of statements. Use it
656: as a way to keep some attributes
657: local *)
658: (** On MSVC we support structured exception handling. This is what you
659: * might expect. Control can get into the finally block either from the
660: * end of the body block, or if an exception is thrown. The location
661: * corresponds to the try keyword. *)
662: | TryFinally of block * block * location
663:
664: (** On MSVC we support structured exception handling. The try/except
665: * statement is a bit tricky:
666: __try { blk }
667: __except (e) {
668: handler
669: }
670:
671: The argument to __except must be an expression. However, we keep a
672: list of instructions AND an expression in case you need to make
673: function calls. We'll print those as a comma expression. The control
674: can get to the __except expression only if an exception is thrown.
675: After that, depending on the value of the expression the control
676: goes to the handler, propagates the exception, or retries the
677: exception !!! The location corresponds to the try keyword.
678: *)
679: | TryExcept of block * (instr list * exp) * block * location
680:
681:
682: (** Instructions. They may cause effects directly but may not have control
683: flow.*)
684: and instr =
685: Set of lval * exp * location (** An assignment. A cast is present
686: if the exp has different type
687: from lval *)
688: | Call of lval option * exp * exp list * location
689: (** optional: result is an lval. A cast might be
690: necessary if the declared result type of the
691: function is not the same as that of the
692: destination. If the function is declared then
693: casts are inserted for those arguments that
694: correspond to declared formals. (The actual
695: number of arguments might be smaller or larger
696: than the declared number of arguments. C allows
697: this.) If the type of the result variable is not
698: the same as the declared type of the function
699: result then an implicit cast exists. *)
700:
701: (* See the GCC specification for the meaning of ASM.
702: * If the source is MS VC then only the templates
703: * are used *)
704: (* sm: I've added a notes.txt file which contains more
705: * information on interpreting Asm instructions *)
706: | Asm of attributes * (* Really only const and volatile can appear
707: * here *)
708: string list * (* templates (CR-separated) *)
709: (string * lval) list * (* outputs must be lvals with
710: * constraints. I would like these
711: * to be actually variables, but I
712: * run into some trouble with ASMs
713: * in the Linux sources *)
714: (string * exp) list * (* inputs with constraints *)
715: string list * (* register clobbers *)
716: location
717: (** An inline assembly instruction. The arguments are (1) a list of
718: attributes (only const and volatile can appear here and only for
719: GCC), (2) templates (CR-separated), (3) a list of
720: outputs, each of which is an lvalue with a constraint, (4) a list
721: of input expressions along with constraints, (5) clobbered
722: registers, and (5) location information *)
723:
724:
725:
726: (** Describes a location in a source file *)
727: and location = {
728: line: int; (** The line number. -1 means "do not know" *)
729: file: string; (** The name of the source file*)
730: byte: int; (** The byte position in the source file *)
731: }
732:
733:
734:
735: (** To be able to add/remove features easily, each feature should be package
736: * as an interface with the following interface. These features should be *)
737: type featureDescr = {
738: fd_enabled: bool ref;
739: (** The enable flag. Set to default value *)
740:
741: fd_name: string;
742: (** This is used to construct an option "--doxxx" and "--dontxxx" that
743: * enable and disable the feature *)
744:
745: fd_description: string;
746: (* A longer name that can be used to document the new options *)
747:
748: fd_extraopt: (string * Arg.spec * string) list;
749: (** Additional command line options *)
750:
751: fd_doit: (file -> unit);
752: (** This performs the transformation *)
753:
754: fd_post_check: bool;
755: (* Whether to perform a CIL consistency checking after this stage, if
756: * checking is enabled (--check is passed to cilly) *)
757: }
758:
759: let locUnknown = { line = -1; file = ""; byte = -1; }
760: (* A reference to the current location *)
761: let currentLoc : location ref = ref locUnknown
762:
763: let compareLoc (a: location) (b: location) : int =
764: let namecmp = compare a.file b.file in
765: if namecmp != 0
766: then namecmp
767: else
768: let linecmp = a.line - b.line in
769: if linecmp != 0
770: then linecmp
771: else a.byte - b.byte
772:
773: let argsToList : (string * typ * attributes) list option
774: -> (string * typ * attributes) list
775: = function
776: None -> []
777: | Some al -> al
778:
779:
780:
781: (** Different visiting actions. 'a will be instantiated with [exp], [instr],
782: etc. *)
783: type 'a visitAction =
784: SkipChildren (** Do not visit the children. Return
785: the node as it is. *)
786: | DoChildren (** Continue with the children of this
787: node. Rebuild the node on return
788: if any of the children changes
789: (use == test) *)
790: | ChangeTo of 'a (** Replace the expression with the
791: given one *)
792: | ChangeDoChildrenPost of 'a * ('a -> 'a) (** First consider that the entire
793: exp is replaced by the first
794: parameter. Then continue with
795: the children. On return rebuild
796: the node if any of the children
797: has changed and then apply the
798: function on the node *)
799:
800:
801:
802: (* sm/gn: cil visitor interface for traversing Flx_cil_cil trees. *)
803: (* Use visitCilStmt and/or visitCilFile to use this. *)
804: (* Some of the nodes are changed in place if the children are changed. Use
805: * one of Change... actions if you want to copy the node *)
806:
807: (** A visitor interface for traversing CIL trees. Create instantiations of
808: * this type by specializing the class {!Flx_cil_cil.nopCilVisitor}. *)
809: class type cilVisitor = object
810:
811: method vvdec: varinfo -> varinfo visitAction
812: (** Invoked for each variable declaration. The subtrees to be traversed
813: * are those corresponding to the type and attributes of the variable.
814: * Note that variable declarations are all the [GVar], [GVarDecl], [GFun],
815: * all the [varinfo] in formals of function types, and the formals and
816: * locals for function definitions. This means that the list of formals
817: * in a function definition will be traversed twice, once as part of the
818: * function type and second as part of the formals in a function
819: * definition. *)
820:
821: method vvrbl: varinfo -> varinfo visitAction
822: (** Invoked on each variable use. Here only the [SkipChildren] and
823: * [ChangeTo] actions make sense since there are no subtrees. Note that
824: * the type and attributes of the variable are not traversed for a
825: * variable use *)
826:
827: method vexpr: exp -> exp visitAction
828: (** Invoked on each expression occurence. The subtrees are the
829: * subexpressions, the types (for a [Cast] or [SizeOf] expression) or the
830: * variable use. *)
831:
832: method vlval: lval -> lval visitAction
833: (** Invoked on each lvalue occurence *)
834:
835: method voffs: offset -> offset visitAction
836: (** Invoked on each offset occurrence that is *not* as part
837: * of an initializer list specification, i.e. in an lval or
838: * recursively inside an offset. *)
839:
840: method vinitoffs: offset -> offset visitAction
841: (** Invoked on each offset appearing in the list of a
842: * CompoundInit initializer. *)
843:
844: method vinst: instr -> instr list visitAction
845: (** Invoked on each instruction occurrence. The [ChangeTo] action can
846: * replace this instruction with a list of instructions *)
847:
848: method vstmt: stmt -> stmt visitAction
849: (** Control-flow statement. *)
850:
851: method vblock: block -> block visitAction (** Block. Replaced in
852: place. *)
853: method vfunc: fundec -> fundec visitAction (** Function definition.
854: Replaced in place. *)
855: method vglob: global -> global list visitAction (** Global (vars, types,
856: etc.) *)
857: method vinit: init -> init visitAction (** Initializers for globals *)
858: method vtype: typ -> typ visitAction (** Use of some type. Note
859: * that for structure/union
860: * and enumeration types the
861: * definition of the
862: * composite type is not
863: * visited. Use [vglob] to
864: * visit it. *)
865: method vattr: attribute -> attribute list visitAction
866: (** Attribute. Each attribute can be replaced by a list *)
867:
868: (** Add here instructions while visiting to queue them to
869: * preceede the current statement or instruction being processed *)
870: method queueInstr: instr list -> unit
871:
872: (** Gets the queue of instructions and resets the queue *)
873: method unqueueInstr: unit -> instr list
874:
875: end
876:
877: (* the default visitor does nothing at each node, but does *)
878: (* not stop; hence they return true *)
879: class nopCilVisitor : cilVisitor = object
880: method vvrbl (v:varinfo) = DoChildren (* variable *)
881: method vvdec (v:varinfo) = DoChildren (* variable
882: * declaration *)
883: method vexpr (e:exp) = DoChildren (* expression *)
884: method vlval (l:lval) = DoChildren (* lval (base is 1st
885: * field) *)
886: method voffs (o:offset) = DoChildren (* lval or recursive offset *)
887: method vinitoffs (o:offset) = DoChildren (* initializer offset *)
888: method vinst (i:instr) = DoChildren (* imperative instruction *)
889: method vstmt (s:stmt) = DoChildren (* constrol-flow statement *)
890: method vblock (b: block) = DoChildren
891: method vfunc (f:fundec) = DoChildren (* function definition *)
892: method vglob (g:global) = DoChildren (* global (vars, types, etc.) *)
893: method vinit (i:init) = DoChildren (* global initializers *)
894: method vtype (t:typ) = DoChildren (* use of some type *)
895: method vattr (a: attribute) = DoChildren
896:
897: val mutable instrQueue = []
898:
899: method queueInstr (il: instr list) =
900: List.iter (fun i -> instrQueue <- i :: instrQueue) il
901:
902: method unqueueInstr () =
903: let res = List.rev instrQueue in
904: instrQueue <- [];
905: res
906:
907: end
908:
909: let assertEmptyQueue vis =
910: if vis#unqueueInstr () <> [] then
911: (* Either a visitor inserted an instruction somewhere that it shouldn't
912: have (i.e. at the top level rather than inside of a statement), or
913: there's a bug in the visitor engine. *)
914: E.s (E.bug "Visitor's instruction queue is not empty\n. You should only use queueInstr inside a function body!");
915: ()
916:
917:
918: let lu = locUnknown
919:
920: (* sm: utility *)
921: let startsWith (prefix: string) (s: string) : bool =
922: (
923: let prefixLen = (String.length prefix) in
924: (String.length s) >= prefixLen &&
925: (String.sub s 0 prefixLen) = prefix
926: )
927:
928:
929: let get_instrLoc (inst : instr) =
930: match inst with
931: Set(_, _, loc) -> loc
932: | Call(_, _, _, loc) -> loc
933: | Asm(_, _, _, _, _, loc) -> loc
934: let get_globalLoc (g : global) =
935: match g with
936: | GFun(_,l) -> (l)
937: | GType(_,l) -> (l)
938: | GEnumTag(_,l) -> (l)
939: | GEnumTagDecl(_,l) -> (l)
940: | GCompTag(_,l) -> (l)
941: | GCompTagDecl(_,l) -> (l)
942: | GVarDecl(_,l) -> (l)
943: | GVar(_,_,l) -> (l)
944: | GAsm(_,l) -> (l)
945: | GPragma(_,l) -> (l)
946: | GText(_) -> locUnknown
947:
948: let rec get_stmtLoc (statement : stmtkind) =
949: match statement with
950: Instr([]) -> lu
951: | Instr(hd::tl) -> get_instrLoc(hd)
952: | Return(_, loc) -> loc
953: | Goto(_, loc) -> loc
954: | Break(loc) -> loc
955: | Continue(loc) -> loc
956: | If(_, _, _, loc) -> loc
957: | Switch (_, _, _, loc) -> loc
958: | Loop (_, loc, _, _) -> loc
959: | Block b -> if b.bstmts = [] then lu
960: else get_stmtLoc ((List.hd b.bstmts).skind)
961: | TryFinally (_, _, l) -> l
962: | TryExcept (_, _, _, l) -> l
963:
964:
965: (* The next variable identifier to use. Counts up *)
966: let nextGlobalVID = ref 1
967:
968: (* The next compindo identifier to use. Counts up. *)
969: let nextCompinfoKey = ref 1
970:
971: (* Some error reporting functions *)
972: let d_loc (_: unit) (loc: location) : doc =
973: text loc.file ++ chr ':' ++ num loc.line
974:
975: let d_thisloc (_: unit) : doc = d_loc () !currentLoc
976:
977: let error (fmt : ('a,unit,doc) format) : 'a =
978: let f d =
979: E.hadErrors := true;
980: ignore (eprintf "@!%t: Error: %a@!"
981: d_thisloc insert d);
982: nil
983: in
984: Flx_cil_pretty.gprintf f fmt
985:
986: let unimp (fmt : ('a,unit,doc) format) : 'a =
987: let f d =
988: E.hadErrors := true;
989: ignore (eprintf "@!%t: Unimplemented: %a@!"
990: d_thisloc insert d);
991: nil
992: in
993: Flx_cil_pretty.gprintf f fmt
994:
995: let bug (fmt : ('a,unit,doc) format) : 'a =
996: let f d =
997: E.hadErrors := true;
998: ignore (eprintf "@!%t: Bug: %a@!"
999: d_thisloc insert d);
1000: E.showContext ();
1001: nil
1002: in
1003: Flx_cil_pretty.gprintf f fmt
1004:
1005: let errorLoc (loc: location) (fmt : ('a,unit,doc) format) : 'a =
1006: let f d =
1007: E.hadErrors := true;
1008: ignore (eprintf "@!%a: Error: %a@!"
1009: d_loc loc insert d);
1010: E.showContext ();
1011: nil
1012: in
1013: Flx_cil_pretty.gprintf f fmt
1014:
1015: let warn (fmt : ('a,unit,doc) format) : 'a =
1016: let f d =
1017: ignore (eprintf "@!%t: Warning: %a@!"
1018: d_thisloc insert d);
1019: nil
1020: in
1021: Flx_cil_pretty.gprintf f fmt
1022:
1023:
1024: let warnOpt (fmt : ('a,unit,doc) format) : 'a =
1025: let f d =
1026: if !E.warnFlag then
1027: ignore (eprintf "@!%t: Warning: %a@!"
1028: d_thisloc insert d);
1029: nil
1030: in
1031: Flx_cil_pretty.gprintf f fmt
1032:
1033: let warnContext (fmt : ('a,unit,doc) format) : 'a =
1034: let f d =
1035: ignore (eprintf "@!%t: Warning: %a@!"
1036: d_thisloc insert d);
1037: E.showContext ();
1038: nil
1039: in
1040: Flx_cil_pretty.gprintf f fmt
1041:
1042: let warnContextOpt (fmt : ('a,unit,doc) format) : 'a =
1043: let f d =
1044: if !E.warnFlag then
1045: ignore (eprintf "@!%t: Warning: %a@!"
1046: d_thisloc insert d);
1047: E.showContext ();
1048: nil
1049: in
1050: Flx_cil_pretty.gprintf f fmt
1051:
1052: let warnLoc (loc: location) (fmt : ('a,unit,doc) format) : 'a =
1053: let f d =
1054: ignore (eprintf "@!%a: Warning: %a@!"
1055: d_loc loc insert d);
1056: E.showContext ();
1057: nil
1058: in
1059: Flx_cil_pretty.gprintf f fmt
1060:
1061:
1062:
1063: (* Represents an integer as for a given kind. Some truncation might be
1064: * necessary *)
1065: let truncateInteger64 (k: ikind) (i: int64) =
1066: let nrBits, signed =
1067: match k with
1068: | IBool -> 8, true
1069: | IChar|ISChar -> 8, true
1070: | IUChar -> 8, false
1071: | IShort -> 16, true
1072: | IUShort -> 16, false
1073: | IInt | ILong -> 32, true
1074: | IUInt | IULong -> 32, false
1075: | ILongLong -> 64, true
1076: | IULongLong -> 64, false
1077: in
1078: if nrBits = 64 then
1079: i
1080: else begin
1081: let i1 = Int64.shift_left i (64 - nrBits) in
1082: let i2 =
1083: if signed then Int64.shift_right i1 (64 - nrBits)
1084: else Int64.shift_right_logical i1 (64 - nrBits)
1085: in
1086: i2
1087: end
1088:
1089: (* Construct an integer constant with possible truncation *)
1090: let kinteger64 (k: ikind) (i: int64) : exp =
1091: let i' = truncateInteger64 k i in
1092: if i' <> i then
1093: ignore (warnOpt "Truncating integer %s to %s\n"
1094: (Int64.format "0x%x" i) (Int64.format "0x%x" i'));
1095: Const (CInt64(i', k, None))
1096:
1097: (* Construct an integer of a given kind. *)
1098: let kinteger (k: ikind) (i: int) = kinteger64 k (Int64.of_int i)
1099:
1100: (* Construct an integer. Use only for values that fit on 31 bits *)
1101: let integer (i: int) = Const (CInt64(Int64.of_int i, IInt, None))
1102:
1103: let zero = integer 0
1104: let one = integer 1
1105: let mone = integer (-1)
1106:
1107: let rec isInteger = function
1108: | Const(CInt64 (n,_,_)) -> Some n
1109: | Const(CChr c) -> Some (Int64.of_int (Char.code c))
1110: | CastE(_, e) -> isInteger e
1111: | _ -> None
1112:
1113:
1114:
1115: let rec isZero (e: exp) : bool = isInteger e = Some Int64.zero
1116:
1117: let voidType = TVoid([])
1118: let intType = TInt(IInt,[])
1119: let uintType = TInt(IUInt,[])
1120: let longType = TInt(ILong,[])
1121: let ulongType = TInt(IULong,[])
1122: let charType = TInt(IChar, [])
1123: let boolType = TInt(IBool, [])
1124:
1125: let charPtrType = TPtr(charType,[])
1126: let charConstPtrType = TPtr(TInt(IChar, [Attr("const", [])]),[])
1127: let stringLiteralType = ref charPtrType
1128:
1129: let voidPtrType = TPtr(voidType, [])
1130: let intPtrType = TPtr(intType, [])
1131: let uintPtrType = TPtr(uintType, [])
1132:
1133: let doubleType = TFloat(FDouble, [])
1134:
1135: let parseInt (str: string) : exp =
1136: let hasSuffix str =
1137: let l = String.length str in
1138: fun s ->
1139: let ls = String.length s in
1140: l >= ls && s = String.uppercase (String.sub str (l - ls) ls)
1141: in
1142: let l = String.length str in
1143: (* See if it is octal or hex *)
1144: let octalhex = (l >= 1 && String.get str 0 = '0') in
1145: (* The length of the suffix and a list of possible kinds. See ISO
1146: * 6.4.4.1 *)
1147: let hasSuffix = hasSuffix str in
1148: let suffixlen, kinds =
1149: if hasSuffix "ULL" || hasSuffix "LLU" then
1150: 3, [IULongLong]
1151: else if hasSuffix "LL" then
1152: 2, if octalhex then [ILongLong; IULongLong] else [ILongLong]
1153: else if hasSuffix "UL" || hasSuffix "LU" then
1154: 2, [IULong; IULongLong]
1155: else if hasSuffix "L" then
1156: 1, if octalhex then [ILong; IULong; ILongLong; IULongLong]
1157: else [ILong; ILongLong]
1158: else if hasSuffix "U" then
1159: 1, [IUInt; IULong; IULongLong]
1160: else
1161: 0, if octalhex || true (* !!! This is against the ISO but it
1162: * is what GCC and MSVC do !!! *)
1163: then [IInt; IUInt; ILong; IULong; ILongLong; IULongLong]
1164: else [IInt; ILong; IUInt; ILongLong]
1165: in
1166: (* Convert to integer. To prevent overflow we do the arithmetic
1167: * on Int64 and we take care of overflow. We work only with
1168: * positive integers since the lexer takes care of the sign *)
1169: let rec toInt (base: int64) (acc: int64) (idx: int) : int64 =
1170: let doAcc (what: int) =
1171: let acc' =
1172: Int64.add (Int64.mul base acc) (Int64.of_int what) in
1173: if acc < Int64.zero || (* We clearly overflow since base >= 2
1174: * *)
1175: (acc' > Int64.zero && acc' < acc) then
1176: E.s (unimp "Cannot represent on 64 bits the integer %s\n"
1177: str)
1178: else
1179: toInt base acc' (idx + 1)
1180: in
1181: if idx >= l - suffixlen then begin
1182: acc
1183: end else
1184: let ch = String.get str idx in
1185: if ch >= '0' && ch <= '9' then
1186: doAcc (Char.code ch - Char.code '0')
1187: else if ch >= 'a' && ch <= 'f' then
1188: doAcc (10 + Char.code ch - Char.code 'a')
1189: else if ch >= 'A' && ch <= 'F' then
1190: doAcc (10 + Char.code ch - Char.code 'A')
1191: else
1192: E.s (bug "Invalid integer constant: %s" str)
1193: in
1194: try
1195: let i =
1196: if octalhex then
1197: if l >= 2 &&
1198: (let c = String.get str 1 in c = 'x' || c = 'X') then
1199: toInt (Int64.of_int 16) Int64.zero 2
1200: else
1201: toInt (Int64.of_int 8) Int64.zero 1
1202: else
1203: toInt (Int64.of_int 10) Int64.zero 0
1204: in
1205: (* Construct an integer of the first kinds that fits. i must be
1206: * POSITIVE *)
1207: let res =
1208: let rec loop = function
1209: | ((IInt | ILong) as k) :: _
1210: when i < Int64.shift_left (Int64.of_int 1) 31 ->
1211: kinteger64 k i
1212: | ((IUInt | IULong) as k) :: _
1213: when i < Int64.shift_left (Int64.of_int 1) 32
1214: -> kinteger64 k i
1215: | (ILongLong as k) :: _
1216: when i <= Int64.sub (Int64.shift_left
1217: (Int64.of_int 1) 63)
1218: (Int64.of_int 1)
1219: ->
1220: kinteger64 k i
1221: | (IULongLong as k) :: _ -> kinteger64 k i
1222: | _ :: rest -> loop rest
1223: | [] -> E.s (E.unimp "Cannot represent the integer %s\n"
1224: (Int64.to_string i))
1225: in
1226: loop kinds
1227: in
1228: res
1229: with e -> begin
1230: ignore (E.log "int_of_string %s (%s)\n" str
1231: (Printexc.to_string e));
1232: zero
1233: end
1234:
1235:
1236: (* An integer type that fits pointers. Initialized by initCIL *)
1237: let upointType = ref voidType
1238:
1239: (* An integer type that fits wchar_t. Initialized by initCIL *)
1240: let wcharKind = ref IChar
1241: let wcharType = ref voidType
1242:
1243:
1244: (* An integer type that is the type of sizeof. Initialized by initCIL *)
1245: let typeOfSizeOf = ref voidType
1246: let kindOfSizeOf = ref IUInt
1247:
1248: (** Returns true if and only if the given integer type is signed. *)
1249: let isSigned = function
1250: | IBool
1251: | IUChar
1252: | IUShort
1253: | IUInt
1254: | IULong
1255: | IULongLong ->
1256: false
1257: | ISChar
1258: | IShort
1259: | IInt
1260: | ILong
1261: | ILongLong ->
1262: true
1263: | IChar ->
1264: not !theMachine.Flx_cil_machdep_type.char_is_unsigned
1265:
1266: let mkStmt (sk: stmtkind) : stmt =
1267: { skind = sk;
1268: labels = [];
1269: sid = -1; succs = []; preds = [] }
1270:
1271: let mkBlock (slst: stmt list) : block =
1272: { battrs = []; bstmts = slst; }
1273:
1274: let mkEmptyStmt () = mkStmt (Instr [])
1275: let mkStmtOneInstr (i: instr) = mkStmt (Instr [i])
1276:
1277: let dummyInstr = (Asm([], ["dummy statement!!"], [], [], [], lu))
1278: let dummyStmt = mkStmt (Instr [dummyInstr])
1279:
1280: let compactStmts (b: stmt list) : stmt list =
1281: (* Try to compress statements. Scan the list of statements and remember
1282: * the last instrunction statement encountered, along with a Flx_cil_clist of
1283: * instructions in it. *)
1284: let rec compress (lastinstrstmt: stmt) (* Might be dummStmt *)
1285: (lastinstrs: instr Flx_cil_clist.clist)
1286: (body: stmt list) =
1287: let finishLast (tail: stmt list) : stmt list =
1288: if lastinstrstmt == dummyStmt then tail
1289: else begin
1290: lastinstrstmt.skind <- Instr (Flx_cil_clist.toList lastinstrs);
1291: lastinstrstmt :: tail
1292: end
1293: in
1294: match body with
1295: [] -> finishLast []
1296: | ({skind=Instr il} as s) :: rest ->
1297: let ils = Flx_cil_clist.fromList il in
1298: if lastinstrstmt != dummyStmt && s.labels == [] then
1299: compress lastinstrstmt (Flx_cil_clist.append lastinstrs ils) rest
1300: else
1301: finishLast (compress s ils rest)
1302:
1303: | s :: rest ->
1304: let res = s :: compress dummyStmt Flx_cil_clist.empty rest in
1305: finishLast res
1306: in
1307: compress dummyStmt Flx_cil_clist.empty b
1308:
1309:
1310: (** Construct sorted lists of attributes ***)
1311: let rec addAttribute (Attr(an, _) as a: attribute) (al: attributes) =
1312: let rec insertSorted = function
1313: [] -> [a]
1314: | ((Attr(an0, _) as a0) :: rest) as l ->
1315: if an < an0 then a :: l
1316: else if an > an0 then a0 :: insertSorted rest
1317: else if a = a0 then l (* Do not add if already in there *)
1318: else a0 :: insertSorted rest (* Make sure we see all attributes with
1319: * this name *)
1320: in
1321: insertSorted al
1322:
1323: (** The second attribute list is sorted *)
1324: and addAttributes al0 (al: attributes) : attributes =
1325: if al0 == [] then al else
1326: List.fold_left (fun acc a -> addAttribute a acc) al al0
1327:
1328: and dropAttribute (an: string) (al: attributes) =
1329: List.filter (fun (Attr(an', _)) -> an <> an') al
1330:
1331: and dropAttributes (anl: string list) (al: attributes) =
1332: List.fold_left (fun acc an -> dropAttribute an acc) al anl
1333:
1334: and filterAttributes (s: string) (al: attribute list) : attribute list =
1335: List.filter (fun (Attr(an, _)) -> an = s) al
1336:
1337: (* sm: *)
1338: let hasAttribute s al =
1339: (filterAttributes s al <> [])
1340:
1341:
1342: type attributeClass =
1343: AttrName of bool
1344: (* Attribute of a name. If argument is true and we are on MSVC then
1345: * the attribute is printed using __declspec as part of the storage
1346: * specifier *)
1347: | AttrFunType of bool
1348: (* Attribute of a function type. If argument is true and we are on
1349: * MSVC then the attribute is printed just before the function name *)
1350:
1351: | AttrType (* Attribute of a type *)
1352:
1353: (* This table contains the mapping of predefined attributes to classes.
1354: * Extend this table with more attributes as you need. This table is used to
1355: * determine how to associate attributes with names or type during cabs2cil
1356: * conversion *)
1357: let attributeHash: (string, attributeClass) H.t =
1358: let table = H.create 13 in
1359: List.iter (fun a -> H.add table a (AttrName false))
1360: [ "section"; "constructor"; "destructor"; "unused"; "weak";
1361: "no_instrument_function"; "alias"; "no_check_memory_usage";
1362: "exception"; "model"; (* "restrict"; *)
1363: "aconst"; "__asm__" (* Gcc uses this to specifiy the name to be used in
1364: * assembly for a global *)];
1365:
1366: (* Now come the MSVC declspec attributes *)
1367: List.iter (fun a -> H.add table a (AttrName true))
1368: [ "thread"; "naked"; "dllimport"; "dllexport"; "noreturn";
1369: "selectany"; "allocate"; "nothrow"; "novtable"; "property";
1370: "uuid"; "align" ];
1371:
1372: List.iter (fun a -> H.add table a (AttrFunType false))
1373: [ "format"; "regparm"; "longcall" ];
1374: List.iter (fun a -> H.add table a (AttrFunType true))
1375: [ "stdcall";"cdecl"; "fastcall" ];
1376: List.iter (fun a -> H.add table a AttrType)
1377: [ "const"; "volatile"; "restrict"; "mode" ];
1378: table
1379:
1380:
1381: (* Partition the attributes into classes *)
1382: let partitionAttributes
1383: ~(default:attributeClass)
1384: (attrs: attribute list) :
1385: attribute list * attribute list * attribute list =
1386: let rec loop (n,f,t) = function
1387: [] -> n, f, t
1388: | (Attr(an, _) as a) :: rest ->
1389: match (try H.find attributeHash an with Not_found -> default) with
1390: AttrName _ -> loop (addAttribute a n, f, t) rest
1391: | AttrFunType _ -> loop (n, addAttribute a f, t) rest
1392: | AttrType -> loop (n, f, addAttribute a t) rest
1393: in
1394: loop ([], [], []) attrs
1395:
1396:
1397: (* Get the full name of a comp *)
1398: let compFullName comp =
1399: (if comp.cstruct then "struct " else "union ") ^ comp.cname
1400:
1401:
1402: let missingFieldName = "___missing_field_name"
1403:
1404: (** Creates a a (potentially recursive) composite type. Make sure you add a
1405: * GTag for it to the file! **)
1406: let mkCompInfo
1407: (isstruct: bool)
1408: (n: string)
1409: (* fspec is a function that when given a forward
1410: * representation of the structure type constructs the type of
1411: * the fields. The function can ignore this argument if not
1412: * constructing a recursive type. *)
1413: (mkfspec: compinfo -> (string * typ * int option * attribute list *
1414: location * storage) list)
1415: (a: attribute list) : compinfo =
1416:
1417: (* make an new name for anonymous structs *)
1418: if n = "" then
1419: E.s (E.bug "mkCompInfo: missing structure name\n");
1420: (* Make a new self cell and a forward reference *)
1421: let comp =
1422: { cstruct = isstruct; cname = ""; ckey = 0; cfields = [];
1423: cattr = a; creferenced = false;
1424: (* Make this compinfo undefined by default *)
1425: cdefined = false; }
1426: in
1427: comp.cname <- n;
1428: comp.ckey <- !nextCompinfoKey;
1429: incr nextCompinfoKey;
1430: let self = ref voidType in
1431: let flds =
1432: List.map (fun (fn, ft, fb, fa, fl, fs) ->
1433: { fcomp = comp;
1434: ftype = ft;
1435: fname = fn;
1436: fbitfield = fb;
1437: fattr = fa;
1438: floc = fl;
1439: fstorage = fs}) (mkfspec comp) in
1440: comp.cfields <- flds;
1441: if flds <> [] then comp.cdefined <- true;
1442: comp
1443:
1444: (** Make a copy of a compinfo, changing the name and the key *)
1445: let copyCompInfo (ci: compinfo) (n: string) : compinfo =
1446: let ci' = {ci with cname = n;
1447: ckey = !nextCompinfoKey; } in
1448: incr nextCompinfoKey;
1449: (* Copy the fields and set the new pointers to parents *)
1450: ci'.cfields <- List.map (fun f -> {f with fcomp = ci'}) ci'.cfields;
1451: ci'
1452:
1453: (**** Flx_cil_utility functions ******)
1454: let rec unrollType = function (* Might drop some attributes !! *)
1455: TNamed (r, _) -> unrollType r.ttype
1456: | x -> x
1457:
1458: let rec unrollTypeDeep = function (* Might drop some attributes !! *)
1459: TNamed (r, _) -> unrollTypeDeep r.ttype
1460: | TPtr(t, a) -> TPtr(unrollTypeDeep t, a)
1461: | TArray(t, l, a) -> TArray(unrollTypeDeep t, l, a)
1462: | TFun(rt, args, isva, a) ->
1463: TFun (unrollTypeDeep rt,
1464: (match args with
1465: None -> None
1466: | Some argl ->
1467: Some (List.map (fun (an,at,aa) -> (an, unrollTypeDeep at, aa)) argl)),
1468: isva, a)
1469: | x -> x
1470:
1471: let isVoidType t =
1472: match unrollType t with
1473: TVoid _ -> true
1474: | _ -> false
1475: let isVoidPtrType t =
1476: match unrollType t with
1477: TPtr(tau,_) when isVoidType tau -> true
1478: | _ -> false
1479:
1480: let var vi : lval = (Var vi, NoOffset)
1481: (* let assign vi e = Instrs(Set (var vi, e), lu) *)
1482:
1483: let mkString s = Const(CStr s)
1484:
1485:
1486: let mkWhile ~(guard:exp) ~(body: stmt list) : stmt list =
1487: (* Do it like this so that the pretty printer recognizes it *)
1488: [ mkStmt (Loop (mkBlock (mkStmt (If(guard,
1489: mkBlock [ mkEmptyStmt () ],
1490: mkBlock [ mkStmt (Break lu)], lu)) ::
1491: body), lu, None, None)) ]
1492:
1493:
1494:
1495: let mkFor ~(start: stmt list) ~(guard: exp) ~(next: stmt list)
1496: ~(body: stmt list) : stmt list =
1497: (start @
1498: (mkWhile guard (body @ next)))
1499:
1500:
1501: let mkForIncr ~(iter : varinfo) ~(first: exp) ~stopat:(past: exp) ~(incr: exp)
1502: ~(body: stmt list) : stmt list =
1503: (* See what kind of operator we need *)
1504: let compop, nextop =
1505: match unrollType iter.vtype with
1506: TPtr _ -> Lt, PlusPI
1507: | _ -> Lt, PlusA
1508: in
1509: mkFor
1510: [ mkStmt (Instr [(Set (var iter, first, lu))]) ]
1511: (BinOp(compop, Lval(var iter), past, intType))
1512: [ mkStmt (Instr [(Set (var iter,
1513: (BinOp(nextop, Lval(var iter), incr, iter.vtype)),
1514: lu))])]
1515: body
1516:
1517:
1518:
1519:
1520: (* the name of the C function we call to get ccgr ASTs
1521: external parse : string -> file = "cil_main"
1522: *)
1523: (*
1524: Flx_cil_pretty Printing
1525: *)
1526:
1527: let d_ikind () = function
1528: | IBool -> text "_Bool"
1529: | IChar -> text "char"
1530: | ISChar -> text "signed char"
1531: | IUChar -> text "unsigned char"
1532: | IInt -> text "int"
1533: | IUInt -> text "unsigned int"
1534: | IShort -> text "short"
1535: | IUShort -> text "unsigned short"
1536: | ILong -> text "long"
1537: | IULong -> text "unsigned long"
1538: | ILongLong ->
1539: if !msvcMode then text "__int64" else text "long long"
1540: | IULongLong ->
1541: if !msvcMode then text "unsigned __int64"
1542: else text "unsigned long long"
1543:
1544: let d_fkind () = function
1545: FFloat -> text "float"
1546: | FDouble -> text "double"
1547: | FLongDouble -> text "long double"
1548:
1549: | CFloat -> text "_Complex"
1550: | CDouble -> text "double _Complex"
1551: | CLongDouble -> text "long double _Complex"
1552:
1553: | IFloat -> text "_Imaginary"
1554: | IDouble -> text "double _Imaginary"
1555: | ILongDouble -> text "long double _Imaginary"
1556:
1557: let d_storage () = function
1558: NoStorage -> nil
1559: | Static -> text "static "
1560: | Extern -> text "extern "
1561: | Register -> text "register "
1562:
1563: (* sm: need this value below *)
1564: let mostNeg32BitInt : int64 = (Int64.of_string "-0x80000000")
1565: let mostNeg64BitInt : int64 = (Int64.of_string "-0x8000000000000000")
1566:
1567: (* constant *)
1568: let d_const () c =
1569: let suffix ik =
1570: match ik with
1571: IUInt -> "U"
1572: | ILong -> "L"
1573: | IULong -> "UL"
1574: | ILongLong -> if !msvcMode then "L" else "LL"
1575: | IULongLong -> if !msvcMode then "UL" else "ULL"
1576: | _ -> ""
1577: in
1578: match c with
1579: CInt64(_, _, Some s) -> text s (* Always print the text if there is one *)
1580: | CInt64(i, ik, None) ->
1581: (* Watch out here for negative integers that we should be printing as
1582: * large positive ones *)
1583: if i < Int64.zero
1584: && (match ik with
1585: IUInt | IULong | IULongLong | IUChar | IUShort -> true | _ -> false) then
1586: let high = Int64.shift_right i 32 in
1587: if ik <> IULongLong && ik <> ILongLong && high = Int64.of_int (-1) then
1588: (* Print only the low order 32 bits *)
1589: text ("0x" ^
1590: Int64.format "%x" (Int64.logand i (Int64.shift_right_logical high 32))
1591: ^ suffix ik)
1592: else
1593: text ("0x" ^ Int64.format "%x" i ^ suffix ik)
1594: else (
1595: if (i = mostNeg32BitInt) then
1596: (* sm: quirk here: if you print -2147483648 then this is two tokens *)
1597: (* in C, and the second one is too large to represent in a signed *)
1598: (* int.. so we do what's done in limits.h, and print (-2147483467-1); *)
1599: (* in gcc this avoids a warning, but it might avoid a real problem *)
1600: (* on another compiler or a 64-bit architecture *)
1601: text "(-0x7FFFFFFF-1)"
1602: else if (i = mostNeg64BitInt) then
1603: (* The same is true of the largest 64-bit negative. *)
1604: text "(-0x7FFFFFFFFFFFFFFF-1)"
1605: else
1606: text (Int64.to_string i ^ suffix ik)
1607: )
1608:
1609: | CStr(s) -> text ("\"" ^ escape_string s ^ "\"")
1610: | CWStr(s) ->
1611: (* text ("L\"" ^ escape_string s ^ "\"") *)
1612: (List.fold_left (fun acc elt ->
1613: acc ++
1614: if (elt >= Int64.zero &&
1615: elt <= (Int64.of_int 255)) then
1616: text (escape_char (Char.chr (Int64.to_int elt)))
1617: else
1618: ( text (Printf.sprintf "\\x%LX\"" elt) ++ break ++
1619: (text "\""))
1620: ) (text "L\"") s ) ++ text "\""
1621: (* we cannot print L"\xabcd" "feedme" as L"\xabcdfeedme" --
1622: * the former has 7 wide characters and the later has 3. *)
1623:
1624: | CChr(c) -> text ("'" ^ escape_char c ^ "'")
1625: | CReal(_, _, Some s) -> text s
1626: | CReal(f, _, None) -> text (string_of_float f)
1627:
1628: (* Parentheses level. An expression "a op b" is printed parenthesized if its
1629: * parentheses level is >= that that of its context. Identifiers have the
1630: * lowest level and weakly binding operators (e.g. |) have the largest level.
1631: * The correctness criterion is that a smaller level MUST correspond to a
1632: * stronger precedence!
1633: *)
1634: let derefStarLevel = 20
1635: let indexLevel = 20
1636: let arrowLevel = 20
1637: let addrOfLevel = 30
1638: let additiveLevel = 60
1639: let comparativeLevel = 70
1640: let bitwiseLevel = 75
1641: let getParenthLevel = function
1642: | BinOp((LAnd | LOr), _,_,_) -> 80
1643: (* Bit operations. *)
1644: | BinOp((BOr|BXor|BAnd),_,_,_) -> bitwiseLevel (* 75 *)
1645:
1646: (* Comparisons *)
1647: | BinOp((Eq|Ne|Gt|Lt|Ge|Le),_,_,_) ->
1648: comparativeLevel (* 70 *)
1649: (* Additive. Shifts can have higher
1650: * level than + or - but I want
1651: * parentheses around them *)
1652: | BinOp((MinusA|MinusPP|MinusPI|PlusA|
1653: PlusPI|IndexPI|Shiftlt|Shiftrt),_,_,_)
1654: -> additiveLevel (* 60 *)
1655:
1656: (* Multiplicative *)
1657: | BinOp((Div|Mod|Mult),_,_,_) -> 40
1658:
1659: (* Unary *)
1660: | CastE(_,_) -> 30
1661: | AddrOf(_) -> 30
1662: | StartOf(_) -> 30
1663: | UnOp((Neg|BNot|LNot),_,_) -> 30
1664:
1665: (* Lvals *)
1666: | Lval(Mem _ , _) -> 20
1667: | Lval(Var _, (Field _|Index _)) -> 20
1668: | SizeOf _ | SizeOfE _ | SizeOfStr _ -> 20
1669: | AlignOf _ | AlignOfE _ -> 20
1670:
1671: | Lval(Var _, NoOffset) -> 0 (* Plain variables *)
1672: | Const _ -> 0 (* Constants *)
1673:
1674:
1675:
1676: (* Separate out the storage-modifier name attributes *)
1677: let separateStorageModifiers (al: attribute list) =
1678: let isstoragemod (Attr(an, _): attribute) : bool =
1679: try
1680: match H.find attributeHash an with
1681: AttrName issm -> issm
1682: | _ -> E.s (E.bug "separateStorageModifier: %s is not a name attribute" an)
1683: with Not_found -> false
1684: in
1685: let stom, rest = List.partition isstoragemod al in
1686: if not !msvcMode then
1687: stom, rest
1688: else
1689: (* Put back the declspec. Put it without the leading __ since these will
1690: * be added later *)
1691: let stom' =
1692: List.map (fun (Attr(an, args)) ->
1693: Attr("declspec", [ACons(an, args)])) stom in
1694: stom', rest
1695:
1696:
1697: let rec typeAttrs = function
1698: TVoid a -> a
1699: | TInt (_, a) -> a
1700: | TFloat (_, a) -> a
1701: | TNamed (t, a) -> addAttributes a (typeAttrs t.ttype)
1702: | TPtr (_, a) -> a
1703: | TArray (_, _, a) -> a
1704: | TComp (comp, a) -> addAttributes comp.cattr a
1705: | TEnum (enum, a) -> addAttributes enum.eattr a
1706: | TFun (_, _, _, a) -> a
1707: | TBuiltin_va_list a -> a
1708:
1709:
1710: let setTypeAttrs t a =
1711: match t with
1712: TVoid _ -> TVoid a
1713: | TInt (i, _) -> TInt (i, a)
1714: | TFloat (f, _) -> TFloat (f, a)
1715: | TNamed (t, _) -> TNamed(t, a)
1716: | TPtr (t', _) -> TPtr(t', a)
1717: | TArray (t', l, _) -> TArray(t', l, a)
1718: | TComp (comp, _) -> TComp (comp, a)
1719: | TEnum (enum, _) -> TEnum (enum, a)
1720: | TFun (r, args, v, _) -> TFun(r,args,v,a)
1721: | TBuiltin_va_list _ -> TBuiltin_va_list a
1722:
1723:
1724: let typeAddAttributes a0 t =
1725: begin
1726: match a0 with
1727: | [] ->
1728: (* no attributes, keep same type *)
1729: t
1730: | _ ->
1731: (* anything else: add a0 to existing attributes *)
1732: let add (a: attributes) = addAttributes a0 a in
1733: match t with
1734: TVoid a -> TVoid (add a)
1735: | TInt (ik, a) -> TInt (ik, add a)
1736: | TFloat (fk, a) -> TFloat (fk, add a)
1737: | TEnum (enum, a) -> TEnum (enum, add a)
1738: | TPtr (t, a) -> TPtr (t, add a)
1739: | TArray (t, l, a) -> TArray (t, l, add a)
1740: | TFun (t, args, isva, a) -> TFun(t, args, isva, add a)
1741: | TComp (comp, a) -> TComp (comp, add a)
1742: | TNamed (t, a) -> TNamed (t, add a)
1743: | TBuiltin_va_list a -> TBuiltin_va_list (add a)
1744: end
1745:
1746: let typeRemoveAttributes (anl: string list) t =
1747: let drop (al: attributes) = dropAttributes anl al in
1748: match t with
1749: TVoid a -> TVoid (drop a)
1750: | TInt (ik, a) -> TInt (ik, drop a)
1751: | TFloat (fk, a) -> TFloat (fk, drop a)
1752: | TEnum (enum, a) -> TEnum (enum, drop a)
1753: | TPtr (t, a) -> TPtr (t, drop a)
1754: | TArray (t, l, a) -> TArray (t, l, drop a)
1755: | TFun (t, args, isva, a) -> TFun(t, args, isva, drop a)
1756: | TComp (comp, a) -> TComp (comp, drop a)
1757: | TNamed (t, a) -> TNamed (t, drop a)
1758: | TBuiltin_va_list a -> TBuiltin_va_list (drop a)
1759:
1760:
1761: (* Type signatures. Two types are identical iff they have identical
1762: * signatures *)
1763: type typsig =
1764: TSArray of typsig * exp option * attribute list
1765: | TSPtr of typsig * attribute list
1766: | TSComp of bool * string * attribute list
1767: | TSFun of typsig * typsig list * bool * attribute list
1768: | TSEnum of string * attribute list
1769: | TSBase of typ
1770:
1771: (* Compute a type signature *)
1772: let rec typeSigWithAttrs doattr t =
1773: let typeSig = typeSigWithAttrs doattr in
1774: match t with
1775: | TInt (ik, al) -> TSBase (TInt (ik, doattr al))
1776: | TFloat (fk, al) -> TSBase (TFloat (fk, doattr al))
1777: | TVoid al -> TSBase (TVoid (doattr al))
1778: | TEnum (enum, a) -> TSEnum (enum.ename, doattr a)
1779: | TPtr (t, a) -> TSPtr (typeSig t, doattr a)
1780: | TArray (t,l,a) -> TSArray(typeSig t, l, doattr a)
1781: | TComp (comp, a) ->
1782: TSComp (comp.cstruct, comp.cname, doattr (addAttributes comp.cattr a))
1783: | TFun(rt,args,isva,a) ->
1784: TSFun(typeSig rt,
1785: List.map (fun (_, atype, _) -> (typeSig atype)) (argsToList args),
1786: isva, doattr a)
1787: | TNamed(t, a) -> typeSigAddAttrs (doattr a) (typeSig t.ttype)
1788: | TBuiltin_va_list al -> TSBase (TBuiltin_va_list (doattr al))
1789: and typeSigAddAttrs a0 t =
1790: if a0 == [] then t else
1791: match t with
1792: TSBase t -> TSBase (typeAddAttributes a0 t)
1793: | TSPtr (ts, a) -> TSPtr (ts, addAttributes a0 a)
1794: | TSArray (ts, l, a) -> TSArray(ts, l, addAttributes a0 a)
1795: | TSComp (iss, n, a) -> TSComp (iss, n, addAttributes a0 a)
1796: | TSEnum (n, a) -> TSEnum (n, addAttributes a0 a)
1797: | TSFun(ts, tsargs, isva, a) -> TSFun(ts, tsargs, isva, addAttributes a0 a)
1798:
1799:
1800: let typeSig t = typeSigWithAttrs (fun al -> al) t
1801:
1802: (* Remove the attribute from the top-level of the type signature *)
1803: let setTypeSigAttrs (a: attribute list) = function
1804: TSBase t -> TSBase (setTypeAttrs t a)
1805: | TSPtr (ts, _) -> TSPtr (ts, a)
1806: | TSArray (ts, l, _) -> TSArray(ts, l, a)
1807: | TSComp (iss, n, _) -> TSComp (iss, n, a)
1808: | TSEnum (n, _) -> TSEnum (n, a)
1809: | TSFun (ts, tsargs, isva, _) -> TSFun (ts, tsargs, isva, a)
1810:
1811:
1812: let typeSigAttrs = function
1813: TSBase t -> typeAttrs t
1814: | TSPtr (ts, a) -> a
1815: | TSArray (ts, l, a) -> a
1816: | TSComp (iss, n, a) -> a
1817: | TSEnum (n, a) -> a
1818: | TSFun (ts, tsargs, isva, a) -> a
1819:
1820:
1821: (**** Compute the type of an expression ****)
1822: let rec typeOf (e: exp) : typ =
1823: match e with
1824: | Const(CInt64 (_, ik, _)) -> TInt(ik, [])
1825:
1826: (* Character constants have type int. ISO/IEC 9899:1999 (E),
1827: * section 6.4.4.4 [Character constants], paragraph 10, if you
1828: * don't believe me. *)
1829: | Const(CChr _) -> intType
1830:
1831: (* The type of a string is a pointer to characters ! The only case when
1832: * you would want it to be an array is as an argument to sizeof, but we
1833: * have SizeOfStr for that *)
1834: | Const(CStr s) -> !stringLiteralType
1835:
1836: | Const(CWStr s) -> TPtr(!wcharType,[])
1837:
1838: | Const(CReal (_, fk, _)) -> TFloat(fk, [])
1839: | Lval(lv) -> typeOfLval lv
1840: | SizeOf _ | SizeOfE _ | SizeOfStr _ -> !typeOfSizeOf
1841: | AlignOf _ | AlignOfE _ -> !typeOfSizeOf
1842: | UnOp (_, _, t) -> t
1843: | BinOp (_, _, _, t) -> t
1844: | CastE (t, _) -> t
1845: | AddrOf (lv) -> TPtr(typeOfLval lv, [])
1846: | StartOf (lv) -> begin
1847: match unrollType (typeOfLval lv) with
1848: TArray (t,_, _) -> TPtr(t, [])
1849: | _ -> E.s (E.bug "typeOf: StartOf on a non-array")
1850: end
1851:
1852: and typeOfInit (i: init) : typ =
1853: match i with
1854: SingleInit e -> typeOf e
1855: | CompoundInit (t, _) -> t
1856:
1857: and typeOfLval = function
1858: Var vi, off -> typeOffset vi.vtype off
1859: | Mem addr, off -> begin
1860: match unrollType (typeOf addr) with
1861: TPtr (t, _) -> typeOffset t off
1862: | _ -> E.s (bug "typeOfLval: Mem on a non-pointer")
1863: end
1864:
1865: and typeOffset basetyp = function
1866: NoOffset -> basetyp
1867: | Index (_, o) -> begin
1868: match unrollType basetyp with
1869: TArray (t, _, _) -> typeOffset t o
1870: | t -> E.s (E.bug "typeOffset: Index on a non-array")
1871: end
1872: | Field (fi, o) -> typeOffset fi.ftype o
1873:
1874:
1875: and d_binop () b =
1876: match b with
1877: PlusA | PlusPI | IndexPI -> text "+"
1878: | MinusA | MinusPP | MinusPI -> text "-"
1879: | Mult -> text "*"
1880: | Div -> text "/"
1881: | Mod -> text "%"
1882: | Shiftlt -> text "<<"
1883: | Shiftrt -> text ">>"
1884: | Lt -> text "<"
1885: | Gt -> text ">"
1886: | Le -> text "<="
1887: | Ge -> text ">="
1888: | Eq -> text "=="
1889: | Ne -> text "!="
1890: | BAnd -> text "&"
1891: | BXor -> text "^"
1892: | BOr -> text "|"
1893: | LAnd -> text "&&"
1894: | LOr -> text "||"
1895:
1896: let invalidStmt = mkStmt (Instr [])
1897:
1898: (** Construct a hash with the builtins *)
1899: let gccBuiltins : (string, typ * typ list * bool) H.t =
1900: let h = H.create 17 in
1901: (* See if we have builtin_va_list *)
1902: let hasbva = M.gccHas__builtin_va_list in
1903: (* When we parse builtin_next_arg we drop the second argument *)
1904: H.add h "__builtin_next_arg"
1905: ((if hasbva then TBuiltin_va_list [] else voidPtrType), [], false);
1906: H.add h "__builtin_constant_p" (intType, [ intType ], false);
1907: H.add h "__builtin_fabs" (doubleType, [ doubleType ], false);
1908: let longDouble = TFloat (FLongDouble, []) in
1909: H.add h "__builtin_fabsl" (longDouble, [ longDouble ], false);
1910: if hasbva then begin
1911: H.add h "__builtin_va_end" (voidType, [ TBuiltin_va_list [] ], false);
1912: H.add h "__builtin_varargs_start"
1913: (voidType, [ TBuiltin_va_list [] ], false);
1914: H.add h "__builtin_va_start" (voidType, [ TBuiltin_va_list [] ], false);
1915: (* When we parse builtin_stdarg_start, we drop the second argument *)
1916: H.add h "__builtin_stdarg_start" (voidType, [ TBuiltin_va_list []; ],
1917: false);
1918: (* When we parse builtin_va_arg we change its interface *)
1919: H.add h "__builtin_va_arg" (voidType, [ TBuiltin_va_list [];
1920: uintType; (* Sizeof the type *)
1921: voidPtrType; (* Ptr to res *) ],
1922: false);
1923: H.add h "__builtin_va_copy" (voidType, [ TBuiltin_va_list [];
1924: TBuiltin_va_list [] ],
1925: false);
1926: end;
1927: h
1928:
1929: (** Construct a hash with the builtins *)
1930: let msvcBuiltins : (string, typ * typ list * bool) H.t =
1931: (* These are empty for now but can be added to depending on the application*)
1932: let h = H.create 17 in
1933: (** Take a number of wide string literals *)
1934: H.add h "__annotation" (voidType, [ ], true);
1935: h
1936:
1937:
1938: (** A printer interface for CIL trees. Create instantiations of
1939: * this type by specializing the class {!Flx_cil_cil.defaultCilPrinter}. *)
1940: class type cilPrinter = object
1941: method pVDecl: unit -> varinfo -> doc
1942: (** Invoked for each variable declaration. Note that variable
1943: * declarations are all the [GVar], [GVarDecl], [GFun], all the [varinfo]
1944: * in formals of function types, and the formals and locals for function
1945: * definitions. *)
1946:
1947: method pVar: varinfo -> doc
1948: (** Invoked on each variable use. *)
1949:
1950: method pLval: unit -> lval -> doc
1951: (** Invoked on each lvalue occurence *)
1952:
1953: method pOffset: doc -> offset -> doc
1954: (** Invoked on each offset occurence. The second argument is the base. *)
1955:
1956: method pInstr: unit -> instr -> doc
1957: (** Invoked on each instruction occurrence. *)
1958:
1959: method pStmt: unit -> stmt -> doc
1960: (** Control-flow statement. This is used by
1961: * {!Flx_cil_cil.printGlobal} and by {!Flx_cil_cil.dumpGlobal}. *)
1962:
1963: method dStmt: out_channel -> int -> stmt -> unit
1964: (** Dump a control-flow statement to a file with a given indentation. This is used by
1965: * {!Flx_cil_cil.dumpGlobal}. *)
1966:
1967: method dBlock: out_channel -> int -> block -> unit
1968: (** Dump a control-flow block to a file with a given indentation. This is
1969: * used by {!Flx_cil_cil.dumpGlobal}. *)
1970:
1971: method pBlock: unit -> block -> Flx_cil_pretty.doc
1972: (** Print a block. *)
1973:
1974: method pGlobal: unit -> global -> doc
1975: (** Global (vars, types, etc.). This can be slow and is used only by
1976: * {!Flx_cil_cil.printGlobal} but by {!Flx_cil_cil.dumpGlobal} for everything else except
1977: * [GVar] and [GFun]. *)
1978:
1979: method dGlobal: out_channel -> global -> unit
1980: (** Dump a global to a file. This is used by {!Flx_cil_cil.dumpGlobal}. *)
1981:
1982: method pFieldDecl: unit -> fieldinfo -> doc
1983: (** A field declaration *)
1984:
1985: method pType: doc option -> unit -> typ -> doc
1986: (* Use of some type in some declaration. The first argument is used to print
1987: * the declared element, or is None if we are just printing a type with no
1988: * name being decalred. Note that for structure/union and enumeration types
1989: * the definition of the composite type is not visited. Use [vglob] to
1990: * visit it. *)
1991:
1992: method pAttr: attribute -> doc * bool
1993: (** Attribute. Also return an indication whether this attribute must be
1994: * printed inside the __attribute__ list or not. *)
1995:
1996: method pAttrParam: unit -> attrparam -> doc
1997: (** Attribute paramter *)
1998:
1999: method pAttrs: unit -> attributes -> doc
2000: (** Attribute lists *)
2001:
2002: method pLabel: unit -> label -> doc
2003: (** Label *)
2004:
2005: method pLineDirective: ?forcefile:bool -> location -> Flx_cil_pretty.doc
2006: (** Print a line-number. This is assumed to come always on an empty line.
2007: * If the forcefile argument is present and is true then the file name
2008: * will be printed always. Otherwise the file name is printed only if it
2009: * is different from the last time time this function is called. The last
2010: * file name is stored in a private field inside the cilPrinter object. *)
2011:
2012: method pStmtKind : stmt -> unit -> stmtkind -> Flx_cil_pretty.doc
2013: (** Print a statement kind. The code to be printed is given in the
2014: * {!Flx_cil_cil.stmtkind} argument. The initial {!Flx_cil_cil.stmt} argument
2015: * records the statement which follows the one being printed;
2016: * {!Flx_cil_cil.defaultCilPrinterClass} uses this information to prettify
2017: * statement printing in certain special cases. *)
2018:
2019: method pExp: unit -> exp -> doc
2020: (** Print expressions *)
2021:
2022: method pInit: unit -> init -> doc
2023: (** Print initializers. This can be slow and is used by
2024: * {!Flx_cil_cil.printGlobal} but not by {!Flx_cil_cil.dumpGlobal}. *)
2025:
2026: method dInit: out_channel -> int -> init -> unit
2027: (** Dump a global to a file with a given indentation. This is used by
2028: * {!Flx_cil_cil.dumpGlobal}. *)
2029: end
2030:
2031:
2032: class defaultCilPrinterClass : cilPrinter = object (self)
2033: val mutable currentFormals : varinfo list = []
2034: method private getLastNamedArgument (s: string) : exp =
2035: match List.rev currentFormals with
2036: f :: _ -> Lval (var f)
2037: | [] ->
2038: E.s (warn "Cannot find the last named argument when priting call to %s\n" s);
2039: zero
2040:
2041: (*** VARIABLES ***)
2042: (* variable use *)
2043: method pVar (v:varinfo) = text v.vname
2044:
2045: (* variable declaration *)
2046: method pVDecl () (v:varinfo) =
2047: let stom, rest = separateStorageModifiers v.vattr in
2048: (* First the storage modifiers *)
2049: text (if v.vinline then "__inline " else "")
2050: ++ d_storage () v.vstorage
2051: ++ (self#pAttrs () stom)
2052: ++ (self#pType (Some (text v.vname)) () v.vtype)
2053: ++ text " "
2054: ++ self#pAttrs () rest
2055:
2056: (*** L-VALUES ***)
2057: method pLval () (lv:lval) = (* lval (base is 1st field) *)
2058: match lv with
2059: Var vi, o -> self#pOffset (self#pVar vi) o
2060: | Mem e, Field(fi, o) ->
2061: self#pOffset
2062: ((self#pExpPrec arrowLevel () e) ++ text ("->" ^ fi.fname)) o
2063: | Mem e, o ->
2064: self#pOffset
2065: (text "(*" ++ self#pExpPrec derefStarLevel () e ++ text ")") o
2066:
2067: (** Offsets **)
2068: method pOffset (base: doc) = function
2069: | NoOffset -> base
2070: | Field (fi, o) ->
2071: self#pOffset (base ++ text "." ++ text fi.fname) o
2072: | Index (e, o) ->
2073: self#pOffset (base ++ text "[" ++ self#pExp () e ++ text "]") o
2074:
2075: method private pLvalPrec (contextprec: int) () lv =
2076: if getParenthLevel (Lval(lv)) >= contextprec then
2077: text "(" ++ self#pLval () lv ++ text ")"
2078: else
2079: self#pLval () lv
2080:
2081: (*** EXPRESSIONS ***)
2082: method pExp () (e: exp) : doc =
2083: let level = getParenthLevel e in
2084: match e with
2085: Const(c) -> d_const () c
2086: | Lval(l) -> self#pLval () l
2087: | UnOp(u,e1,_) ->
2088: let d_unop () u =
2089: match u with
2090: Neg -> text "-"
2091: | BNot -> text "~"
2092: | LNot -> text "!"
2093: in
2094: (d_unop () u) ++ chr ' ' ++ (self#pExpPrec level () e1)
2095:
2096: | BinOp(b,e1,e2,_) ->
2097: align
2098: ++ (self#pExpPrec level () e1)
2099: ++ chr ' '
2100: ++ (d_binop () b)
2101: ++ break
2102: ++ (self#pExpPrec level () e2)
2103: ++ unalign
2104:
2105: | CastE(t,e) ->
2106: text "("
2107: ++ self#pType None () t
2108: ++ text ")"
2109: ++ self#pExpPrec level () e
2110:
2111: | SizeOf (t) ->
2112: text "sizeof(" ++ self#pType None () t ++ chr ')'
2113: | SizeOfE (e) -> text "sizeof(" ++ self#pExp () e ++ chr ')'
2114:
2115: | SizeOfStr s ->
2116: text "sizeof(" ++ d_const () (CStr s) ++ chr ')'
2117:
2118: | AlignOf (t) ->
2119: text "__alignof__(" ++ self#pType None () t ++ chr ')'
2120: | AlignOfE (e) ->
2121: text "__alignof__(" ++ self#pExp () e ++ chr ')'
2122: | AddrOf(lv) ->
2123: text "& " ++ (self#pLvalPrec addrOfLevel () lv)
2124:
2125: | StartOf(lv) -> self#pLval () lv
2126:
2127: method private pExpPrec (contextprec: int) () (e: exp) =
2128: let thisLevel = getParenthLevel e in
2129: let needParens =
2130: if thisLevel >= contextprec then
2131: true
2132: else if contextprec == bitwiseLevel then
2133: (* quiet down some GCC warnings *)
2134: thisLevel == additiveLevel || thisLevel == comparativeLevel
2135: else
2136: false
2137: in
2138: if needParens then
2139: chr '(' ++ self#pExp () e ++ chr ')'
2140: else
2141: self#pExp () e
2142:
2143: method pInit () = function
2144: SingleInit e -> self#pExp () e
2145: | CompoundInit (t, initl) ->
2146: (* We do not print the type of the Compound *)
2147: (*
2148: let dinit e = d_init () e in
2149: dprintf "{@[%a@]}"
2150: (docList (chr ',' ++ break) dinit) initl
2151: *)
2152: let printDesignator =
2153: if not !msvcMode then begin
2154: (* Print only for union when we do not initialize the first field *)
2155: match unrollType t, initl with
2156: TComp(ci, _), [(Field(f, NoOffset), _)] ->
2157: if not (ci.cstruct) && ci.cfields != [] &&
2158: (List.hd ci.cfields).fname = f.fname then
2159: true
2160: else
2161: false
2162: | _ -> false
2163: end else
2164: false
2165: in
2166: let d_oneInit = function
2167: Field(f, NoOffset), i ->
2168: (if printDesignator then
2169: text ("." ^ f.fname ^ " = ")
2170: else nil) ++ self#pInit () i
2171: | Index(e, NoOffset), i ->
2172: (if printDesignator then
2173: text "[" ++ self#pExp () e ++ text "] = " else nil) ++
2174: self#pInit () i
2175: | _ -> E.s (unimp "Trying to print malformed initializer")
2176: in
2177: chr '{' ++ (align
2178: ++ ((docList (chr ',' ++ break) d_oneInit) () initl)
2179: ++ unalign)
2180: ++ chr '}'
2181: (*
2182: | ArrayInit (_, _, il) ->
2183: chr '{' ++ (align
2184: ++ ((docList (chr ',' ++ break) (self#pInit ())) () il)
2185: ++ unalign)
2186: ++ chr '}'
2187: *)
2188: (* dump initializers to a file. *)
2189: method dInit (out: out_channel) (ind: int) (i: init) =
2190: (* Dump an array *)
2191: let dumpArray (bt: typ) (il: 'a list) (getelem: 'a -> init) =
2192: let onALine = (* How many elements on a line *)
2193: match unrollType bt with TComp _ | TArray _ -> 1 | _ -> 4
2194: in
2195: let rec outputElements (isfirst: bool) (room_on_line: int) = function
2196: [] -> output_string out "}"
2197: | (i: 'a) :: rest ->
2198: if not isfirst then output_string out ", ";
2199: let new_room_on_line =
2200: if room_on_line == 0 then begin
2201: output_string out "\n"; output_string out (String.make ind ' ');
2202: onALine - 1
2203: end else
2204: room_on_line - 1
2205: in
2206: self#dInit out (ind + 2) (getelem i);
2207: outputElements false new_room_on_line rest
2208: in
2209: output_string out "{ ";
2210: outputElements true onALine il
2211: in
2212: match i with
2213: SingleInit e ->
2214: fprint out 80 (indent ind (self#pExp () e))
2215: | CompoundInit (t, initl) -> begin
2216: match unrollType t with
2217: TArray(bt, _, _) ->
2218: dumpArray bt initl (fun (_, i) -> i)
2219: | _ ->
2220: (* Now a structure or a union *)
2221: fprint out 80 (indent ind (self#pInit () i))
2222: end
2223: (*
2224: | ArrayInit (bt, len, initl) -> begin
2225: (* If the base type does not contain structs then use the pInit
2226: match unrollType bt with
2227: TComp _ | TArray _ ->
2228: dumpArray bt initl (fun x -> x)
2229: | _ -> *)
2230: fprint out 80 (indent ind (self#pInit () i))
2231: end
2232: *)
2233:
2234: (** What terminator to print after an instruction. sometimes we want to
2235: * print sequences of instructions separated by comma *)
2236: val mutable printInstrTerminator = ";"
2237:
2238: (*** INSTRUCTIONS ****)
2239: method pInstr () (i:instr) = (* imperative instruction *)
2240: match i with
2241: | Set(lv,e,l) -> begin
2242: (* Be nice to some special cases *)
2243: match e with
2244: BinOp((PlusA|PlusPI|IndexPI),Lval(lv'),Const(CInt64(one,_,_)),_)
2245: when lv == lv' && one = Int64.one && not !printCilAsIs ->
2246: self#pLineDirective l
2247: ++ self#pLval () lv
2248: ++ text (" ++" ^ printInstrTerminator)
2249:
2250: | BinOp((MinusA|MinusPI),Lval(lv'),
2251: Const(CInt64(one,_,_)), _)
2252: when lv == lv' && one = Int64.one && not !printCilAsIs ->
2253: self#pLineDirective l
2254: ++ self#pLval () lv
2255: ++ text (" --" ^ printInstrTerminator)
2256:
2257: | BinOp((PlusA|PlusPI|IndexPI),Lval(lv'),Const(CInt64(mone,_,_)),_)
2258: when lv == lv' && mone = Int64.minus_one && not !printCilAsIs ->
2259: self#pLineDirective l
2260: ++ self#pLval () lv
2261: ++ text (" --" ^ printInstrTerminator)
2262:
2263: | BinOp((PlusA|PlusPI|IndexPI|MinusA|MinusPP|MinusPI|BAnd|BOr|BXor|
2264: Mult|Div|Mod|Shiftlt|Shiftrt) as bop,
2265: Lval(lv'),e,_) when lv == lv' ->
2266: self#pLineDirective l
2267: ++ self#pLval () lv
2268: ++ text " " ++ d_binop () bop
2269: ++ text "= "
2270: ++ self#pExp () e
2271: ++ text printInstrTerminator
2272:
2273: | _ ->
2274: self#pLineDirective l
2275: ++ self#pLval () lv
2276: ++ text " = "
2277: ++ self#pExp () e
2278: ++ text printInstrTerminator
2279:
2280: end
2281: (* In cabs2cil we have turned the call to builtin_va_arg into a
2282: * three-argument call: the last argument is the address of the
2283: * destination *)
2284: | Call(None, Lval(Var vi, NoOffset), [dest; SizeOf t; adest], l)
2285: when vi.vname = "__builtin_va_arg" && not !printCilAsIs ->
2286: let rec stripCast = function
2287: CastE (_, e) -> stripCast e
2288: | e -> e in
2289: let destlv = match stripCast adest with
2290: AddrOf destlv -> destlv
2291: | _ -> E.s (E.error "Encountered unexpected call to %s\n" vi.vname)
2292: in
2293: self#pLineDirective l
2294: ++ self#pLval () destlv ++ text " = "
2295:
2296: (* Now the function name *)
2297: ++ text "__builtin_va_arg"
2298: ++ text "(" ++ (align
2299: (* Now the arguments *)
2300: ++ self#pExp () dest
2301: ++ chr ',' ++ break
2302: ++ self#pType None () t
2303: ++ unalign)
2304: ++ text (")" ^ printInstrTerminator)
2305:
2306: (* In cabs2cil we have dropped the last argument in the call to
2307: * __builtin_stdarg_start. *)
2308: | Call(None, Lval(Var vi, NoOffset), [marker], l)
2309: when vi.vname = "__builtin_stdarg_start" && not !printCilAsIs -> begin
2310: let last = self#getLastNamedArgument vi.vname in
2311: self#pInstr () (Call(None,Lval(Var vi,NoOffset),[marker; last],l))
2312: end
2313:
2314: (* In cabs2cil we have dropped the last argument in the call to
2315: * __builtin_next_arg. *)
2316: | Call(res, Lval(Var vi, NoOffset), [ ], l)
2317: when vi.vname = "__builtin_next_arg" && not !printCilAsIs -> begin
2318: let last = self#getLastNamedArgument vi.vname in
2319: self#pInstr () (Call(res,Lval(Var vi,NoOffset),[last],l))
2320: end
2321:
2322: | Call(dest,e,args,l) ->
2323: self#pLineDirective l
2324: ++ (match dest with
2325: None -> nil
2326: | Some lv ->
2327: self#pLval () lv ++ text " = " ++
2328: (* Maybe we need to print a cast *)
2329: (let destt = typeOfLval lv in
2330: match unrollType (typeOf e) with
2331: TFun (rt, _, _, _) when typeSig rt <> typeSig destt ->
2332: text "(" ++ self#pType None () destt ++ text ")"
2333: | _ -> nil))
2334: (* Now the function name *)
2335: ++ (let ed = self#pExp () e in
2336: match e with
2337: Lval(Var _, _) -> ed
2338: | _ -> text "(" ++ ed ++ text ")")
2339: ++ text "(" ++
2340: (align
2341: (* Now the arguments *)
2342: ++ (docList (chr ',' ++ break)
2343: (self#pExp ()) () args)
2344: ++ unalign)
2345: ++ text (")" ^ printInstrTerminator)
2346:
2347: | Asm(attrs, tmpls, outs, ins, clobs, l) ->
2348: if !msvcMode then
2349: self#pLineDirective l
2350: ++ text "__asm {"
2351: ++ (align
2352: ++ (docList line text () tmpls)
2353: ++ unalign)
2354: ++ text ("}" ^ printInstrTerminator)
2355: else
2356: self#pLineDirective l
2357: ++ text ("__asm__ ")
2358: ++ self#pAttrs () attrs
2359: ++ text " ("
2360: ++ (align
2361: ++ (docList line
2362: (fun x -> text ("\"" ^ escape_string x ^ "\""))
2363: () tmpls)
2364: ++
2365: (if outs = [] && ins = [] && clobs = [] then
2366: nil
2367: else
2368: (text ": "
2369: ++ (docList (chr ',' ++ break)
2370: (fun (c, lv) ->
2371: text ("\"" ^ escape_string c ^ "\" (")
2372: ++ self#pLval () lv
2373: ++ text ")") () outs)))
2374: ++
2375: (if ins = [] && clobs = [] then
2376: nil
2377: else
2378: (text ": "
2379: ++ (docList (chr ',' ++ break)
2380: (fun (c, e) ->
2381: text ("\"" ^ escape_string c ^ "\" (")
2382: ++ self#pExp () e
2383: ++ text ")") () ins)))
2384: ++
2385: (if clobs = [] then nil
2386: else
2387: (text ": "
2388: ++ (docList (chr ',' ++ break)
2389: (fun c -> text ("\"" ^ escape_string c ^ "\""))
2390: ()
2391: clobs)))
2392: ++ unalign)
2393: ++ text (")" ^ printInstrTerminator)
2394:
2395:
2396: (**** STATEMENTS ****)
2397: method pStmt () (s:stmt) = (* control-flow statement *)
2398: self#pStmtNext invalidStmt () s
2399:
2400: method dStmt (out: out_channel) (ind: int) (s:stmt) : unit =
2401: fprint out 80 (indent ind (self#pStmt () s))
2402:
2403: method dBlock (out: out_channel) (ind: int) (b:block) : unit =
2404: fprint out 80 (indent ind (self#pBlock () b))
2405:
2406: method private pStmtNext (next: stmt) () (s: stmt) =
2407: (* print the labels *)
2408: ((docList line (fun l -> self#pLabel () l)) () s.labels)
2409: (* print the statement itself. If the labels are non-empty and the
2410: * statement is empty, print a semicolon *)
2411: ++
2412: (if s.skind = Instr [] && s.labels <> [] then
2413: text ";"
2414: else
2415: (if s.labels <> [] then line else nil)
2416: ++ self#pStmtKind next () s.skind)
2417:
2418: method private pLabel () = function
2419: Label (s, _, true) -> text (s ^ ": ")
2420: | Label (s, _, false) -> text (s ^ ": /* CIL Label */ ")
2421: | Case (e, _) -> text "case " ++ self#pExp () e ++ text ": "
2422: | Default _ -> text "default: "
2423:
2424: (* The pBlock will put the unalign itself *)
2425: method pBlock () (blk: block) =
2426: let rec dofirst () = function
2427: [] -> nil
2428: | [x] -> self#pStmtNext invalidStmt () x
2429: | x :: rest -> dorest nil x rest
2430: and dorest acc prev = function
2431: [] -> acc ++ (self#pStmtNext invalidStmt () prev)
2432: | x :: rest ->
2433: dorest (acc ++ (self#pStmtNext x () prev) ++ line)
2434: x rest
2435: in
2436: (* Let the host of the block decide on the alignment. The d_block will
2437: * pop the alignment as well *)
2438: text "{"
2439: ++
2440: (if blk.battrs <> [] then
2441: self#pAttrsGen true blk.battrs
2442: else nil)
2443: ++ line
2444: ++ (dofirst () blk.bstmts)
2445: ++ unalign ++ line ++ text "}"
2446:
2447:
2448: (* Store here the name of the last file printed in a line number. This is
2449: * private to the object *)
2450: val mutable lastFileName = ""
2451: (* Make sure that you only call self#pLineDirective on an empty line *)
2452: method pLineDirective ?(forcefile=false) l =
2453: currentLoc := l;
2454: match !lineDirectiveStyle with
2455: | Some style when l.line > 0 ->
2456: let directive =
2457: match style with
2458: | LineComment -> text "//#line "
2459: | LinePreprocessorOutput when not !msvcMode -> chr '#'
2460: | _ -> text "#line"
2461: in
2462: let filename =
2463: if forcefile || l.file <> lastFileName then
2464: begin
2465: lastFileName <- l.file;
2466: text " \"" ++ text l.file ++ text "\""
2467: end
2468: else
2469: nil
2470: in
2471: leftflush ++ directive ++ chr ' ' ++ num l.line ++ filename ++ line
2472: | _ ->
2473: nil
2474:
2475:
2476: method private pStmtKind (next: stmt) () = function
2477: Return(None, l) ->
2478: self#pLineDirective l
2479: ++ text "return;"
2480:
2481: | Return(Some e, l) ->
2482: self#pLineDirective l
2483: ++ text "return ("
2484: ++ self#pExp () e
2485: ++ text ");"
2486:
2487: | Goto (sref, l) -> begin
2488: (* Grab one of the labels *)
2489: let rec pickLabel = function
2490: [] -> None
2491: | Label (l, _, _) :: _ -> Some l
2492: | _ :: rest -> pickLabel rest
2493: in
2494: match pickLabel !sref.labels with
2495: Some l -> text ("goto " ^ l ^ ";")
2496: | None ->
2497: ignore (error "Cannot find label for target of goto\n");
2498: text "goto __invalid_label;"
2499: end
2500:
2501: | Break l ->
2502: self#pLineDirective l
2503: ++ text "break;"
2504:
2505: | Continue l ->
2506: self#pLineDirective l
2507: ++ text "continue;"
2508:
2509: | Instr il ->
2510: align
2511: ++ (docList line (fun i -> self#pInstr () i) () il)
2512: ++ unalign
2513:
2514: | If(be,t,{bstmts=[];battrs=[]},l) when not !printCilAsIs ->
2515: self#pLineDirective l
2516: ++ text "if"
2517: ++ (align
2518: ++ text " ("
2519: ++ self#pExp () be
2520: ++ text ") "
2521: ++ self#pBlock () t)
2522:
2523: | If(be,t,{bstmts=[{skind=Goto(gref,_);labels=[]} as s];
2524: battrs=[]},l)
2525: when !gref == next && not !printCilAsIs ->
2526: self#pLineDirective l
2527: ++ text "if"
2528: ++ (align
2529: ++ text " ("
2530: ++ self#pExp () be
2531: ++ text ") "
2532: ++ self#pBlock () t)
2533:
2534: | If(be,{bstmts=[];battrs=[]},e,l) when not !printCilAsIs ->
2535: self#pLineDirective l
2536: ++ text "if"
2537: ++ (align
2538: ++ text " ("
2539: ++ self#pExp () (UnOp(LNot,be,intType))
2540: ++ text ") "
2541: ++ self#pBlock () e)
2542:
2543: | If(be,{bstmts=[{skind=Goto(gref,_);labels=[]} as s];
2544: battrs=[]},e,l)
2545: when !gref == next && not !printCilAsIs ->
2546: self#pLineDirective l
2547: ++ text "if"
2548: ++ (align
2549: ++ text " ("
2550: ++ self#pExp () (UnOp(LNot,be,intType))
2551: ++ text ") "
2552: ++ self#pBlock () e)
2553:
2554: | If(be,t,e,l) ->
2555: self#pLineDirective l
2556: ++ (align
2557: ++ text "if"
2558: ++ (align
2559: ++ text " ("
2560: ++ self#pExp () be
2561: ++ text ") "
2562: ++ self#pBlock () t)
2563: ++ text " " (* sm: indent next code 2 spaces (was 4) *)
2564: ++ (align
2565: ++ text "else "
2566: ++ self#pBlock () e)
2567: ++ unalign)
2568:
2569: | Switch(e,b,_,l) ->
2570: self#pLineDirective l
2571: ++ (align
2572: ++ text "switch ("
2573: ++ self#pExp () e
2574: ++ text ") "
2575: ++ self#pBlock () b)
2576: | Loop(b, l, _, _) -> begin
2577: (* Maybe the first thing is a conditional. Turn it into a WHILE *)
2578: try
2579: let term, bodystmts =
2580: let rec skipEmpty = function
2581: [] -> []
2582: | {skind=Instr [];labels=[]} :: rest -> skipEmpty rest
2583: | x -> x
2584: in
2585: (* Bill McCloskey: Do not remove the If if it has labels *)
2586: match skipEmpty b.bstmts with
2587: {skind=If(e,tb,fb,_); labels=[]} :: rest
2588: when not !printCilAsIs -> begin
2589: match skipEmpty tb.bstmts, skipEmpty fb.bstmts with
2590: [], {skind=Break _; labels=[]} :: _ -> e, rest
2591: | {skind=Break _; labels=[]} :: _, []
2592: -> UnOp(LNot, e, intType), rest
2593: | _ -> raise Not_found
2594: end
2595: | _ -> raise Not_found
2596: in
2597: self#pLineDirective l
2598: ++ text "wh"
2599: ++ (align
2600: ++ text "ile ("
2601: ++ self#pExp () term
2602: ++ text ") "
2603: ++ self#pBlock () {bstmts=bodystmts; battrs=b.battrs})
2604:
2605: with Not_found ->
2606: self#pLineDirective l
2607: ++ text "wh"
2608: ++ (align
2609: ++ text "ile (1) "
2610: ++ self#pBlock () b)
2611: end
2612: | Block b -> align ++ self#pBlock () b
2613:
2614: | TryFinally (b, h, l) ->
2615: self#pLineDirective l
2616: ++ text "__try "
2617: ++ align
2618: ++ self#pBlock () b
2619: ++ text " __fin" ++ align ++ text "ally "
2620: ++ self#pBlock () h
2621:
2622: | TryExcept (b, (il, e), h, l) ->
2623: self#pLineDirective l
2624: ++ text "__try "
2625: ++ align
2626: ++ self#pBlock () b
2627: ++ text " __e" ++ align ++ text "xcept(" ++ line
2628: ++ align
2629: (* Print the instructions but with a comma at the end, instead of
2630: * semicolon *)
2631: ++ (printInstrTerminator <- ",";
2632: let res =
2633: (docList line (self#pInstr ())
2634: () il)
2635: in
2636: printInstrTerminator <- ";";
2637: res)
2638: ++ self#pExp () e
2639: ++ text ") " ++ unalign
2640: ++ self#pBlock () h
2641:
2642:
2643: (*** GLOBALS ***)
2644: method pGlobal () (g:global) : doc = (* global (vars, types, etc.) *)
2645: match g with
2646: | GFun (fundec, l) ->
2647: (* If the function has attributes then print a prototype because
2648: * GCC cannot accept function attributes in a definition *)
2649: let oldattr = fundec.svar.vattr in
2650: (* Always pring the file name before function declarations *)
2651: let proto =
2652: if oldattr <> [] then
2653: (self#pLineDirective l) ++ (self#pVDecl () fundec.svar)
2654: ++ chr ';' ++ line
2655: else nil in
2656: (* Temporarily remove the function attributes *)
2657: fundec.svar.vattr <- [];
2658: let body = (self#pLineDirective ~forcefile:true l)
2659: ++ (self#pFunDecl () fundec) in
2660: fundec.svar.vattr <- oldattr;
2661: proto ++ body ++ line
2662:
2663: | GType (typ, l) ->
2664: self#pLineDirective ~forcefile:true l ++
2665: text "typedef "
2666: ++ (self#pType (Some (text typ.tname)) () typ.ttype)
2667: ++ text ";\n"
2668:
2669: | GEnumTag (enum, l) ->
2670: self#pLineDirective l ++
2671: text "enum" ++ align ++ text (" " ^ enum.ename) ++
2672: self#pAttrs () enum.eattr ++ text " {" ++ line
2673: ++ (docList (chr ',' ++ line)
2674: (fun (n,i, loc) ->
2675: text (n ^ " = ")
2676: ++ self#pExp () i)
2677: () enum.eitems)
2678: ++ unalign ++ line ++ text "};\n"
2679:
2680: | GEnumTagDecl (enum, l) -> (* This is a declaration of a tag *)
2681: self#pLineDirective l ++
2682: text ("enum " ^ enum.ename ^ ";\n")
2683:
2684: | GCompTag (comp, l) -> (* This is a definition of a tag *)
2685: let n = comp.cname in
2686: let su, su1, su2 =
2687: if comp.cstruct then "struct", "str", "uct"
2688: else "union", "uni", "on"
2689: in
2690: let sto_mod, rest_attr = separateStorageModifiers comp.cattr in
2691: self#pLineDirective ~forcefile:true l ++
2692: text su1 ++ (align ++ text su2 ++ chr ' ' ++ (self#pAttrs () sto_mod)
2693: ++ text n
2694: ++ text " {" ++ line
2695: ++ ((docList line (self#pFieldDecl ())) ()
2696: comp.cfields)
2697: ++ unalign)
2698: ++ line ++ text "}" ++
2699: (self#pAttrs () rest_attr) ++ text ";\n"
2700:
2701: | GCompTagDecl (comp, l) -> (* This is a declaration of a tag *)
2702: self#pLineDirective l ++
2703: text (compFullName comp) ++ text ";\n"
2704:
2705: | GVar (vi, io, l) ->
2706: self#pLineDirective ~forcefile:true l ++
2707: self#pVDecl () vi
2708: ++ chr ' '
2709: ++ (match io.init with
2710: None -> nil
2711: | Some i -> text " = " ++
2712: (let islong =
2713: match i with
2714: CompoundInit (_, il) when List.length il >= 8 -> true
2715: | _ -> false
2716: in
2717: if islong then
2718: line ++ self#pLineDirective l ++ text " "
2719: else nil) ++
2720: (self#pInit () i))
2721: ++ text ";\n"
2722:
2723: (* print global variable 'extern' declarations, and function prototypes *)
2724: | GVarDecl (vi, l) ->
2725: self#pLineDirective l ++
2726: (self#pVDecl () vi)
2727: ++ text ";\n"
2728:
2729: | GAsm (s, l) ->
2730: self#pLineDirective l ++
2731: text ("__asm__(\"" ^ escape_string s ^ "\");\n")
2732:
2733: | GPragma (Attr(an, args), l) ->
2734: (* sm: suppress printing pragmas that gcc does not understand *)
2735: (* assume anything starting with "ccured" is ours *)
2736: (* also don't print the 'combiner' pragma *)
2737: (* nor 'cilnoremove' *)
2738: let suppress =
2739: not !print_CIL_Input &&
2740: not !msvcMode &&
2741: ((startsWith "box" an) ||
2742: (startsWith "ccured" an) ||
2743: (an = "merger") ||
2744: (an = "cilnoremove")) in
2745: let d =
2746: match an, args with
2747: | _, [] ->
2748: text an
2749: | "weak", [ACons (symbol, [])] ->
2750: text "weak " ++ text symbol
2751: | _ ->
2752: text (an ^ "(")
2753: ++ docList (chr ',') (self#pAttrParam ()) () args
2754: ++ text ")"
2755: in
2756: self#pLineDirective l
2757: ++ (if suppress then text "/* " else text "")
2758: ++ (text "#pragma ")
2759: ++ d
2760: ++ (if suppress then text " */\n" else text "\n")
2761:
2762: | GText s ->
2763: if s <> "//" then
2764: text s ++ text "\n"
2765: else
2766: nil
2767:
2768:
2769: method dGlobal (out: out_channel) (g: global) : unit =
2770: (* For all except functions and variable with initializers, use the
2771: * pGlobal *)
2772: match g with
2773: GFun (fdec, l) ->
2774: (* If the function has attributes then print a prototype because
2775: * GCC cannot accept function attributes in a definition *)
2776: let oldattr = fdec.svar.vattr in
2777: let proto =
2778: if oldattr <> [] then
2779: (self#pLineDirective l) ++ (self#pVDecl () fdec.svar)
2780: ++ chr ';' ++ line
2781: else nil in
2782: fprint out 80 (proto ++ (self#pLineDirective ~forcefile:true l));
2783: (* Temporarily remove the function attributes *)
2784: fdec.svar.vattr <- [];
2785: fprint out 80 (self#pFunDecl () fdec);
2786: fdec.svar.vattr <- oldattr;
2787: output_string out "\n"
2788:
2789: | GVar (vi, {init = Some i}, l) -> begin
2790: fprint out 80
2791: (self#pLineDirective ~forcefile:true l ++
2792: self#pVDecl () vi
2793: ++ text " = "
2794: ++ (let islong =
2795: match i with
2796: CompoundInit (_, il) when List.length il >= 8 -> true
2797: | _ -> false
2798: in
2799: if islong then
2800: line ++ self#pLineDirective l ++ text " "
2801: else nil));
2802: self#dInit out 3 i;
2803: output_string out ";\n"
2804: end
2805:
2806: | g -> fprint out 80 (self#pGlobal () g)
2807:
2808: method pFieldDecl () fi =
2809: (self#pType
2810: (Some (text (if fi.fname = missingFieldName then "" else fi.fname)))
2811: ()
2812: fi.ftype)
2813: ++ text " "
2814: ++ (match fi.fbitfield with None -> nil
2815: | Some i -> text ": " ++ num i ++ text " ")
2816: ++ self#pAttrs () fi.fattr
2817: ++ text ";"
2818:
2819: method private pFunDecl () f =
2820: self#pVDecl () f.svar
2821: ++ line
2822: ++ text "{ "
2823: ++ (align
2824: (* locals. *)
2825: ++ (docList line (fun vi -> self#pVDecl () vi ++ text ";")
2826: () f.slocals)
2827: ++ line ++ line
2828: (* the body *)
2829: ++ ((* remember the declaration *) currentFormals <- f.sformals;
2830: let body = self#pBlock () f.sbody in
2831: currentFormals <- [];
2832: body))
2833: ++ line
2834: ++ text "}"
2835:
2836: (***** PRINTING DECLARATIONS and TYPES ****)
2837:
2838: method pType (nameOpt: doc option) (* Whether we are declaring a name or
2839: * we are just printing a type *)
2840: () (t:typ) = (* use of some type *)
2841: let name = match nameOpt with None -> nil | Some d -> d in
2842: let printAttributes (a: attributes) =
2843: let pa = self#pAttrs () a in
2844: match nameOpt with
2845: | None when not !print_CIL_Input && not !msvcMode ->
2846: (* Cannot print the attributes in this case because gcc does not
2847: * like them here, except if we are printing for CIL, or for MSVC.
2848: * In fact, for MSVC we MUST print attributes such as __stdcall *)
2849: if pa = nil then nil else
2850: text "/*" ++ pa ++ text "*/"
2851: | _ -> pa
2852: in
2853: match t with
2854: TVoid a ->
2855: text "void"
2856: ++ self#pAttrs () a
2857: ++ text " "
2858: ++ name
2859:
2860: | TInt (ikind,a) ->
2861: d_ikind () ikind
2862: ++ self#pAttrs () a
2863: ++ text " "
2864: ++ name
2865:
2866: | TFloat(fkind, a) ->
2867: d_fkind () fkind
2868: ++ self#pAttrs () a
2869: ++ text " "
2870: ++ name
2871:
2872: | TComp (comp, a) -> (* A reference to a struct *)
2873: let su = if comp.cstruct then "struct" else "union" in
2874: text (su ^ " " ^ comp.cname ^ " ")
2875: ++ self#pAttrs () a
2876: ++ name
2877:
2878: | TEnum (enum, a) ->
2879: text ("enum " ^ enum.ename ^ " ")
2880: ++ self#pAttrs () a
2881: ++ name
2882: | TPtr (bt, a) ->
2883: (* Parenthesize the ( * attr name) if a pointer to a function or an
2884: * array. However, on MSVC the __stdcall modifier must appear right
2885: * before the pointer constructor "(__stdcall *f)". We push them into
2886: * the parenthesis. *)
2887: let (paren: doc option), (bt': typ) =
2888: match bt with
2889: TFun(rt, args, isva, fa) when !msvcMode ->
2890: let an, af', at = partitionAttributes ~default:AttrType fa in
2891: (* We take the af' and we put them into the parentheses *)
2892: Some (text "(" ++ printAttributes af'),
2893: TFun(rt, args, isva, addAttributes an at)
2894:
2895: | TFun _ | TArray _ -> Some (text "("), bt
2896:
2897: | _ -> None, bt
2898: in
2899: let name' = text "*" ++ printAttributes a ++ name in
2900: let name'' = (* Put the parenthesis *)
2901: match paren with
2902: Some p -> p ++ name' ++ text ")"
2903: | _ -> name'
2904: in
2905: self#pType
2906: (Some name'')
2907: ()
2908: bt'
2909:
2910: | TArray (elemt, lo, a) ->
2911: let name' =
2912: if a == [] then name else
2913: if nameOpt == None then printAttributes a else
2914: text "(" ++ printAttributes a ++ name ++ text ")"
2915: in
2916: self#pType
2917: (Some (name'
2918: ++ text "["
2919: ++ (match lo with None -> nil | Some e -> self#pExp () e)
2920: ++ text "]"))
2921: ()
2922: elemt
2923:
2924: | TFun (restyp, args, isvararg, a) ->
2925: let name' =
2926: if a == [] then name else
2927: if nameOpt == None then printAttributes a else
2928: text "(" ++ printAttributes a ++ name ++ text ")"
2929: in
2930: self#pType
2931: (Some
2932: (name'
2933: ++ text "("
2934: ++ (align
2935: ++
2936: (if args = Some [] && isvararg then
2937: text "..."
2938: else
2939: (if args = None then nil
2940: else if args = Some [] then text "void"
2941: else
2942: let pArg (aname, atype, aattr) =
2943: let stom, rest = separateStorageModifiers aattr in
2944: (* First the storage modifiers *)
2945: (self#pAttrs () stom)
2946: ++ (self#pType (Some (text aname)) () atype)
2947: ++ text " "
2948: ++ self#pAttrs () rest
2949: in
2950: (docList (chr ',' ++ break) pArg) ()
2951: (argsToList args))
2952: ++ (if isvararg then break ++ text ", ..." else nil))
2953: ++ unalign)
2954: ++ text ")"))
2955: ()
2956: restyp
2957:
2958: | TNamed (t, a) ->
2959: text t.tname ++ self#pAttrs () a ++ text " " ++ name
2960:
2961: | TBuiltin_va_list a ->
2962: text "__builtin_va_list"
2963: ++ self#pAttrs () a
2964: ++ text " "
2965: ++ name
2966:
2967:
2968: (**** PRINTING ATTRIBUTES *********)
2969: method pAttrs () (a: attributes) =
2970: self#pAttrsGen false a
2971:
2972:
2973: (* Print one attribute. Return also an indication whether this attribute
2974: * should be printed inside the __attribute__ list *)
2975: method pAttr (Attr(an, args): attribute) : doc * bool =
2976: (* Recognize and take care of some known cases *)
2977: match an, args with
2978: "const", [] -> text "const", false
2979: (* Put the aconst inside the attribute list *)
2980: | "aconst", [] when not !msvcMode -> text "__const__", true
2981: | "thread", [] when not !msvcMode -> text "__thread", false
2982: | "volatile", [] -> text "volatile", false
2983: | "restrict", [] -> text "__restrict", false
2984: | "missingproto", [] -> text "/* missing proto */", false
2985: | "cdecl", [] when !msvcMode -> text "__cdecl", false
2986: | "stdcall", [] when !msvcMode -> text "__stdcall", false
2987: | "fastcall", [] when !msvcMode -> text "__fastcall", false
2988: | "declspec", args when !msvcMode ->
2989: text "__declspec("
2990: ++ docList (chr ',') (self#pAttrParam ()) () args
2991: ++ text ")", false
2992: | "w64", [] when !msvcMode -> text "__w64", false
2993: | "asm", args ->
2994: text "__asm__("
2995: ++ docList (chr ',') (self#pAttrParam ()) () args
2996: ++ text ")", false
2997: (* we suppress printing mode(__si__) because it triggers an *)
2998: (* internal compiler error in all current gcc versions *)
2999: (* sm: I've now encountered a problem with mode(__hi__)... *)
3000: (* I don't know what's going on, but let's try disabling all "mode"..*)
3001: | "mode", [ACons(tag,[])] ->
3002: text "/* mode(" ++ text tag ++ text ") */", false
3003:
3004: (* sm: also suppress "format" because we seem to print it in *)
3005: (* a way gcc does not like *)
3006: | "format", _ -> text "/* format attribute */", false
3007:
3008: (* sm: here's another one I don't want to see gcc warnings about.. *)
3009: | "mayPointToStack", _ when not !print_CIL_Input
3010: (* [matth: may be inside another comment.]
3011: -> text "/*mayPointToStack*/", false
3012: *)
3013: -> text "", false
3014:
3015: | _ -> (* This is the dafault case *)
3016: (* Add underscores to the name *)
3017: let an' = if !msvcMode then "__" ^ an else "__" ^ an ^ "__" in
3018: if args = [] then
3019: text an', true
3020: else
3021: text (an' ^ "(")
3022: ++ (docList (chr ',') (self#pAttrParam ()) () args)
3023: ++ text ")",
3024: true
3025:
3026: method pAttrParam () = function
3027: | AInt n -> num n
3028: | AStr s -> text ("\"" ^ escape_string s ^ "\"")
3029: | ACons(s, []) -> text s
3030: | ACons(s,al) ->
3031: text (s ^ "(")
3032: ++ (docList (chr ',') (self#pAttrParam ()) () al)
3033: ++ text ")"
3034: | ASizeOfE a -> text "sizeof(" ++ self#pAttrParam () a ++ text ")"
3035: | ASizeOf t -> text "sizeof(" ++ self#pType None () t ++ text ")"
3036: | AAlignOfE a -> text "__alignof__(" ++ self#pAttrParam () a ++ text ")"
3037: | AAlignOf t -> text "__alignof__(" ++ self#pType None () t ++ text ")"
3038: | AUnOp(u,a1) ->
3039: let d_unop () u =
3040: match u with
3041: Neg -> text "-"
3042: | BNot -> text "~"
3043: | LNot -> text "!"
3044: in
3045: (d_unop () u) ++ text " (" ++ (self#pAttrParam () a1) ++ text ")"
3046:
3047: | ABinOp(b,a1,a2) ->
3048: align
3049: ++ text "("
3050: ++ (self#pAttrParam () a1)
3051: ++ text ") "
3052: ++ (d_binop () b)
3053: ++ break
3054: ++ text " (" ++ (self#pAttrParam () a2) ++ text ") "
3055: ++ unalign
3056: | ADot (ap, s) -> (self#pAttrParam () ap) ++ text ("." ^ s)
3057:
3058: (* A general way of printing lists of attributes *)
3059: method private pAttrsGen (block: bool) (a: attributes) =
3060: (* Scan all the attributes and separate those that must be printed inside
3061: * the __attribute__ list *)
3062: let rec loop (in__attr__: doc list) = function
3063: [] -> begin
3064: match in__attr__ with
3065: [] -> nil
3066: | _ :: _->
3067: (* sm: added 'forgcc' calls to not comment things out
3068: * if CIL is the consumer; this is to address a case
3069: * Daniel ran into where blockattribute(nobox) was being
3070: * dropped by the merger
3071: *)
3072: (if block then
3073: text (" " ^ (forgcc "/*") ^ " __blockattribute__(")
3074: else
3075: text "__attribute__((")
3076:
3077: ++ (docList (chr ',' ++ break)
3078: (fun a -> a)) () in__attr__
3079: ++ text ")"
3080: ++ (if block then text (forgcc "*/") else text ")")
3081: end
3082: | x :: rest ->
3083: let dx, ina = self#pAttr x in
3084: if ina then
3085: loop (dx :: in__attr__) rest
3086: else
3087: dx ++ text " " ++ loop in__attr__ rest
3088: in
3089: let res = loop [] a in
3090: if res = nil then
3091: res
3092: else
3093: text " " ++ res ++ text " "
3094:
3095: end (* class defaultCilPrinterClass *)
3096:
3097: let defaultCilPrinter = new defaultCilPrinterClass
3098:
3099: (* Top-level printing functions *)
3100: let printType (pp: cilPrinter) () (t: typ) : doc =
3101: pp#pType None () t
3102:
3103: let printExp (pp: cilPrinter) () (e: exp) : doc =
3104: pp#pExp () e
3105:
3106: let printLval (pp: cilPrinter) () (lv: lval) : doc =
3107: pp#pLval () lv
3108:
3109: let printGlobal (pp: cilPrinter) () (g: global) : doc =
3110: pp#pGlobal () g
3111:
3112: let dumpGlobal (pp: cilPrinter) (out: out_channel) (g: global) : unit =
3113: pp#dGlobal out g
3114:
3115: let printAttr (pp: cilPrinter) () (a: attribute) : doc =
3116: let ad, _ = pp#pAttr a in ad
3117:
3118: let printAttrs (pp: cilPrinter) () (a: attributes) : doc =
3119: pp#pAttrs () a
3120:
3121: let printInstr (pp: cilPrinter) () (i: instr) : doc =
3122: pp#pInstr () i
3123:
3124: let printStmt (pp: cilPrinter) () (s: stmt) : doc =
3125: pp#pStmt () s
3126:
3127: let printBlock (pp: cilPrinter) () (b: block) : doc =
3128: (* We must add the alignment ourselves, beucase pBlock will pop it *)
3129: align ++ pp#pBlock () b
3130:
3131: let dumpStmt (pp: cilPrinter) (out: out_channel) (ind: int) (s: stmt) : unit =
3132: pp#dStmt out ind s
3133:
3134: let dumpBlock (pp: cilPrinter) (out: out_channel) (ind: int) (b: block) : unit =
3135: pp#dBlock out ind b
3136:
3137: let printInit (pp: cilPrinter) () (i: init) : doc =
3138: pp#pInit () i
3139:
3140: let dumpInit (pp: cilPrinter) (out: out_channel) (ind: int) (i: init) : unit =
3141: pp#dInit out ind i
3142:
3143: (* Now define some short cuts *)
3144: let d_exp () e = printExp defaultCilPrinter () e
3145: let d_lval () lv = printLval defaultCilPrinter () lv
3146: let d_offset base () off = defaultCilPrinter#pOffset base off
3147: let d_init () i = printInit defaultCilPrinter () i
3148: let d_type () t = printType defaultCilPrinter () t
3149: let d_global () g = printGlobal defaultCilPrinter () g
3150: let d_attrlist () a = printAttrs defaultCilPrinter () a
3151: let d_attr () a = printAttr defaultCilPrinter () a
3152: let d_attrparam () e = defaultCilPrinter#pAttrParam () e
3153: let d_label () l = defaultCilPrinter#pLabel () l
3154: let d_stmt () s = printStmt defaultCilPrinter () s
3155: let d_block () b = printBlock defaultCilPrinter () b
3156: let d_instr () i = printInstr defaultCilPrinter () i
3157:
3158: let d_shortglobal () = function
3159: GPragma (Attr(an, _), _) -> dprintf "#pragma %s" an
3160: | GType (ti, _) -> dprintf "typedef %s" ti.tname
3161: | GVarDecl (vi, _) -> dprintf "declaration of %s" vi.vname
3162: | GVar (vi, _, _) -> dprintf "definition of %s" vi.vname
3163: | GCompTag(ci,_) -> dprintf "definition of %s" (compFullName ci)
3164: | GCompTagDecl(ci,_) -> dprintf "declaration of %s" (compFullName ci)
3165: | GEnumTag(ei,_) -> dprintf "definition of enum %s" ei.ename
3166: | GEnumTagDecl(ei,_) -> dprintf "declaration of enum %s" ei.ename
3167: | GFun(fd, _) -> dprintf "definition of %s" fd.svar.vname
3168: | GText _ -> text "GText"
3169: | GAsm _ -> text "GAsm"
3170:
3171:
3172: (* sm: given an ordinary CIL object printer, yield one which
3173: * behaves the same, except it never prints #line directives
3174: * (this is useful for debugging printfs) *)
3175: let dn_obj (func: unit -> 'a -> doc) : (unit -> 'a -> doc) =
3176: begin
3177: (* construct the closure to return *)
3178: let theFunc () (obj:'a) : doc =
3179: begin
3180: let prevStyle = !lineDirectiveStyle in
3181: lineDirectiveStyle := None;
3182: let ret = (func () obj) in (* call underlying printer *)
3183: lineDirectiveStyle := prevStyle;
3184: ret
3185: end in
3186: theFunc
3187: end
3188:
3189: (* now define shortcuts for the non-location-printing versions,
3190: * with the naming prefix "dn_" *)
3191: let dn_exp = (dn_obj d_exp)
3192: let dn_lval = (dn_obj d_lval)
3193: (* dn_offset is missing because it has a different interface *)
3194: let dn_init = (dn_obj d_init)
3195: let dn_type = (dn_obj d_type)
3196: let dn_global = (dn_obj d_global)
3197: let dn_attrlist = (dn_obj d_attrlist)
3198: let dn_attr = (dn_obj d_attr)
3199: let dn_attrparam = (dn_obj d_attrparam)
3200: let dn_stmt = (dn_obj d_stmt)
3201: let dn_instr = (dn_obj d_instr)
3202:
3203:
3204: (* Now define a cilPlainPrinter *)
3205: class plainCilPrinterClass =
3206: (* We keep track of the composite types that we have done to avoid
3207: * recursion *)
3208: let donecomps : (int, unit) H.t = H.create 13 in
3209: object (self)
3210:
3211: inherit defaultCilPrinterClass as super
3212:
3213: (*** PLAIN TYPES ***)
3214: method pType (dn: doc option) () (t: typ) =
3215: match dn with
3216: None -> self#pOnlyType () t
3217: | Some d -> d ++ text " : " ++ self#pOnlyType () t
3218:
3219: method private pOnlyType () = function
3220: TVoid a -> dprintf "TVoid(@[%a@])" self#pAttrs a
3221: | TInt(ikind, a) -> dprintf "TInt(@[%a,@?%a@])"
3222: d_ikind ikind self#pAttrs a
3223: | TFloat(fkind, a) ->
3224: dprintf "TFloat(@[%a,@?%a@])" d_fkind fkind self#pAttrs a
3225: | TNamed (t, a) ->
3226: dprintf "TNamed(@[%s,@?%a,@?%a@])"
3227: t.tname self#pOnlyType t.ttype self#pAttrs a
3228: | TPtr(t, a) -> dprintf "TPtr(@[%a,@?%a@])" self#pOnlyType t self#pAttrs a
3229: | TArray(t,l,a) ->
3230: let dl = match l with
3231: None -> text "None" | Some l -> dprintf "Some(@[%a@])" self#pExp l in
3232: dprintf "TArray(@[%a,@?%a,@?%a@])"
3233: self#pOnlyType t insert dl self#pAttrs a
3234: | TEnum(enum,a) -> dprintf "Enum(%s,@[%a@])" enum.ename self#pAttrs a
3235: | TFun(tr,args,isva,a) ->
3236: dprintf "TFun(@[%a,@?%a%s,@?%a@])"
3237: self#pOnlyType tr
3238: insert
3239: (if args = None then text "None"
3240: else (docList (chr ',' ++ break)
3241: (fun (an,at,aa) ->
3242: dprintf "%s: %a" an self#pOnlyType at))
3243: ()
3244: (argsToList args))
3245: (if isva then "..." else "") self#pAttrs a
3246: | TComp (comp, a) ->
3247: if H.mem donecomps comp.ckey then
3248: dprintf "TCompLoop(%s %s, _, %a)"
3249: (if comp.cstruct then "struct" else "union") comp.cname
3250: self#pAttrs comp.cattr
3251: else begin
3252: H.add donecomps comp.ckey (); (* Add it before we do the fields *)
3253: dprintf "TComp(@[%s %s,@?%a,@?%a,@?%a@])"
3254: (if comp.cstruct then "struct" else "union") comp.cname
3255: (docList (chr ',' ++ break)
3256: (fun f -> dprintf "%s : %a" f.fname self#pOnlyType f.ftype))
3257: comp.cfields
3258: self#pAttrs comp.cattr
3259: self#pAttrs a
3260: end
3261: | TBuiltin_va_list a ->
3262: dprintf "TBuiltin_va_list(%a)" self#pAttrs a
3263:
3264:
3265: (* Some plain pretty-printers. Unlike the above these expose all the
3266: * details of the internal representation *)
3267: method pExp () = function
3268: Const(c) ->
3269: text "Const(" ++ d_const () c ++ text ")"
3270: | Lval(lv) ->
3271: text "Lval("
3272: ++ (align
3273: ++ self#pLval () lv
3274: ++ unalign)
3275: ++ text ")"
3276:
3277: | CastE(t,e) -> dprintf "CastE(@[%a,@?%a@])" self#pOnlyType t self#pExp e
3278:
3279: | UnOp(u,e1,_) ->
3280: let d_unop () u =
3281: match u with
3282: Neg -> text "-"
3283: | BNot -> text "~"
3284: | LNot -> text "!"
3285: in
3286: dprintf "UnOp(@[%a,@?%a@])"
3287: d_unop u self#pExp e1
3288:
3289: | BinOp(b,e1,e2,_) ->
3290: dprintf "%a(@[%a,@?%a@])" d_binop b
3291: self#pExp e1 self#pExp e2
3292:
3293: | SizeOf (t) ->
3294: text "sizeof(" ++ self#pType None () t ++ chr ')'
3295: | SizeOfE (e) ->
3296: text "sizeofE(" ++ self#pExp () e ++ chr ')'
3297: | SizeOfStr (s) ->
3298: text "sizeofStr(" ++ d_const () (CStr s) ++ chr ')'
3299: | AlignOf (t) ->
3300: text "__alignof__(" ++ self#pType None () t ++ chr ')'
3301: | AlignOfE (e) ->
3302: text "__alignof__(" ++ self#pExp () e ++ chr ')'
3303:
3304: | StartOf lv -> dprintf "StartOf(%a)" self#pLval lv
3305: | AddrOf (lv) -> dprintf "AddrOf(%a)" self#pLval lv
3306:
3307:
3308:
3309: method private d_plainoffset () = function
3310: NoOffset -> text "NoOffset"
3311: | Field(fi,o) ->
3312: dprintf "Field(@[%s:%a,@?%a@])"
3313: fi.fname self#pOnlyType fi.ftype self#d_plainoffset o
3314: | Index(e, o) ->
3315: dprintf "Index(@[%a,@?%a@])" self#pExp e self#d_plainoffset o
3316:
3317: method pInit () = function
3318: SingleInit e -> dprintf "SI(%a)" d_exp e
3319: | CompoundInit (t, initl) ->
3320: let d_plainoneinit (o, i) =
3321: self#d_plainoffset () o ++ text " = " ++ self#pInit () i
3322: in
3323: dprintf "CI(@[%a,@?%a@])" self#pOnlyType t
3324: (docList (chr ',' ++ break) d_plainoneinit) initl
3325: (*
3326: | ArrayInit (t, len, initl) ->
3327: let idx = ref (- 1) in
3328: let d_plainoneinit i =
3329: incr idx;
3330: text "[" ++ num !idx ++ text "] = " ++ self#pInit () i
3331: in
3332: dprintf "AI(@[%a,%d,@?%a@])" self#pOnlyType t len
3333: (docList (chr ',' ++ break) d_plainoneinit) initl
3334: *)
3335: method pLval () (lv: lval) =
3336: match lv with
3337: | Var vi, o -> dprintf "Var(@[%s,@?%a@])" vi.vname self#d_plainoffset o
3338: | Mem e, o -> dprintf "Mem(@[%a,@?%a@])" self#pExp e self#d_plainoffset o
3339:
3340:
3341: end
3342: let plainCilPrinter = new plainCilPrinterClass
3343:
3344: (* And now some shortcuts *)
3345: let d_plainexp () e = plainCilPrinter#pExp () e
3346: let d_plaintype () t = plainCilPrinter#pType None () t
3347: let d_plaininit () i = plainCilPrinter#pInit () i
3348: let d_plainlval () l = plainCilPrinter#pLval () l
3349:
3350: let rec d_typsig () = function
3351: TSArray (ts, eo, al) ->
3352: dprintf "TSArray(@[%a,@?%a,@?%a@])"
3353: d_typsig ts
3354: insert (match eo with None -> text "None" | Some e -> d_exp () e)
3355: d_attrlist al
3356: | TSPtr (ts, al) ->
3357: dprintf "TSPtr(@[%a,@?%a@])"
3358: d_typsig ts d_attrlist al
3359: | TSComp (iss, name, al) ->
3360: dprintf "TSComp(@[%s %s,@?%a@])"
3361: (if iss then "struct" else "union") name
3362: d_attrlist al
3363: | TSFun (rt, args, isva, al) ->
3364: dprintf "TSFun(@[%a,@?%a,%b,@?%a@])"
3365: d_typsig rt
3366: (docList (chr ',' ++ break) (d_typsig ())) args isva
3367: d_attrlist al
3368: | TSEnum (n, al) ->
3369: dprintf "TSEnum(@[%s,@?%a@])"
3370: n d_attrlist al
3371: | TSBase t -> dprintf "TSBase(%a)" d_type t
3372:
3373:
3374:
3375: (* Make a varinfo. Used mostly as a helper function below *)
3376: let makeVarinfo global name typ =
3377: (* Strip const from type for locals *)
3378: let vi =
3379: { vname = name;
3380: vid = !nextGlobalVID;
3381: vglob = global;
3382: vtype = if global then typ else typeRemoveAttributes ["const"] typ;
3383: vdecl = lu;
3384: vinline = false;
3385: vattr = [];
3386: vstorage = NoStorage;
3387: vaddrof = false;
3388: vreferenced = false; (* sm *)
3389: } in
3390: incr nextGlobalVID;
3391: vi
3392:
3393: let copyVarinfo (vi: varinfo) (newname: string) : varinfo =
3394: let vi' = {vi with vname = newname; vid = !nextGlobalVID } in
3395: incr nextGlobalVID;
3396: vi'
3397:
3398: let makeLocal fdec name typ = (* a helper function *)
3399: fdec.smaxid <- 1 + fdec.smaxid;
3400: let vi = makeVarinfo false name typ in
3401: vi
3402:
3403: (* Make a local variable and add it to a function *)
3404: let makeLocalVar fdec ?(insert = true) name typ =
3405: let vi = makeLocal fdec name typ in
3406: if insert then fdec.slocals <- fdec.slocals @ [vi];
3407: vi
3408:
3409:
3410: let makeTempVar fdec ?(name = "__cil_tmp") typ : varinfo =
3411: let name = name ^ (string_of_int (1 + fdec.smaxid)) in
3412: makeLocalVar fdec name typ
3413:
3414:
3415: (* Set the formals and re-create the function name based on the information*)
3416: let setFormals (f: fundec) (forms: varinfo list) =
3417: f.sformals <- forms; (* Set the formals *)
3418: match unrollType f.svar.vtype with
3419: TFun(rt, _, isva, fa) ->
3420: f.svar.vtype <-
3421: TFun(rt,
3422: Some (List.map (fun a -> (a.vname, a.vtype, a.vattr)) forms),
3423: isva, fa)
3424: | _ -> E.s (E.bug "Set formals. %s does not have function type\n"
3425: f.svar.vname)
3426:
3427: (* Set the types of arguments and results as given by the function type
3428: * passed as the second argument *)
3429: let setFunctionType (f: fundec) (t: typ) =
3430: match unrollType t with
3431: TFun (rt, Some args, va, a) ->
3432: if List.length f.sformals <> List.length args then
3433: E.s (E.bug "setFunctionType: number of arguments differs from the number of formals");
3434: (* Change the function type. *)
3435: f.svar.vtype <- t;
3436: (* Change the sformals and we know that indirectly we'll change the
3437: * function type *)
3438: List.iter2
3439: (fun (an,at,aa) f ->
3440: f.vtype <- at; f.vattr <- aa)
3441: args f.sformals
3442:
3443: | _ -> E.s (E.bug "setFunctionType: not a function type")
3444:
3445:
3446: let setMaxId (f: fundec) =
3447: f.smaxid <- List.length f.sformals + List.length f.slocals
3448:
3449:
3450: (* Make a formal variable for a function. Insert it in both the sformals
3451: * and the type of the function. You can optionally specify where to insert
3452: * this one. If where = "^" then it is inserted first. If where = "$" then
3453: * it is inserted last. Otherwise where must be the name of a formal after
3454: * which to insert this. By default it is inserted at the end. *)
3455: let makeFormalVar fdec ?(where = "$") name typ : varinfo =
3456: (* Search for the insertion place *)
3457: let thenewone = ref fdec.svar in (* Just a placeholder *)
3458: let makeit () : varinfo =
3459: let vi = makeLocal fdec name typ in
3460: thenewone := vi;
3461: vi
3462: in
3463: let rec loopFormals = function
3464: [] ->
3465: if where = "$" then [makeit ()]
3466: else E.s (E.error "makeFormalVar: cannot find insert-after formal %s"
3467: where)
3468: | f :: rest when f.vname = where -> f :: makeit () :: rest
3469: | f :: rest -> f :: loopFormals rest
3470: in
3471: let newformals =
3472: if where = "^" then makeit () :: fdec.sformals else
3473: loopFormals fdec.sformals in
3474: setFormals fdec newformals;
3475: !thenewone
3476:
3477: (* Make a global variable. Your responsibility to make sure that the name
3478: * is unique *)
3479: let makeGlobalVar name typ =
3480: let vi = makeVarinfo true name typ in
3481: vi
3482:
3483:
3484: (* Make an empty function *)
3485: let emptyFunction name =
3486: { svar = makeGlobalVar name (TFun(voidType, Some [], false,[]));
3487: smaxid = 0;
3488: slocals = [];
3489: sformals = [];
3490: sbody = mkBlock [];
3491: smaxstmtid = None;
3492: }
3493:
3494:
3495:
3496: (* A dummy function declaration handy for initialization *)
3497: let dummyFunDec = emptyFunction "@dummy"
3498: let dummyFile =
3499: { globals = [];
3500: fileName = "<dummy>";
3501: globinit = None;
3502: globinitcalled = false}
3503:
3504: let saveBinaryFile (cil_file : file) (filename : string) =
3505: let outchan = open_out_bin filename in
3506: Marshal.to_channel outchan cil_file [] ;
3507: close_out outchan
3508:
3509: let saveBinaryFileChannel (cil_file : file) (outchan : out_channel) =
3510: Marshal.to_channel outchan cil_file []
3511:
3512: let loadBinaryFile (filename : string) : file =
3513: let inchan = open_in_bin filename in
3514: let cil_file = (Marshal.from_channel inchan : file) in
3515: close_in inchan ;
3516: cil_file
3517:
3518:
3519: (* Take the name of a file and make a valid symbol name out of it. There are
3520: * a few chanracters that are not valid in symbols *)
3521: let makeValidSymbolName (s: string) =
3522: let s = String.copy s in (* So that we can update in place *)
3523: let l = String.length s in
3524: for i = 0 to l - 1 do
3525: let c = String.get s i in
3526: let isinvalid =
3527: match c with
3528: '-' | '.' -> true
3529: | _ -> false
3530: in
3531: if isinvalid then
3532: String.set s i '_';
3533: done;
3534: s
3535:
3536:
3537: (*** Define the visiting engine ****)
3538: (* visit all the nodes in a Flx_cil_cil expression *)
3539: let doVisit (vis: cilVisitor)
3540: (startvisit: 'a -> 'a visitAction)
3541: (children: cilVisitor -> 'a -> 'a)
3542: (node: 'a) : 'a =
3543: let action = startvisit node in
3544: match action with
3545: SkipChildren -> node
3546: | ChangeTo node' -> node'
3547: | _ -> (* DoChildren and ChangeDoChildrenPost *)
3548: let nodepre = match action with
3549: ChangeDoChildrenPost (node', _) -> node'
3550: | _ -> node
3551: in
3552: let nodepost = children vis nodepre in
3553: match action with
3554: ChangeDoChildrenPost (_, f) -> f nodepost
3555: | _ -> nodepost
3556:
3557: (* mapNoCopy is like map but avoid copying the list if the function does not
3558: * change the elements. *)
3559: let rec mapNoCopy (f: 'a -> 'a) = function
3560: [] -> []
3561: | (i :: resti) as li ->
3562: let i' = f i in
3563: let resti' = mapNoCopy f resti in
3564: if i' != i || resti' != resti then i' :: resti' else li
3565:
3566: let rec mapNoCopyList (f: 'a -> 'a list) = function
3567: [] -> []
3568: | (i :: resti) as li ->
3569: let il' = f i in
3570: let resti' = mapNoCopyList f resti in
3571: match il' with
3572: [i'] when i' == i && resti' == resti -> li
3573: | _ -> il' @ resti'
3574:
3575: (* A visitor for lists *)
3576: let doVisitList (vis: cilVisitor)
3577: (startvisit: 'a -> 'a list visitAction)
3578: (children: cilVisitor -> 'a -> 'a)
3579: (node: 'a) : 'a list =
3580: let action = startvisit node in
3581: match action with
3582: SkipChildren -> [node]
3583: | ChangeTo nodes' -> nodes'
3584: | _ ->
3585: let nodespre = match action with
3586: ChangeDoChildrenPost (nodespre, _) -> nodespre
3587: | _ -> [node]
3588: in
3589: let nodespost = mapNoCopy (children vis) nodespre in
3590: match action with
3591: ChangeDoChildrenPost (_, f) -> f nodespost
3592: | _ -> nodespost
3593:
3594: let debugVisit = false
3595:
3596: let rec visitCilExpr (vis: cilVisitor) (e: exp) : exp =
3597: doVisit vis vis#vexpr childrenExp e
3598: and childrenExp (vis: cilVisitor) (e: exp) : exp =
3599: let vExp e = visitCilExpr vis e in
3600: let vTyp t = visitCilType vis t in
3601: let vLval lv = visitCilLval vis lv in
3602: match e with
3603: Const _ -> e
3604: | SizeOf t ->
3605: let t'= vTyp t in
3606: if t' != t then SizeOf t' else e
3607: | SizeOfE e1 ->
3608: let e1' = vExp e1 in
3609: if e1' != e1 then SizeOfE e1' else e
3610: | SizeOfStr s -> e
3611:
3612: | AlignOf t ->
3613: let t' = vTyp t in
3614: if t' != t then AlignOf t' else e
3615: | AlignOfE e1 ->
3616: let e1' = vExp e1 in
3617: if e1' != e1 then AlignOfE e1' else e
3618: | Lval lv ->
3619: let lv' = vLval lv in
3620: if lv' != lv then Lval lv' else e
3621: | UnOp (uo, e1, t) ->
3622: let e1' = vExp e1 in let t' = vTyp t in
3623: if e1' != e1 || t' != t then UnOp(uo, e1', t') else e
3624: | BinOp (bo, e1, e2, t) ->
3625: let e1' = vExp e1 in let e2' = vExp e2 in let t' = vTyp t in
3626: if e1' != e1 || e2' != e2 || t' != t then BinOp(bo, e1',e2',t') else e
3627: | CastE (t, e1) ->
3628: let t' = vTyp t in let e1' = vExp e1 in
3629: if t' != t || e1' != e1 then CastE(t', e1') else e
3630: | AddrOf lv ->
3631: let lv' = vLval lv in
3632: if lv' != lv then AddrOf lv' else e
3633: | StartOf lv ->
3634: let lv' = vLval lv in
3635: if lv' != lv then StartOf lv' else e
3636:
3637: and visitCilInit (vis: cilVisitor) (i: init) : init =
3638: doVisit vis vis#vinit childrenInit i
3639: and childrenInit (vis: cilVisitor) (i: init) : init =
3640: let fExp e = visitCilExpr vis e in
3641: let fInit i = visitCilInit vis i in
3642: let fTyp t = visitCilType vis t in
3643: match i with
3644: | SingleInit e ->
3645: let e' = fExp e in
3646: if e' != e then SingleInit e' else i
3647: | CompoundInit (t, initl) ->
3648: let t' = fTyp t in
3649: (* Collect the new initializer list, in reverse. We prefer two
3650: * traversals to ensure tail-recursion. *)
3651: let newinitl : (offset * init) list ref = ref [] in
3652: (* Keep track whether the list has changed *)
3653: let hasChanged = ref false in
3654: let doOneInit ((o, i) as oi) =
3655: let o' = visitCilInitOffset vis o in (* use initializer version *)
3656: let i' = fInit i in
3657: let newio =
3658: if o' != o || i' != i then
3659: begin hasChanged := true; (o', i') end else oi
3660: in
3661: newinitl := newio :: !newinitl
3662: in
3663: List.iter doOneInit initl;
3664: let initl' = if !hasChanged then List.rev !newinitl else initl in
3665: if t' != t || initl' != initl then CompoundInit (t', initl') else i
3666: (*
3667: | ArrayInit (bt, len, initl) ->
3668: let bt' = fTyp bt in
3669: (* Collect the new initializer list, in reverse. We prefer two
3670: * traversals to ensure tail-recursion. *)
3671: let newinitl : init list ref = ref [] in
3672: (* Keep track whether the list has changed *)
3673: let hasChanged = ref false in
3674: List.iter (fun i -> let i' = fInit i in
3675: let i'' =
3676: if i' != i then
3677: begin hasChanged := true; i' end else i
3678: in
3679: newinitl := i'' :: !newinitl) initl;
3680: let initl' = if !hasChanged then List.rev !newinitl else initl in
3681: if bt' != bt || initl' != initl then ArrayInit(bt', len, initl') else i
3682: *)
3683:
3684: and visitCilLval (vis: cilVisitor) (lv: lval) : lval =
3685: doVisit vis vis#vlval childrenLval lv
3686: and childrenLval (vis: cilVisitor) (lv: lval) : lval =
3687: (* and visit its subexpressions *)
3688: let vExp e = visitCilExpr vis e in
3689: let vTyp t = visitCilType vis t in
3690: let vOff off = visitCilOffset vis off in
3691: match lv with
3692: Var v, off ->
3693: let v' = doVisit vis vis#vvrbl (fun _ x -> x) v in
3694: let off' = vOff off in
3695: if v' != v || off' != off then Var v', off' else lv
3696: | Mem e, off ->
3697: let e' = vExp e in
3698: let off' = vOff off in
3699: if e' != e || off' != off then Mem e', off' else lv
3700:
3701: and visitCilOffset (vis: cilVisitor) (off: offset) : offset =
3702: doVisit vis vis#voffs childrenOffset off
3703: and childrenOffset (vis: cilVisitor) (off: offset) : offset =
3704: let vOff off = visitCilOffset vis off in
3705: match off with
3706: Field (f, o) ->
3707: let o' = vOff o in
3708: if o' != o then Field (f, o') else off
3709: | Index (e, o) ->
3710: let e' = visitCilExpr vis e in
3711: let o' = vOff o in
3712: if e' != e || o' != o then Index (e', o') else off
3713: | NoOffset -> off
3714:
3715: (* sm: for offsets in initializers, the 'startvisit' will be the
3716: * vinitoffs method, but we can re-use the childrenOffset from
3717: * above since recursive offsets are visited by voffs. (this point
3718: * is moot according to cil.mli which claims the offsets in
3719: * initializers will never recursively contain offsets)
3720: *)
3721: and visitCilInitOffset (vis: cilVisitor) (off: offset) : offset =
3722: doVisit vis vis#vinitoffs childrenOffset off
3723:
3724: and visitCilInstr (vis: cilVisitor) (i: instr) : instr list =
3725: let oldloc = !currentLoc in
3726: currentLoc := (get_instrLoc i);
3727: assertEmptyQueue vis;
3728: let res = doVisitList vis vis#vinst childrenInstr i in
3729: currentLoc := oldloc;
3730: (* See if we have accumulated some instructions *)
3731: vis#unqueueInstr () @ res
3732:
3733: and childrenInstr (vis: cilVisitor) (i: instr) : instr =
3734: let fExp = visitCilExpr vis in
3735: let fLval = visitCilLval vis in
3736: match i with
3737: | Set(lv,e,l) ->
3738: let lv' = fLval lv in let e' = fExp e in
3739: if lv' != lv || e' != e then Set(lv',e',l) else i
3740: | Call(None,f,args,l) ->
3741: let f' = fExp f in let args' = mapNoCopy fExp args in
3742: if f' != f || args' != args then Call(None,f',args',l) else i
3743: | Call(Some lv,fn,args,l) ->
3744: let lv' = fLval lv in let fn' = fExp fn in
3745: let args' = mapNoCopy fExp args in
3746: if lv' != lv || fn' != fn || args' != args
3747: then Call(Some lv', fn', args', l) else i
3748:
3749: | Asm(sl,isvol,outs,ins,clobs,l) ->
3750: let outs' = mapNoCopy (fun ((s,lv) as pair) ->
3751: let lv' = fLval lv in
3752: if lv' != lv then (s,lv') else pair) outs in
3753: let ins' = mapNoCopy (fun ((s,e) as pair) ->
3754: let e' = fExp e in
3755: if e' != e then (s,e') else pair) ins in
3756: if outs' != outs || ins' != ins then
3757: Asm(sl,isvol,outs',ins',clobs,l) else i
3758:
3759:
3760: (* visit all nodes in a Flx_cil_cil statement tree in preorder *)
3761: and visitCilStmt (vis: cilVisitor) (s: stmt) : stmt =
3762: let oldloc = !currentLoc in
3763: currentLoc := (get_stmtLoc s.skind) ;
3764: assertEmptyQueue vis;
3765: let toPrepend : instr list ref = ref [] in (* childrenStmt may add to this *)
3766: let res = doVisit vis vis#vstmt (childrenStmt toPrepend) s in
3767: (* Now see if we have saved some instructions *)
3768: toPrepend := !toPrepend @ vis#unqueueInstr ();
3769: (match !toPrepend with
3770: [] -> () (* Return the same statement *)
3771: | _ ->
3772: (* Make our statement contain the instructions to prepend *)
3773: res.skind <- Block { battrs = []; bstmts = [ mkStmt (Instr !toPrepend);
3774: mkStmt res.skind ] });
3775: currentLoc := oldloc;
3776: res
3777:
3778: and childrenStmt (toPrepend: instr list ref) (vis:cilVisitor) (s:stmt): stmt =
3779: let fExp e = (visitCilExpr vis e) in
3780: let fLval lv = (visitCilLval vis lv) in
3781: let fOff o = (visitCilOffset vis o) in
3782: let fBlock b = visitCilBlock vis b in
3783: let fInst i = visitCilInstr vis i in
3784: (* Just change the statement kind *)
3785: let skind' =
3786: match s.skind with
3787: Break _ | Continue _ | Goto _ | Return (None, _) -> s.skind
3788: | Return (Some e, l) ->
3789: let e' = fExp e in
3790: if e' != e then Return (Some e', l) else s.skind
3791: | Loop (b, l, s1, s2) ->
3792: let b' = fBlock b in
3793: if b' != b then Loop (b', l, s1, s2) else s.skind
3794: | If(e, s1, s2, l) ->
3795: let e' = fExp e in
3796: (*if e queued any instructions, pop them here and remember them so that
3797: they are inserted before the If stmt, not in the then block. *)
3798: toPrepend := vis#unqueueInstr ();
3799: let s1'= fBlock s1 in let s2'= fBlock s2 in
3800: (* the stmts in the blocks should have cleaned up after themselves.*)
3801: assertEmptyQueue vis;
3802: if e' != e || s1' != s1 || s2' != s2 then
3803: If(e', s1', s2', l) else s.skind
3804: | Switch (e, b, stmts, l) ->
3805: let e' = fExp e in
3806: toPrepend := vis#unqueueInstr (); (* insert these before the switch *)
3807: let b' = fBlock b in
3808: (* the stmts in b should have cleaned up after themselves.*)
3809: assertEmptyQueue vis;
3810: (* Don't do stmts, but we better not change those *)
3811: if e' != e || b' != b then Switch (e', b', stmts, l) else s.skind
3812: | Instr il ->
3813: let il' = mapNoCopyList fInst il in
3814: if il' != il then Instr il' else s.skind
3815: | Block b ->
3816: let b' = fBlock b in
3817: if b' != b then Block b' else s.skind
3818: | TryFinally (b, h, l) ->
3819: let b' = fBlock b in
3820: let h' = fBlock h in
3821: if b' != b || h' != h then TryFinally(b', h', l) else s.skind
3822: | TryExcept (b, (il, e), h, l) ->
3823: let b' = fBlock b in
3824: assertEmptyQueue vis;
3825: (* visit the instructions *)
3826: let il' = mapNoCopyList fInst il in
3827: (* Visit the expression *)
3828: let e' = fExp e in
3829: let il'' =
3830: let more = vis#unqueueInstr () in
3831: if more != [] then
3832: il' @ more
3833: else
3834: il'
3835: in
3836: let h' = fBlock h in
3837: (* Now collect the instructions *)
3838: if b' != b || il'' != il || e' != e || h' != h then
3839: TryExcept(b', (il'', e'), h', l)
3840: else s.skind
3841: in
3842: if skind' != s.skind then s.skind <- skind';
3843: (* Visit the labels *)
3844: let labels' =
3845: let fLabel = function
3846: Case (e, l) as lb ->
3847: let e' = fExp e in
3848: if e' != e then Case (e', l) else lb
3849: | lb -> lb
3850: in
3851: mapNoCopy fLabel s.labels
3852: in
3853: if labels' != s.labels then s.labels <- labels';
3854: s
3855:
3856:
3857:
3858: and visitCilBlock (vis: cilVisitor) (b: block) : block =
3859: doVisit vis vis#vblock childrenBlock b
3860: and childrenBlock (vis: cilVisitor) (b: block) : block =
3861: let fStmt s = visitCilStmt vis s in
3862: let stmts' = mapNoCopy fStmt b.bstmts in
3863: if stmts' != b.bstmts then { battrs = b.battrs; bstmts = stmts'} else b
3864:
3865:
3866: and visitCilType (vis : cilVisitor) (t : typ) : typ =
3867: doVisit vis vis#vtype childrenType t
3868: and childrenType (vis : cilVisitor) (t : typ) : typ =
3869: (* look for types referred to inside t's definition *)
3870: let fTyp t = visitCilType vis t in
3871: let fAttr a = visitCilAttributes vis a in
3872: match t with
3873: TPtr(t1, a) ->
3874: let t1' = fTyp t1 in
3875: let a' = fAttr a in
3876: if t1' != t || a' != a then TPtr(t1', a') else t
3877: | TArray(t1, None, a) ->
3878: let t1' = fTyp t1 in
3879: let a' = fAttr a in
3880: if t1' != t || a' != a then TArray(t1', None, a') else t
3881: | TArray(t1, Some e, a) ->
3882: let t1' = fTyp t1 in
3883: let e' = visitCilExpr vis e in
3884: let a' = fAttr a in
3885: if t1' != t || e' != e || a' != a then TArray(t1', Some e', a') else t
3886:
3887: (* DON'T recurse into the compinfo, this is done in visitCilGlobal.
3888: User can iterate over cinfo.cfields manually, if desired.*)
3889: | TComp(cinfo, a) ->
3890: let a' = fAttr a in
3891: if a != a' then TComp(cinfo, a') else t
3892:
3893: | TFun(rettype, args, isva, a) ->
3894: let rettype' = fTyp rettype in
3895: (* iterate over formals, as variable declarations *)
3896: let argslist = argsToList args in
3897: let visitArg ((an,at,aa) as arg) =
3898: let at' = fTyp at in
3899: let aa' = fAttr aa in
3900: if at' != at || aa' != aa then (an,at',aa') else arg
3901: in
3902: let argslist' = mapNoCopy visitArg argslist in
3903: let a' = fAttr a in
3904: if rettype' != rettype || argslist' != argslist || a' != a then
3905: let args' = if argslist' == argslist then args else Some argslist' in
3906: TFun(rettype', args', isva, a') else t
3907:
3908: | TNamed(t1, a) -> (* Do not go into the type. Will do it at the time of
3909: * GType *)
3910: let a' = fAttr a in
3911: if a' != a then TNamed (t1, a') else t
3912:
3913: | _ -> (* other types (TVoid, TInt, TFloat, TEnum, and TBuiltin_va_list)
3914: don't contain nested types, but they do have attributes. *)
3915: let a = typeAttrs t in
3916: let a' = fAttr a in
3917: if a' != a then setTypeAttrs t a' else t
3918:
3919:
3920: (* for declarations, we visit the types inside; but for uses, *)
3921: (* we just visit the varinfo node *)
3922: and visitCilVarDecl (vis : cilVisitor) (v : varinfo) : varinfo =
3923: doVisit vis vis#vvdec childrenVarDecl v
3924: and childrenVarDecl (vis : cilVisitor) (v : varinfo) : varinfo =
3925: v.vtype <- visitCilType vis v.vtype;
3926: v.vattr <- visitCilAttributes vis v.vattr;
3927: v
3928:
3929: and visitCilAttributes (vis: cilVisitor) (al: attribute list) : attribute list=
3930: let al' =
3931: mapNoCopyList (doVisitList vis vis#vattr childrenAttribute) al in
3932: if al' != al then
3933: (* Must re-sort *)
3934: addAttributes al' []
3935: else
3936: al
3937: and childrenAttribute (vis: cilVisitor) (a: attribute) : attribute =
3938: let fTyp t = visitCilType vis t in
3939: let rec doarg (aa: attrparam) =
3940: match aa with
3941: AInt _ | AStr _ -> aa
3942: | ACons(n, args) ->
3943: let args' = mapNoCopy doarg args in
3944: if args' != args then ACons(n, args') else aa
3945: | ASizeOf t ->
3946: let t' = fTyp t in
3947: if t' != t then ASizeOf t' else aa
3948: | ASizeOfE e ->
3949: let e' = doarg e in
3950: if e' != e then ASizeOfE e' else aa
3951: | AAlignOf t ->
3952: let t' = fTyp t in
3953: if t' != t then AAlignOf t' else aa
3954: | AAlignOfE e ->
3955: let e' = doarg e in
3956: if e' != e then AAlignOfE e' else aa
3957: | AUnOp (uo, e1) ->
3958: let e1' = doarg e1 in
3959: if e1' != e1 then AUnOp (uo, e1') else aa
3960: | ABinOp (bo, e1, e2) ->
3961: let e1' = doarg e1 in
3962: let e2' = doarg e2 in
3963: if e1' != e1 || e2' != e2 then ABinOp (bo, e1', e2') else aa
3964: | ADot (ap, s) ->
3965: let ap' = doarg ap in
3966: if ap' != ap then ADot (ap', s) else aa
3967:
3968: in
3969: match a with
3970: Attr (n, args) ->
3971: let args' = mapNoCopy doarg args in
3972: if args' != args then Attr(n, args') else a
3973:
3974:
3975:
3976: let rec visitCilFunction (vis : cilVisitor) (f : fundec) : fundec =
3977: if debugVisit then ignore (E.log "Visiting function %s\n" f.svar.vname);
3978: doVisit vis vis#vfunc childrenFunction f
3979:
3980: and childrenFunction (vis : cilVisitor) (f : fundec) : fundec =
3981: f.svar <- visitCilVarDecl vis f.svar; (* hit the function name *)
3982: (* visit local declarations *)
3983: f.slocals <- mapNoCopy (visitCilVarDecl vis) f.slocals;
3984: (* visit the formals *)
3985: let newformals = mapNoCopy (visitCilVarDecl vis) f.sformals in
3986: (* Make sure the type reflects the formals *)
3987: setFormals f newformals;
3988: f.sbody <- visitCilBlock vis f.sbody; (* visit the body *)
3989: f
3990:
3991: let rec visitCilGlobal (vis: cilVisitor) (g: global) : global list =
3992: (*(trace "visit" (dprintf "visitCilGlobal\n"));*)
3993: let oldloc = !currentLoc in
3994: currentLoc := (get_globalLoc g) ;
3995: let res = doVisitList vis vis#vglob childrenGlobal g in
3996: currentLoc := oldloc;
3997: res
3998: and childrenGlobal (vis: cilVisitor) (g: global) : global =
3999: match g with
4000: | GFun (f, l) ->
4001: let f' = visitCilFunction vis f in
4002: if f' != f then GFun (f', l) else g
4003: | GType(t, l) ->
4004: t.ttype <- visitCilType vis t.ttype;
4005: g
4006:
4007: | GEnumTagDecl _ | GCompTagDecl _ -> g (* Nothing to visit *)
4008: | GEnumTag (enum, _) ->
4009: (trace "visit" (dprintf "visiting global enum %s\n" enum.ename));
4010: (* Do the values and attributes of the enumerated items *)
4011: let itemVisit (name, exp, loc) = (name, visitCilExpr vis exp, loc) in
4012: enum.eitems <- mapNoCopy itemVisit enum.eitems;
4013: enum.eattr <- visitCilAttributes vis enum.eattr;
4014: g
4015:
4016: | GCompTag (comp, _) ->
4017: (trace "visit" (dprintf "visiting global comp %s\n" comp.cname));
4018: (* Do the types and attirbutes of the fields *)
4019: let fieldVisit = fun fi ->
4020: fi.ftype <- visitCilType vis fi.ftype;
4021: fi.fattr <- visitCilAttributes vis fi.fattr
4022: in
4023: List.iter fieldVisit comp.cfields;
4024: g
4025:
4026: | GVarDecl(v, l) ->
4027: let v' = visitCilVarDecl vis v in
4028: if v' != v then GVarDecl (v', l) else g
4029: | GVar (v, inito, l) ->
4030: let v' = visitCilVarDecl vis v in
4031: (match inito.init with
4032: None -> ()
4033: | Some i -> let i' = visitCilInit vis i in
4034: if i' != i then inito.init <- Some i');
4035:
4036: if v' != v then GVar (v', inito, l) else g
4037:
4038: | GPragma (a, l) -> begin
4039: match visitCilAttributes vis [a] with
4040: [a'] -> if a' != a then GPragma (a', l) else g
4041: | _ -> E.s (E.unimp "visitCilAttributes returns more than one attribute")
4042: end
4043: | _ -> g
4044:
4045:
4046: (* Iterate over all globals, including the global initializer *)
4047: let iterGlobals (fl: file)
4048: (doone: global -> unit) : unit =
4049: let doone' g =
4050: currentLoc := get_globalLoc g;
4051: doone g
4052: in
4053: List.iter doone' fl.globals;
4054: (match fl.globinit with
4055: None -> ()
4056: | Some g -> doone' (GFun(g, locUnknown)))
4057:
4058: (* Fold over all globals, including the global initializer *)
4059: let foldGlobals (fl: file)
4060: (doone: 'a -> global -> 'a)
4061: (acc: 'a) : 'a =
4062: let doone' acc g =
4063: currentLoc := get_globalLoc g;
4064: doone acc g
4065: in
4066: let acc' = List.fold_left doone' acc fl.globals in
4067: (match fl.globinit with
4068: None -> acc'
4069: | Some g -> doone' acc' (GFun(g, locUnknown)))
4070:
4071:
4072: (* A visitor for the whole file that does not change the globals *)
4073: let visitCilFileSameGlobals (vis : cilVisitor) (f : file) : unit =
4074: let fGlob g = visitCilGlobal vis g in
4075: iterGlobals f (fun g ->
4076: match fGlob g with
4077: [g'] when g' == g || g' = g -> () (* Try to do the pointer check first *)
4078: | gl ->
4079: ignore (E.log "You used visitCilFilSameGlobals but the global got changed:\n %a\nchanged to %a\n" d_global g (docList line (d_global ())) gl);
4080: ())
4081:
4082: (* Be careful with visiting the whole file because it might be huge. *)
4083: let visitCilFile (vis : cilVisitor) (f : file) : unit =
4084: let fGlob g = visitCilGlobal vis g in
4085: (* Scan the globals. Make sure this is tail recursive. *)
4086: let rec loop (acc: global list) = function
4087: [] -> f.globals <- List.rev acc
4088: | g :: restg ->
4089: loop ((List.rev (fGlob g)) @ acc) restg
4090: in
4091: loop [] f.globals;
4092: (* the global initializer *)
4093: (match f.globinit with
4094: None -> ()
4095: | Some g -> f.globinit <- Some (visitCilFunction vis g))
4096:
4097:
4098:
4099: (** Create or fetch the global initializer. Tries to put a call to in the the
4100: * function with the main_name *)
4101: let getGlobInit ?(main_name="main") (fl: file) =
4102: match fl.globinit with
4103: Some f -> f
4104: | None -> begin
4105: (* Sadly, we cannot use the Filename library because it does not like
4106: * function names with multiple . in them *)
4107: let f =
4108: let len = String.length fl.fileName in
4109: (* Find the last path separator and record the first . that we see,
4110: * going backwards *)
4111: let lastDot = ref len in
4112: let rec findLastPathSep i =
4113: if i < 0 then -1 else
4114: let c = String.get fl.fileName i in
4115: if c = '/' || c = '\\' then i
4116: else begin
4117: if c = '.' && !lastDot = len then
4118: lastDot := i;
4119: findLastPathSep (i - 1)
4120: end
4121: in
4122: let lastPathSep = findLastPathSep (len - 1) in
4123: let basenoext =
4124: String.sub fl.fileName (lastPathSep + 1) (!lastDot - lastPathSep - 1)
4125: in
4126: emptyFunction
4127: (makeValidSymbolName ("__globinit_" ^ basenoext))
4128: in
4129: fl.globinit <- Some f;
4130: (* Now try to add a call to the global initialized at the beginning of
4131: * main *)
4132: let mainname = "main" in
4133: let inserted = ref false in
4134: List.iter
4135: (fun g ->
4136: match g with
4137: GFun(m, lm) when m.svar.vname = "main" ->
4138: (* Prepend a prototype to the global initializer *)
4139: fl.globals <- GVarDecl (f.svar, lm) :: fl.globals;
4140: m.sbody.bstmts <-
4141: compactStmts (mkStmt (Instr [Call(None,
4142: Lval(var f.svar),
4143: [], locUnknown)])
4144: :: m.sbody.bstmts);
4145: inserted := true;
4146: if !E.verboseFlag then
4147: ignore (E.log "Inserted the globinit\n");
4148: fl.globinitcalled <- true;
4149: | _ -> ())
4150: fl.globals;
4151:
4152: if not !inserted then
4153: ignore (E.warn "Cannot find %s to add global initializer %s"
4154: main_name f.svar.vname);
4155:
4156: f
4157: end
4158:
4159:
4160:
4161: (* Fold over all globals, including the global initializer *)
4162: let mapGlobals (fl: file)
4163: (doone: global -> global) : unit =
4164: fl.globals <- List.map doone fl.globals;
4165: (match fl.globinit with
4166: None -> ()
4167: | Some g -> begin
4168: match doone (GFun(g, locUnknown)) with
4169: GFun(g', _) -> fl.globinit <- Some g'
4170: | _ -> E.s (E.bug "mapGlobals: globinit is not a function")
4171: end)
4172:
4173:
4174:
4175: let dumpFile (pp: cilPrinter) (out : out_channel) file =
4176: printDepth := 99999; (* We don't want ... in the output *)
4177: (* If we are in RELEASE mode then we do not print indentation *)
4178: (* AB: These flags are no longer used by Flx_cil_pretty *)
4179: (*
4180: noBreaks := true; noAligns := true;
4181: assert (noBreaks := false; noAligns := false; true);
4182: *)
4183: Flx_cil_pretty.fastMode := true;
4184: (* In debug mode the asserts are executed
4185: assert (Flx_cil_pretty.fastMode := false; true); *)
4186: if !E.verboseFlag then
4187: ignore (E.log "printing file %s\n" file.fileName);
4188: let print x = fprint out 78 x in
4189: print (text ("/* Generated by CIL v. " ^ cilVersion ^ " */\n" ^
4190: (* sm: I want to easily tell whether the generated output
4191: * is with print_CIL_Input or not *)
4192: "/* print_CIL_Input is " ^ (if !print_CIL_Input then "true" else "false") ^ " */\n\n"));
4193: iterGlobals file (fun g -> dumpGlobal pp out g);
4194:
4195: (* sm: we have to flush the output channel; if we don't then under *)
4196: (* some circumstances (I haven't figure out exactly when, but it happens *)
4197: (* more often with big inputs), we get a truncated output file *)
4198: flush out
4199:
4200:
4201:
4202: (******************
4203: ******************
4204: ******************)
4205:
4206:
4207:
4208: (******************** OPTIMIZATIONS *****)
4209: let rec peepHole1 (* Process one statement and possibly replace it *)
4210: (doone: instr -> instr list option)
4211: (* Scan a block and recurse inside nested blocks *)
4212: (ss: stmt list) : unit =
4213: let rec doInstrList (il: instr list) : instr list =
4214: match il with
4215: [] -> []
4216: | i :: rest -> begin
4217: match doone i with
4218: None -> i :: doInstrList rest
4219: | Some sl -> doInstrList (sl @ rest)
4220: end
4221: in
4222:
4223: List.iter
4224: (fun s ->
4225: match s.skind with
4226: Instr il -> s.skind <- Instr (doInstrList il)
4227: | If (e, tb, eb, _) ->
4228: peepHole1 doone tb.bstmts;
4229: peepHole1 doone eb.bstmts
4230: | Switch (e, b, _, _) -> peepHole1 doone b.bstmts
4231: | Loop (b, l, _, _) -> peepHole1 doone b.bstmts
4232: | Block b -> peepHole1 doone b.bstmts
4233: | TryFinally (b, h, l) ->
4234: peepHole1 doone b.bstmts;
4235: peepHole1 doone h.bstmts
4236: | TryExcept (b, (il, e), h, l) ->
4237: peepHole1 doone b.bstmts;
4238: peepHole1 doone h.bstmts;
4239: s.skind <- TryExcept(b, (doInstrList il, e), h, l);
4240: | Return _ | Goto _ | Break _ | Continue _ -> ())
4241: ss
4242:
4243: let rec peepHole2 (* Process two statements and possibly replace them both *)
4244: (dotwo: instr * instr -> instr list option)
4245: (ss: stmt list) : unit =
4246: let rec doInstrList (il: instr list) : instr list =
4247: match il with
4248: [] -> []
4249: | [i] -> [i]
4250: | (i1 :: ((i2 :: rest) as rest2)) ->
4251: begin
4252: match dotwo (i1,i2) with
4253: None -> i1 :: doInstrList rest2
4254: | Some sl -> doInstrList (sl @ rest)
4255: end
4256: in
4257: List.iter
4258: (fun s ->
4259: match s.skind with
4260: Instr il -> s.skind <- Instr (doInstrList il)
4261: | If (e, tb, eb, _) ->
4262: peepHole2 dotwo tb.bstmts;
4263: peepHole2 dotwo eb.bstmts
4264: | Switch (e, b, _, _) -> peepHole2 dotwo b.bstmts
4265: | Loop (b, l, _, _) -> peepHole2 dotwo b.bstmts
4266: | Block b -> peepHole2 dotwo b.bstmts
4267: | TryFinally (b, h, l) -> peepHole2 dotwo b.bstmts;
4268: peepHole2 dotwo h.bstmts
4269: | TryExcept (b, (il, e), h, l) ->
4270: peepHole2 dotwo b.bstmts;
4271: peepHole2 dotwo h.bstmts;
4272: s.skind <- TryExcept (b, (doInstrList il, e), h, l)
4273:
4274: | Return _ | Goto _ | Break _ | Continue _ -> ())
4275: ss
4276:
4277:
4278:
4279:
4280:
4281:
4282: let dExp: doc -> exp =
4283: fun d -> Const(CStr(sprint 80 d))
4284:
4285: let dInstr: doc -> location -> instr =
4286: fun d l -> Asm([], [sprint 80 d], [], [], [], l)
4287:
4288: let dGlobal: doc -> location -> global =
4289: fun d l -> GAsm(sprint 80 d, l)
4290:
4291: let rec addOffset (toadd: offset) (off: offset) : offset =
4292: match off with
4293: NoOffset -> toadd
4294: | Field(fid', offset) -> Field(fid', addOffset toadd offset)
4295: | Index(e, offset) -> Index(e, addOffset toadd offset)
4296:
4297: (* Add an offset at the end of an lv *)
4298: let addOffsetLval toadd (b, off) : lval =
4299: b, addOffset toadd off
4300:
4301: let rec removeOffset (off: offset) : offset * offset =
4302: match off with
4303: NoOffset -> NoOffset, NoOffset
4304: | Field(f, NoOffset) -> NoOffset, off
4305: | Index(i, NoOffset) -> NoOffset, off
4306: | Field(f, restoff) ->
4307: let off', last = removeOffset restoff in
4308: Field(f, off'), last
4309: | Index(i, restoff) ->
4310: let off', last = removeOffset restoff in
4311: Index(i, off'), last
4312:
4313: let removeOffsetLval ((b, off): lval) : lval * offset =
4314: let off', last = removeOffset off in
4315: (b, off'), last
4316:
4317: (* Make an AddrOf. Given an lval of type T will give back an expression of
4318: * type ptr(T) *)
4319: let mkAddrOf ((b, off) as lval) : exp =
4320: (* Never take the address of a register variable *)
4321: (match lval with
4322: Var vi, off when vi.vstorage = Register -> vi.vstorage <- NoStorage
4323: | _ -> ());
4324: match lval with
4325: Mem e, NoOffset -> e
4326: | b, Index(z, NoOffset) when isZero z -> StartOf (b, NoOffset)(* array *)
4327: | _ -> AddrOf lval
4328:
4329:
4330: let mkAddrOrStartOf (lv: lval) : exp =
4331: match unrollType (typeOfLval lv) with
4332: TArray _ -> StartOf lv
4333: | _ -> mkAddrOf lv
4334:
4335:
4336: (* Make a Mem, while optimizing AddrOf. The type of the addr must be
4337: * TPtr(t) and the type of the resulting lval is t. Note that in CIL the
4338: * implicit conversion between a function and a pointer to a function does
4339: * not apply. You must do the conversion yourself using AddrOf *)
4340: let mkMem ~(addr: exp) ~(off: offset) : lval =
4341: let res =
4342: match addr, off with
4343: AddrOf lv, _ -> addOffsetLval off lv
4344: | StartOf lv, _ -> (* Must be an array *)
4345: addOffsetLval (Index(zero, off)) lv
4346: | _, _ -> Mem addr, off
4347: in
4348: (* ignore (E.log "memof : %a:%a\nresult = %a\n"
4349: d_plainexp addr d_plainoffset off d_plainexp res); *)
4350: res
4351:
4352:
4353: let isIntegralType t =
4354: match unrollType t with
4355: (TInt _ | TEnum _) -> true
4356: | _ -> false
4357:
4358: let isArithmeticType t =
4359: match unrollType t with
4360: (TInt _ | TEnum _ | TFloat _) -> true
4361: | _ -> false
4362:
4363:
4364: let isPointerType t =
4365: match unrollType t with
4366: TPtr _ -> true
4367: | _ -> false
4368:
4369: let isFunctionType t =
4370: match unrollType t with
4371: TFun _ -> true
4372: | _ -> false
4373:
4374: let splitFunctionType (ftype: typ)
4375: : typ * (string * typ * attributes) list option * bool * attributes =
4376: match unrollType ftype with
4377: TFun (rt, args, isva, a) -> rt, args, isva, a
4378: | _ -> E.s (bug "splitFunctionType invoked on a non function type %a"
4379: d_type ftype)
4380:
4381: let splitFunctionTypeVI (fvi: varinfo)
4382: : typ * (string * typ * attributes) list option * bool * attributes =
4383: match unrollType fvi.vtype with
4384: TFun (rt, args, isva, a) -> rt, args, isva, a
4385: | _ -> E.s (bug "Function %s invoked on a non function type" fvi.vname)
4386:
4387: let isArrayType t =
4388: match unrollType t with
4389: TArray _ -> true
4390: | _ -> false
4391:
4392:
4393: let rec isConstant = function
4394: | Const _ -> true
4395: | UnOp (_, e, _) -> isConstant e
4396: | BinOp (_, e1, e2, _) -> isConstant e1 && isConstant e2
4397: | Lval (Var vi, NoOffset) ->
4398: (vi.vglob && isArrayType vi.vtype || isFunctionType vi.vtype)
4399: | Lval _ -> false
4400: | SizeOf _ | SizeOfE _ | SizeOfStr _ | AlignOf _ | AlignOfE _ -> true
4401: | CastE (_, e) -> isConstant e
4402: | AddrOf (Var vi, off) | StartOf (Var vi, off)
4403: -> vi.vglob && isConstantOff off
4404: | AddrOf (Mem e, off) | StartOf(Mem e, off)
4405: -> isConstant e && isConstantOff off
4406:
4407: and isConstantOff = function
4408: NoOffset -> true
4409: | Field(fi, off) -> isConstantOff off
4410: | Index(e, off) -> isConstant e && isConstantOff off
4411:
4412:
4413: let getCompField (cinfo:compinfo) (fieldName:string) : fieldinfo =
4414: (List.find (fun fi -> fi.fname = fieldName) cinfo.cfields)
4415:
4416:
4417: let rec mkCastT ~(e: exp) ~(oldt: typ) ~(newt: typ) =
4418: (* Do not remove old casts because they are conversions !!! *)
4419: if typeSig oldt = typeSig newt then begin
4420: e
4421: end else begin
4422: (* Watch out for constants *)
4423: match newt, e with
4424: TInt(newik, []), Const(CInt64(i, _, _)) -> kinteger64 newik i
4425: | _ -> CastE(newt,e)
4426: end
4427:
4428: let mkCast ~(e: exp) ~(newt: typ) =
4429: mkCastT e (typeOf e) newt
4430:
4431: type existsAction =
4432: ExistsTrue (* We have found it *)
4433: | ExistsFalse (* Stop processing this branch *)
4434: | ExistsMaybe (* This node is not what we are
4435: * looking for but maybe its
4436: * successors are *)
4437: let existsType (f: typ -> existsAction) (t: typ) : bool =
4438: let memo : (int, unit) H.t = H.create 17 in (* Memo table *)
4439: let rec loop t =
4440: match f t with
4441: ExistsTrue -> true
4442: | ExistsFalse -> false
4443: | ExistsMaybe ->
4444: (match t with
4445: TNamed (t', _) -> loop t'.ttype
4446: | TComp (c, _) -> loopComp c
4447: | TArray (t', _, _) -> loop t'
4448: | TPtr (t', _) -> loop t'
4449: | TFun (rt, args, _, _) ->
4450: (loop rt || List.exists (fun (_, at, _) -> loop at)
4451: (argsToList args))
4452: | _ -> false)
4453: and loopComp c =
4454: if H.mem memo c.ckey then
4455: (* We are looping, the answer must be false *)
4456: false
4457: else begin
4458: H.add memo c.ckey ();
4459: List.exists (fun f -> loop f.ftype) c.cfields
4460: end
4461: in
4462: loop t
4463:
4464: (**
4465: **
4466: ** MACHINE DEPENDENT PART
4467: **
4468: **)
4469: exception SizeOfError of typ
4470:
4471:
4472: (* Get the minimum aligment in bytes for a given type *)
4473: let rec alignOf_int = function
4474: | TInt((IChar|ISChar|IUChar), _) -> 1
4475: | TInt((IBool), _) -> !theMachine.alignof_cbool
4476: | TInt((IShort|IUShort), _) -> !theMachine.alignof_short
4477: | TInt((IInt|IUInt), _) -> !theMachine.alignof_int
4478: | TInt((ILong|IULong), _) -> !theMachine.alignof_long
4479: | TInt((ILongLong|IULongLong), _) -> !theMachine.alignof_longlong
4480: | TEnum _ -> !theMachine.alignof_enum
4481:
4482: | TFloat(FFloat, _) -> !theMachine.alignof_float
4483: | TFloat(FDouble, _) -> !theMachine.alignof_double
4484: | TFloat(FLongDouble, _) -> !theMachine.alignof_longdouble
4485:
4486: | TFloat(IFloat, _) -> !theMachine.alignof_imaginary
4487: | TFloat(IDouble, _) -> !theMachine.alignof_doubleimaginary
4488: | TFloat(ILongDouble, _) -> !theMachine.alignof_longdoubleimaginary
4489:
4490: | TFloat(CFloat, _) -> !theMachine.alignof_complex
4491: | TFloat(CDouble, _) -> !theMachine.alignof_doublecomplex
4492: | TFloat(CLongDouble, _) -> !theMachine.alignof_longdoublecomplex
4493:
4494: | TNamed (t, _) -> alignOf_int t.ttype
4495: | TArray (t, _, _) -> alignOf_int t
4496: | TPtr _ | TBuiltin_va_list _ -> !theMachine.sizeof_ptr
4497:
4498: (* For composite types get the maximum alignment of any field inside *)
4499: | TComp (c, _) ->
4500: (* On GCC the zero-width fields do not contribute to the alignment. On
4501: * MSVC only those zero-width that _do_ appear after other
4502: * bitfields contribute to the alignment. So we drop those that
4503: * do not occur after othe bitfields *)
4504: let rec dropZeros (afterbitfield: bool) = function
4505: | f :: rest when f.fbitfield = Some 0 && not afterbitfield ->
4506: dropZeros afterbitfield rest
4507: | f :: rest -> f :: dropZeros (f.fbitfield <> None) rest
4508: | [] -> []
4509: in
4510: let fields = dropZeros false c.cfields in
4511: List.fold_left
4512: (fun sofar f ->
4513: (* Bitfields with zero width do not contribute to the alignment in
4514: * GCC *)
4515: if not !msvcMode && f.fbitfield = Some 0 then sofar else
4516: max sofar (alignOf_int f.ftype)) 1 fields
4517: (* These are some error cases *)
4518: | TFun _ when not !msvcMode -> !theMachine.alignof_fun
4519:
4520: | (TFun _ | TVoid _) as t -> raise (SizeOfError t)
4521:
4522:
4523:
4524: type offsetAcc =
4525: { oaFirstFree: int; (* The first free bit *)
4526: oaLastFieldStart: int; (* Where the previous field started *)
4527: oaLastFieldWidth: int; (* The width of the previous field. Might not
4528: * be same as FirstFree - FieldStart because
4529: * of internal padding *)
4530: oaPrevBitPack: (int * ikind * int) option; (* If the previous fields
4531: * were packed bitfields,
4532: * the bit where packing
4533: * has started, the ikind
4534: * of the bitfield and the
4535: * width of the ikind *)
4536: }
4537:
4538:
4539: (* GCC version *)
4540: (* Does not use the sofar.oaPrevBitPack *)
4541: let rec offsetOfFieldAcc_GCC (fi: fieldinfo)
4542: (sofar: offsetAcc) : offsetAcc =
4543: (* field type *)
4544: let ftype = unrollType fi.ftype in
4545: let ftypeAlign = 8 * alignOf_int ftype in
4546: let ftypeBits = bitsSizeOf ftype in
4547: (*
4548: if fi.fcomp.cname = "comp2468" ||
4549: fi.fcomp.cname = "comp2469" ||
4550: fi.fcomp.cname = "comp2470" ||
4551: fi.fcomp.cname = "comp2471" ||
4552: fi.fcomp.cname = "comp2472" ||
4553: fi.fcomp.cname = "comp2473" ||
4554: fi.fcomp.cname = "comp2474" ||
4555: fi.fcomp.cname = "comp2475" ||
4556: fi.fcomp.cname = "comp2476" ||
4557: fi.fcomp.cname = "comp2477" ||
4558: fi.fcomp.cname = "comp2478" then
4559:
4560: ignore (E.log "offsetOfFieldAcc_GCC(%s of %s:%a%a,firstFree=%d,pack=%a)\n"
4561: fi.fname fi.fcomp.cname
4562: d_type ftype
4563: insert
4564: (match fi.fbitfield with
4565: None -> nil
4566: | Some wdthis -> dprintf ":%d" wdthis)
4567: sofar.oaFirstFree
4568: insert
4569: (match sofar.oaPrevBitPack with
4570: None -> text "None"
4571: | Some (packstart, _, wdpack) ->
4572: dprintf "Some(packstart=%d,wd=%d)"
4573: packstart wdpack));
4574: *)
4575: match ftype, fi.fbitfield with
4576: (* A width of 0 means that we must end the current packing. It seems that
4577: * GCC pads only up to the alignment boundary for the type of this field.
4578: * *)
4579: | _, Some 0 ->
4580: let firstFree = addTrailing sofar.oaFirstFree ftypeAlign in
4581: { oaFirstFree = firstFree;
4582: oaLastFieldStart = firstFree;
4583: oaLastFieldWidth = 0;
4584: oaPrevBitPack = None }
4585:
4586: (* A bitfield cannot span more alignment boundaries of its type than the
4587: * type itself *)
4588: | _, Some wdthis
4589: when (sofar.oaFirstFree + wdthis + ftypeAlign - 1) / ftypeAlign
4590: - sofar.oaFirstFree / ftypeAlign > ftypeBits / ftypeAlign ->
4591: let start = addTrailing sofar.oaFirstFree ftypeAlign in
4592: { oaFirstFree = start + wdthis;
4593: oaLastFieldStart = start;
4594: oaLastFieldWidth = wdthis;
4595: oaPrevBitPack = None }
4596:
4597: (* Try a simple method. Just put the field down *)
4598: | _, Some wdthis ->
4599: { oaFirstFree = sofar.oaFirstFree + wdthis;
4600: oaLastFieldStart = sofar.oaFirstFree;
4601: oaLastFieldWidth = wdthis;
4602: oaPrevBitPack = None
4603: }
4604:
4605: (* Non-bitfield *)
4606: | _, None ->
4607: (* Align this field *)
4608: let newStart = addTrailing sofar.oaFirstFree ftypeAlign in
4609: { oaFirstFree = newStart + ftypeBits;
4610: oaLastFieldStart = newStart;
4611: oaLastFieldWidth = ftypeBits;
4612: oaPrevBitPack = None;
4613: }
4614:
4615: (* MSVC version *)
4616: and offsetOfFieldAcc_MSVC (fi: fieldinfo)
4617: (sofar: offsetAcc) : offsetAcc =
4618: (* field type *)
4619: let ftype = unrollType fi.ftype in
4620: let ftypeAlign = 8 * alignOf_int ftype in
4621: let ftypeBits = bitsSizeOf ftype in
4622: (*
4623: ignore (E.log "offsetOfFieldAcc_MSVC(%s of %s:%a%a,firstFree=%d, pack=%a)\n"
4624: fi.fname fi.fcomp.cname
4625: d_type ftype
4626: insert
4627: (match fi.fbitfield with
4628: None -> nil
4629: | Some wdthis -> dprintf ":%d" wdthis)
4630: sofar.oaFirstFree
4631: insert
4632: (match sofar.oaPrevBitPack with
4633: None -> text "None"
4634: | Some (prevpack, _, wdpack) -> dprintf "Some(prev=%d,wd=%d)"
4635: prevpack wdpack));
4636: *)
4637: match ftype, fi.fbitfield, sofar.oaPrevBitPack with
4638: (* Ignore zero-width bitfields that come after non-bitfields *)
4639: | TInt (ikthis, _), Some 0, None ->
4640: let firstFree = sofar.oaFirstFree in
4641: { oaFirstFree = firstFree;
4642: oaLastFieldStart = firstFree;
4643: oaLastFieldWidth = 0;
4644: oaPrevBitPack = None }
4645:
4646: (* If we are in a bitpack and we see a bitfield for a type with the
4647: * different width than the pack, then we finish the pack and retry *)
4648: | _, Some _, Some (packstart, _, wdpack) when wdpack != ftypeBits ->
4649: let firstFree =
4650: if sofar.oaFirstFree = packstart then packstart else
4651: packstart + wdpack
4652: in
4653: offsetOfFieldAcc_MSVC fi
4654: { oaFirstFree = addTrailing firstFree ftypeAlign;
4655: oaLastFieldStart = sofar.oaLastFieldStart;
4656: oaLastFieldWidth = sofar.oaLastFieldWidth;
4657: oaPrevBitPack = None }
4658:
4659: (* A width of 0 means that we must end the current packing. *)
4660: | TInt (ikthis, _), Some 0, Some (packstart, _, wdpack) ->
4661: let firstFree =
4662: if sofar.oaFirstFree = packstart then packstart else
4663: packstart + wdpack
4664: in
4665: let firstFree = addTrailing firstFree ftypeAlign in
4666: { oaFirstFree = firstFree;
4667: oaLastFieldStart = firstFree;
4668: oaLastFieldWidth = 0;
4669: oaPrevBitPack = Some (firstFree, ikthis, ftypeBits) }
4670:
4671: (* Flx_cil_check for a bitfield that fits in the current pack after some other
4672: * bitfields *)
4673: | TInt(ikthis, _), Some wdthis, Some (packstart, ikprev, wdpack)
4674: when packstart + wdpack >= sofar.oaFirstFree + wdthis ->
4675: { oaFirstFree = sofar.oaFirstFree + wdthis;
4676: oaLastFieldStart = sofar.oaFirstFree;
4677: oaLastFieldWidth = wdthis;
4678: oaPrevBitPack = sofar.oaPrevBitPack
4679: }
4680:
4681:
4682: | _, _, Some (packstart, _, wdpack) -> (* Finish up the bitfield pack and
4683: * restart. *)
4684: let firstFree =
4685: if sofar.oaFirstFree = packstart then packstart else
4686: packstart + wdpack
4687: in
4688: offsetOfFieldAcc_MSVC fi
4689: { oaFirstFree = addTrailing firstFree ftypeAlign;
4690: oaLastFieldStart = sofar.oaLastFieldStart;
4691: oaLastFieldWidth = sofar.oaLastFieldWidth;
4692: oaPrevBitPack = None }
4693:
4694: (* No active bitfield pack. But we are seeing a bitfield. *)
4695: | TInt(ikthis, _), Some wdthis, None ->
4696: let firstFree = addTrailing sofar.oaFirstFree ftypeAlign in
4697: { oaFirstFree = firstFree + wdthis;
4698: oaLastFieldStart = firstFree;
4699: oaLastFieldWidth = wdthis;
4700: oaPrevBitPack = Some (firstFree, ikthis, ftypeBits); }
4701:
4702: (* No active bitfield pack. Non-bitfield *)
4703: | _, None, None ->
4704: (* Align this field *)
4705: let firstFree = addTrailing sofar.oaFirstFree ftypeAlign in
4706: { oaFirstFree = firstFree + ftypeBits;
4707: oaLastFieldStart = firstFree;
4708: oaLastFieldWidth = ftypeBits;
4709: oaPrevBitPack = None;
4710: }
4711:
4712: | _, Some _, None -> E.s (E.bug "offsetAcc")
4713:
4714:
4715: and offsetOfFieldAcc ~(fi: fieldinfo)
4716: ~(sofar: offsetAcc) : offsetAcc =
4717: if !msvcMode then offsetOfFieldAcc_MSVC fi sofar
4718: else offsetOfFieldAcc_GCC fi sofar
4719:
4720: (* The size of a type, in bits. If struct or array then trailing padding is
4721: * added *)
4722: and bitsSizeOf t =
4723: match t with
4724: (* For long long sometimes the alignof and sizeof are different *)
4725: | TInt((ILongLong|IULongLong), _) -> 8 * !theMachine.sizeof_longlong
4726: | TFloat(FDouble, _) -> 8 * 8
4727: | TFloat(FLongDouble, _) -> 8 * !theMachine.sizeof_longdouble
4728: | TInt _ | TFloat _ | TEnum _ | TPtr _ | TBuiltin_va_list _
4729: -> 8 * alignOf_int t
4730: | TNamed (t, _) -> bitsSizeOf t.ttype
4731: | TComp (comp, _) when comp.cfields = [] -> begin
4732: (* Empty structs are allowed in msvc mode *)
4733: if not comp.cdefined && not !msvcMode then
4734: raise (SizeOfError t) (*abstract type*)
4735: else
4736: 0
4737: end
4738:
4739: | TComp (comp, _) when comp.cstruct -> (* Struct *)
4740: (* Go and get the last offset *)
4741: let startAcc =
4742: { oaFirstFree = 0;
4743: oaLastFieldStart = 0;
4744: oaLastFieldWidth = 0;
4745: oaPrevBitPack = None;
4746: } in
4747: let lastoff =
4748: List.fold_left (fun acc fi -> offsetOfFieldAcc ~fi ~sofar:acc)
4749: startAcc comp.cfields
4750: in
4751: if !msvcMode && lastoff.oaFirstFree = 0 && comp.cfields <> [] then
4752: (* On MSVC if we have just a zero-width bitfields then the length
4753: * is 32 and is not padded *)
4754: 32
4755: else
4756: addTrailing lastoff.oaFirstFree (8 * alignOf_int t)
4757:
4758: | TComp (comp, _) -> (* when not comp.cstruct *)
4759: (* Get the maximum of all fields *)
4760: let startAcc =
4761: { oaFirstFree = 0;
4762: oaLastFieldStart = 0;
4763: oaLastFieldWidth = 0;
4764: oaPrevBitPack = None;
4765: } in
4766: let max =
4767: List.fold_left (fun acc fi ->
4768: let lastoff = offsetOfFieldAcc ~fi ~sofar:startAcc in
4769: if lastoff.oaFirstFree > acc then
4770: lastoff.oaFirstFree else acc) 0 comp.cfields in
4771: (* Add trailing by simulating adding an extra field *)
4772: addTrailing max (8 * alignOf_int t)
4773:
4774: | TArray(t, Some len, _) -> begin
4775: match constFold true len with
4776: Const(CInt64(l,_,_)) ->
4777: addTrailing ((bitsSizeOf t) * (Int64.to_int l)) (8 * alignOf_int t)
4778: | _ -> raise (SizeOfError t)
4779: end
4780:
4781:
4782: | TVoid _ -> 8 * !theMachine.sizeof_void
4783: | TFun _ when not !msvcMode -> (* On GCC the size of a function is defined *)
4784: 8 * !theMachine.sizeof_fun
4785:
4786: | TArray (_, None, _) | TFun _ -> raise (SizeOfError t)
4787:
4788:
4789: and addTrailing nrbits roundto =
4790: (nrbits + roundto - 1) land (lnot (roundto - 1))
4791:
4792: and sizeOf t =
4793: try
4794: integer ((bitsSizeOf t) lsr 3)
4795: with SizeOfError _ -> SizeOf(t)
4796:
4797:
4798: and bitsOffset (baset: typ) (off: offset) : int * int =
4799: let rec loopOff (baset: typ) (width: int) (start: int) = function
4800: NoOffset -> start, width
4801: | Index(e, off) -> begin
4802: let ei =
4803: match isInteger e with
4804: Some i64 -> Int64.to_int i64
4805: | None -> raise (SizeOfError baset)
4806: in
4807: let bt =
4808: match unrollType baset with
4809: TArray(bt, _, _) -> bt
4810: | _ -> E.s (E.bug "bitsOffset: Index on a non-array")
4811: in
4812: let bitsbt = bitsSizeOf bt in
4813: loopOff bt bitsbt (start + ei * bitsbt) off
4814: end
4815: | Field(f, off) when not f.fcomp.cstruct ->
4816: (* All union fields start at offset 0 *)
4817: loopOff f.ftype (bitsSizeOf f.ftype) start off
4818:
4819: | Field(f, off) ->
4820: (* Construct a list of fields preceeding and including this one *)
4821: let prevflds =
4822: let rec loop = function
4823: [] -> E.s (E.bug "bitsOffset: Cannot find field %s in %s\n"
4824: f.fname f.fcomp.cname)
4825: | fi' :: _ when fi' == f -> [fi']
4826: | fi' :: rest -> fi' :: loop rest
4827: in
4828: loop f.fcomp.cfields
4829: in
4830: let lastoff =
4831: List.fold_left (fun acc fi' -> offsetOfFieldAcc ~fi:fi' ~sofar:acc)
4832: { oaFirstFree = 0; (* Start at 0 because each struct is done
4833: * separately *)
4834: oaLastFieldStart = 0;
4835: oaLastFieldWidth = 0;
4836: oaPrevBitPack = None } prevflds
4837: in
4838: (* ignore (E.log "Field %s of %s: start=%d, lastFieldStart=%d\n"
4839: f.fname f.fcomp.cname start lastoff.oaLastFieldStart); *)
4840: loopOff f.ftype lastoff.oaLastFieldWidth
4841: (start + lastoff.oaLastFieldStart) off
4842: in
4843: loopOff baset (bitsSizeOf baset) 0 off
4844:
4845:
4846:
4847:
4848: (*** Constant folding. If machdep is true then fold even sizeof operations ***)
4849: and constFold (machdep: bool) (e: exp) : exp =
4850: match e with
4851: BinOp(bop, e1, e2, tres) -> constFoldBinOp machdep bop e1 e2 tres
4852: | UnOp(unop, e1, tres) -> begin
4853: try
4854: let tk =
4855: match unrollType tres with
4856: TInt(ik, _) -> ik
4857: | TEnum _ -> IInt
4858: | _ -> raise Not_found (* probably a float *)
4859: in
4860: match constFold machdep e1 with
4861: Const(CInt64(i,ik,_)) as e1c -> begin
4862: match unop with
4863: Neg -> kinteger64 tk (Int64.neg i)
4864: | BNot -> kinteger64 tk (Int64.lognot i)
4865: | LNot -> if i = Int64.zero then one else zero
4866: end
4867: | e1c -> UnOp(unop, e1c, tres)
4868: with Not_found -> e
4869: end
4870: (* Characters are integers *)
4871: | Const(CChr c) -> Const(CInt64(Int64.of_int (Char.code c),
4872: IInt, None))
4873: | SizeOf t when machdep -> begin
4874: try
4875: let bs = bitsSizeOf t in
4876: kinteger !kindOfSizeOf (bs / 8)
4877: with SizeOfError _ -> e
4878: end
4879: | SizeOfE e when machdep -> constFold machdep (SizeOf (typeOf e))
4880: | SizeOfStr s when machdep -> kinteger !kindOfSizeOf (1 + String.length s)
4881: | AlignOf t when machdep -> kinteger !kindOfSizeOf (alignOf_int t)
4882: | AlignOfE e when machdep -> begin
4883: (* The alignmetn of an expression is not always the alignment of its
4884: * type. I know that for strings this is not true *)
4885: match e with
4886: Const (CStr _) when not !msvcMode ->
4887: kinteger !kindOfSizeOf !theMachine.alignof_str
4888: (* For an array, it is the alignment of the array ! *)
4889: | _ -> constFold machdep (AlignOf (typeOf e))
4890: end
4891:
4892: | CastE (t, e) -> begin
4893: match constFold machdep e, unrollType t with
4894: (* Might truncate silently *)
4895: Const(CInt64(i,k,_)), TInt(nk,_) ->
4896: let i' = truncateInteger64 nk i in
4897: Const(CInt64(i', nk, None))
4898: | e', _ -> CastE (t, e')
4899: end
4900:
4901: | _ -> e
4902:
4903: and constFoldBinOp (machdep: bool) bop e1 e2 tres =
4904: let e1' = constFold machdep e1 in
4905: let e2' = constFold machdep e2 in
4906: if isIntegralType tres then begin
4907: let newe =
4908: let rec mkInt = function
4909: Const(CChr c) -> Const(CInt64(Int64.of_int (Char.code c),
4910: IInt, None))
4911: | CastE(TInt (ik, ta), e) -> begin
4912: match mkInt e with
4913: Const(CInt64(i, _, _)) ->
4914: let i' = truncateInteger64 ik i in
4915: Const(CInt64(i', ik, None))
4916:
4917: | e' -> CastE(TInt(ik, ta), e')
4918: end
4919: | e -> e
4920: in
4921: let tk =
4922: match unrollType tres with
4923: TInt(ik, _) -> ik
4924: | TEnum _ -> IInt
4925: | _ -> E.s (bug "constFoldBinOp")
4926: in
4927: (* See if the result is unsigned *)
4928: let isunsigned typ = not (isSigned typ) in
4929: let ge (unsigned: bool) (i1: int64) (i2: int64) : bool =
4930: if unsigned then
4931: let l1 = Int64.shift_right_logical i1 1 in
4932: let l2 = Int64.shift_right_logical i2 1 in (* Both positive now *)
4933: (l1 > l2) || (l1 = l2 &&
4934: Int64.logand i1 Int64.one >= Int64.logand i2 Int64.one)
4935: else i1 >= i2
4936: in
4937: (* Assume that the necessary promotions have been done *)
4938: match bop, mkInt e1', mkInt e2' with
4939: | PlusA, Const(CInt64(z,_,_)), e2'' when z = Int64.zero -> e2''
4940: | PlusA, e1'', Const(CInt64(z,_,_)) when z = Int64.zero -> e1''
4941: | PlusPI, e1'', Const(CInt64(z,_,_)) when z = Int64.zero -> e1''
4942: | IndexPI, e1'', Const(CInt64(z,_,_)) when z = Int64.zero -> e1''
4943: | MinusPI, e1'', Const(CInt64(z,_,_)) when z = Int64.zero -> e1''
4944: | PlusA, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
4945: kinteger64 tk (Int64.add i1 i2)
4946: | MinusA, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
4947: kinteger64 tk (Int64.sub i1 i2)
4948: | Mult, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
4949: kinteger64 tk (Int64.mul i1 i2)
4950: | Div, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> begin
4951: try kinteger64 tk (Int64.div i1 i2)
4952: with Division_by_zero -> BinOp(bop, e1', e2', tres)
4953: end
4954: | Mod, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> begin
4955: try kinteger64 tk (Int64.rem i1 i2)
4956: with Division_by_zero -> BinOp(bop, e1', e2', tres)
4957: end
4958: | BAnd, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
4959: kinteger64 tk (Int64.logand i1 i2)
4960: | BOr, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
4961: kinteger64 tk (Int64.logor i1 i2)
4962: | BXor, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
4963: kinteger64 tk (Int64.logxor i1 i2)
4964: | Shiftlt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,IInt,_)) ->
4965: kinteger64 tk (Int64.shift_left i1 (Int64.to_int i2))
4966: | Shiftrt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,IInt,_)) ->
4967: if isunsigned ik1 then
4968: kinteger64 tk (Int64.shift_right_logical i1 (Int64.to_int i2))
4969: else
4970: kinteger64 tk (Int64.shift_right i1 (Int64.to_int i2))
4971:
4972: | Eq, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
4973: integer (if i1 = i2 then 1 else 0)
4974: | Ne, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
4975: integer (if i1 <> i2 then 1 else 0)
4976: | Le, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
4977: integer (if ge (isunsigned ik1) i2 i1 then 1 else 0)
4978:
4979: | Ge, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
4980: integer (if ge (isunsigned ik1) i1 i2 then 1 else 0)
4981:
4982: | Lt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
4983: integer (if i1 <> i2 && ge (isunsigned ik1) i2 i1 then 1 else 0)
4984:
4985: | Gt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
4986: integer (if i1 <> i2 && ge (isunsigned ik1) i1 i2 then 1 else 0)
4987: | LAnd, _, _ when isZero e1' || isZero e2' -> zero
4988: | LOr, _, _ when isZero e1' -> e2'
4989: | LOr, _, _ when isZero e2' -> e1'
4990: | _ -> BinOp(bop, e1', e2', tres)
4991: in
4992: if debugConstFold then
4993: ignore (E.log "Folded %a to %a\n" d_exp (BinOp(bop, e1', e2', tres)) d_exp newe);
4994: newe
4995: end else
4996: BinOp(bop, e1', e2', tres)
4997:
4998:
4999: (* Try to do an increment, with constant folding *)
5000: let increm (e: exp) (i: int) =
5001: let et = typeOf e in
5002: let bop = if isPointerType et then PlusPI else PlusA in
5003: constFold false (BinOp(bop, e, integer i, et))
5004:
5005: exception LenOfArray
5006: let lenOfArray (eo: exp option) : int =
5007: match eo with
5008: None -> raise LenOfArray
5009: | Some e -> begin
5010: match constFold true e with
5011: | Const(CInt64(ni, _, _)) when ni >= Int64.zero ->
5012: Int64.to_int ni
5013: | e -> raise LenOfArray
5014: end
5015:
5016:
5017: (*** Make a initializer for zeroe-ing a data type ***)
5018: let rec makeZeroInit (t: typ) : init =
5019: match unrollType t with
5020: TInt (ik, _) -> SingleInit (Const(CInt64(Int64.zero, ik, None)))
5021: | TFloat(fk, _) -> SingleInit(Const(CReal(0.0, fk, None)))
5022: | TEnum _ -> SingleInit zero
5023: | TComp (comp, _) as t' when comp.cstruct ->
5024: let inits =
5025: List.fold_right
5026: (fun f acc ->
5027: if f.fname <> missingFieldName then
5028: (Field(f, NoOffset), makeZeroInit f.ftype) :: acc
5029: else
5030: acc)
5031: comp.cfields []
5032: in
5033: CompoundInit (t', inits)
5034:
5035: | TComp (comp, _) as t' when not comp.cstruct ->
5036: let fstfield =
5037: match comp.cfields with
5038: f :: _ -> f
5039: | [] -> E.s (unimp "Cannot create init for empty union")
5040: in
5041: CompoundInit(t, [(Field(fstfield, NoOffset),
5042: makeZeroInit fstfield.ftype)])
5043:
5044: | TArray(bt, Some len, _) as t' ->
5045: let n =
5046: match constFold true len with
5047: Const(CInt64(n, _, _)) -> Int64.to_int n
5048: | _ -> E.s (E.unimp "Cannot understand length of array")
5049: in
5050: let initbt = makeZeroInit bt in
5051: let rec loopElems acc i =
5052: if i < 0 then acc
5053: else loopElems ((Index(integer i, NoOffset), initbt) :: acc) (i - 1)
5054: in
5055: CompoundInit(t', loopElems [] (n - 1))
5056:
5057: | TArray (bt, None, at) as t' ->
5058: (* Unsized array, allow it and fill it in later
5059: * (see cabs2cil.ml, collectInitializer) *)
5060: CompoundInit (t', [])
5061:
5062: | TPtr _ as t -> SingleInit(CastE(t, zero))
5063: | x -> E.s (unimp "Cannot initialize type: %a" d_type x)
5064:
5065:
5066: (**** Fold over the list of initializers in a Compound. In the case of an
5067: * array initializer only the initializers present are scanned (a prefix of
5068: * all initializers) *)
5069: let foldLeftCompound
5070: ~(doinit: offset -> init -> typ -> 'a -> 'a)
5071: ~(ct: typ)
5072: ~(initl: (offset * init) list)
5073: ~(acc: 'a) : 'a =
5074: match unrollType ct with
5075: TArray(bt, _, _) ->
5076: List.fold_left (fun acc (o, i) -> doinit o i bt acc) acc initl
5077:
5078: | TComp (comp, _) ->
5079: let getTypeOffset = function
5080: Field(f, NoOffset) -> f.ftype
5081: | _ -> E.s (bug "foldLeftCompound: malformed initializer")
5082: in
5083: List.fold_left
5084: (fun acc (o, i) -> doinit o i (getTypeOffset o) acc) acc initl
5085:
5086: | _ -> E.s (unimp "Type of Compound is not array or struct or union")
5087:
5088: (**** Fold over the list of initializers in a Compound. Like foldLeftCompound
5089: * but scans even the zero-initializers that are missing at the end of the
5090: * array *)
5091: let foldLeftCompoundAll
5092: ~(doinit: offset -> init -> typ -> 'a -> 'a)
5093: ~(ct: typ)
5094: ~(initl: (offset * init) list)
5095: ~(acc: 'a) : 'a =
5096: match unrollType ct with
5097: TArray(bt, leno, _) -> begin
5098: let part =
5099: List.fold_left (fun acc (o, i) -> doinit o i bt acc) acc initl in
5100: (* See how many more we have to do *)
5101: match leno with
5102: Some lene -> begin
5103: match constFold true lene with
5104: Const(CInt64(i, _, _)) ->
5105: let len_array = Int64.to_int i in
5106: let len_init = List.length initl in
5107: if len_array > len_init then
5108: let zi = makeZeroInit bt in
5109: let rec loop acc i =
5110: if i >= len_array then acc
5111: else
5112: loop (doinit (Index(integer i, NoOffset)) zi bt acc)
5113: (i + 1)
5114: in
5115: loop part (len_init + 1)
5116: else
5117: part
5118: | _ -> E.s (unimp "foldLeftCompoundAll: array with initializer and non-constant length\n")
5119: end
5120:
5121: | _ -> E.s (unimp "foldLeftCompoundAll: TArray with initializer and no length")
5122: end
5123: | TComp (comp, _) ->
5124: let getTypeOffset = function
5125: Field(f, NoOffset) -> f.ftype
5126: | _ -> E.s (bug "foldLeftCompound: malformed initializer")
5127: in
5128: List.fold_left
5129: (fun acc (o, i) -> doinit o i (getTypeOffset o) acc) acc initl
5130:
5131: | _ -> E.s (E.unimp "Type of Compound is not array or struct or union")
5132:
5133:
5134:
5135: let rec isCompleteType t =
5136: match unrollType t with
5137: | TArray(t, None, _) -> false
5138: | TArray(t, Some z, _) when isZero z -> false
5139: | TComp (comp, _) -> (* Struct or union *)
5140: List.for_all (fun fi -> isCompleteType fi.ftype) comp.cfields
5141: | _ -> true
5142:
5143:
5144:
5145: let debugAlpha (prefix: string) = false
5146: (*** Alpha conversion ***)
5147: let alphaSeparator = "___"
5148: let alphaSeparatorLen = String.length alphaSeparator
5149:
5150: (** For each prefix we remember the list of suffixes and the next integer
5151: * suffix to use *)
5152: type alphaTableData = int * (string * location) list
5153:
5154: type undoAlphaElement =
5155: AlphaChangedSuffix of alphaTableData ref * alphaTableData (* The
5156: * reference that was changed and
5157: * the old suffix *)
5158: | AlphaAddedSuffix of string (* We added this new entry to the
5159: * table *)
5160:
5161: (* Create a new name based on a given name. The new name is formed from a
5162: * prefix (obtained from the given name by stripping a suffix consisting of
5163: * the alphaSeparator followed by only digits), followed by alphaSeparator
5164: * and then by a positive integer suffix. The first argument is a table
5165: * mapping name prefixes to the largest suffix used so far for that
5166: * prefix. The largest suffix is one when only the version without suffix has
5167: * been used. *)
5168: let rec newAlphaName ~(alphaTable: (string, alphaTableData ref) H.t)
5169: ~(undolist: undoAlphaElement list ref option)
5170: ~(lookupname: string) : string * location =
5171: alphaWorker ~alphaTable:alphaTable ~undolist:undolist
5172: ~lookupname:lookupname true
5173:
5174:
5175: (** Just register the name so that we will not use in the future *)
5176: and registerAlphaName ~(alphaTable: (string, alphaTableData ref) H.t)
5177: ~(undolist: undoAlphaElement list ref option)
5178: ~(lookupname: string) : unit =
5179: ignore (alphaWorker ~alphaTable:alphaTable ~undolist:undolist
5180: ~lookupname:lookupname false)
5181:
5182:
5183: and alphaWorker ~(alphaTable: (string, alphaTableData ref) H.t)
5184: ~(undolist: undoAlphaElement list ref option)
5185: ~(lookupname: string)
5186: (make_new: bool) : string * location =
5187: let prefix, suffix, (numsuffix: int) = splitNameForAlpha ~lookupname in
5188: if debugAlpha prefix then
5189: ignore (E.log "Alpha worker: prefix=%s suffix=%s (%d) create=%b. "
5190: prefix suffix numsuffix make_new);
5191: let newname, (oldloc: location) =
5192: try
5193: let rc = H.find alphaTable prefix in
5194: let max, suffixes = !rc in
5195: (* We have seen this prefix *)
5196: if debugAlpha prefix then
5197: ignore (E.log " Old max %d. Old suffixes: @[%a@]" max
5198: (docList (chr ',')
5199: (fun (s, l) -> dprintf "%a:%s" d_loc l s)) suffixes);
5200: (* Save the undo info *)
5201: (match undolist with
5202: Some l -> l := AlphaChangedSuffix (rc, !rc) :: !l
5203: | _ -> ());
5204:
5205: let newmax, newsuffix, (oldloc: location), newsuffixes =
5206: if numsuffix > max then begin
5207: (* Clearly we have not seen it *)
5208: numsuffix, suffix, !currentLoc,
5209: (suffix, !currentLoc) :: suffixes
5210: end else begin
5211: match List.filter (fun (n, _) -> n = suffix) suffixes with
5212: [] -> (* Not found *)
5213: max, suffix, !currentLoc, (suffix, !currentLoc) :: suffixes
5214: | [(_, l) ] ->
5215: (* We have seen this exact suffix before *)
5216: if make_new then
5217: let newsuffix = alphaSeparator ^ (string_of_int (max + 1)) in
5218: max + 1, newsuffix, l, (newsuffix, !currentLoc) :: suffixes
5219: else
5220: max, suffix, !currentLoc, suffixes
5221: | _ -> E.s (E.bug "Flx_cil_cil.alphaWorker")
5222: end
5223: in
5224: rc := (newmax, newsuffixes);
5225: prefix ^ newsuffix, oldloc
5226: with Not_found -> begin (* First variable with this prefix *)
5227: (match undolist with
5228: Some l -> l := AlphaAddedSuffix prefix :: !l
5229: | _ -> ());
5230: H.add alphaTable prefix (ref (numsuffix, [ (suffix, !currentLoc) ]));
5231: if debugAlpha prefix then ignore (E.log " First seen. ");
5232: lookupname, !currentLoc (* Return the original name *)
5233: end
5234: in
5235: if debugAlpha prefix then
5236: ignore (E.log " Res=: %s (%a)\n" newname d_loc oldloc);
5237: newname, oldloc
5238:
5239: (* Strip the suffix. Return the prefix, the suffix (including the separator
5240: * and the numeric value, possibly empty), and the
5241: * numeric value of the suffix (possibly -1 if missing) *)
5242: and splitNameForAlpha ~(lookupname: string) : (string * string * int) =
5243: let len = String.length lookupname in
5244: (* Search backward for the numeric suffix. Return the first digit of the
5245: * suffix. Returns len if no numeric suffix *)
5246: let rec skipSuffix (i: int) =
5247: if i = -1 then -1 else
5248: let c = Char.code (String.get lookupname i) - Char.code '0' in
5249: if c >= 0 && c <= 9 then
5250: skipSuffix (i - 1)
5251: else (i + 1)
5252: in
5253: let startSuffix = skipSuffix (len - 1) in
5254:
5255: if startSuffix >= len (* No digits at all at the end *) ||
5256: startSuffix <= alphaSeparatorLen (* Not enough room for a prefix and
5257: * the separator before suffix *) ||
5258: (* Suffix starts with a 0 and has more characters after that *)
5259: (startSuffix < len - 1 && String.get lookupname startSuffix = '0') ||
5260: alphaSeparator <> String.sub lookupname
5261: (startSuffix - alphaSeparatorLen)
5262: alphaSeparatorLen
5263: then
5264: (lookupname, "", -1) (* No valid suffix in the name *)
5265: else
5266: (String.sub lookupname 0 (startSuffix - alphaSeparatorLen),
5267: String.sub lookupname (startSuffix - alphaSeparatorLen)
5268: (len - startSuffix + alphaSeparatorLen),
5269: int_of_string (String.sub lookupname startSuffix (len - startSuffix)))
5270:
5271:
5272: let getAlphaPrefix ~(lookupname:string) : string =
5273: let p, _, _ = splitNameForAlpha ~lookupname:lookupname in
5274: p
5275:
5276: (* Undoes the changes as specified by the undolist *)
5277: let undoAlphaChanges ~(alphaTable: (string, alphaTableData ref) H.t)
5278: ~(undolist: undoAlphaElement list) =
5279: List.iter
5280: (function
5281: AlphaChangedSuffix (where, old) ->
5282: where := old
5283: | AlphaAddedSuffix name ->
5284: if debugAlpha name then
5285: ignore (E.log "Removing %s from alpha table\n" name);
5286: H.remove alphaTable name)
5287: undolist
5288:
5289: let docAlphaTable () (alphaTable: (string, alphaTableData ref) H.t) =
5290: let acc : (string * (int * (string * location) list)) list ref = ref [] in
5291: H.iter (fun k d -> acc := (k, !d) :: !acc) alphaTable;
5292: docList line (fun (k, (d, _)) -> dprintf " %s -> %d" k d) () !acc
5293:
5294:
5295: (** Uniquefy the variable names *)
5296: let uniqueVarNames (f: file) : unit =
5297: (* Setup the alpha conversion table for globals *)
5298: let gAlphaTable: (string, alphaTableData ref) H.t = H.create 113 in
5299: (* Keep also track of the global names that we have used. Map them to the
5300: * variable ID. We do this only to check that we do not have two globals
5301: * with the same name. *)
5302: let globalNames: (string, int) H.t = H.create 113 in
5303: (* Scan the file and add the global names to the table *)
5304: iterGlobals f
5305: (function
5306: GVarDecl(vi, l)
5307: | GVar(vi, _, l)
5308: | GFun({svar = vi}, l) ->
5309: (* See if we have used this name already for something else *)
5310: (try
5311: let oldid = H.find globalNames vi.vname in
5312: if oldid <> vi.vid then
5313: ignore (warn "The name %s is used for two distinct globals"
5314: vi.vname);
5315: (* Here if we have used this name already. Go ahead *)
5316: ()
5317: with Not_found -> begin
5318: (* Here if this is the first time we define a name *)
5319: H.add globalNames vi.vname vi.vid;
5320: (* And register it *)
5321: registerAlphaName gAlphaTable None vi.vname;
5322: ()
5323: end)
5324: | _ -> ());
5325:
5326: (* Now we must scan the function bodies and rename the locals *)
5327: iterGlobals f
5328: (function
5329: GFun(fdec, l) -> begin
5330: currentLoc := l;
5331: (* Setup an undo list to be able to revert the changes to the
5332: * global alpha table *)
5333: let undolist = ref [] in
5334: (* Process one local variable *)
5335: let processLocal (v: varinfo) =
5336: let newname, oldloc =
5337: newAlphaName gAlphaTable (Some undolist) v.vname in
5338: if false && newname <> v.vname then (* Disable this warning *)
5339: ignore (warn "uniqueVarNames: Changing the name of local %s in %s to %s (due to duplicate at %a)\n"
5340: v.vname fdec.svar.vname newname d_loc oldloc);
5341: v.vname <- newname
5342: in
5343: (* Do the formals first *)
5344: List.iter processLocal fdec.sformals;
5345: (* Fix the type again *)
5346: setFormals fdec fdec.sformals;
5347: (* And now the locals *)
5348: List.iter processLocal fdec.slocals;
5349: (* Undo the changes to the global table *)
5350: undoAlphaChanges gAlphaTable !undolist;
5351: ()
5352: end
5353: | _ -> ());
5354: ()
5355:
5356:
5357: (* A visitor that makes a deep copy of a function body *)
5358: class copyFunctionVisitor (newname: string) = object (self)
5359: inherit nopCilVisitor
5360:
5361: (* Keep here a maping from locals to their copies *)
5362: val map : (string, varinfo) H.t = H.create 113
5363: (* Keep here a maping from statements to their copies *)
5364: val stmtmap : (int, stmt) H.t = H.create 113
5365: val sid = ref 0 (* Will have to assign ids to statements *)
5366: (* Keep here a list of statements to be patched *)
5367: val patches : stmt list ref = ref []
5368:
5369: val argid = ref 0
5370:
5371: (* This is the main function *)
5372: method vfunc (f: fundec) : fundec visitAction =
5373: (* We need a map from the old locals/formals to the new ones *)
5374: H.clear map;
5375: argid := 0;
5376: (* Make a copy of the fundec. *)
5377: let f' = {f with svar = f.svar} in
5378: let patchfunction (f' : fundec) =
5379: (* Change the name. Only this late to allow the visitor to copy the
5380: * svar *)
5381: f'.svar.vname <- newname;
5382: let findStmt (i: int) =
5383: try H.find stmtmap i
5384: with Not_found -> E.s (bug "Cannot find the copy of stmt#%d" i)
5385: in
5386: let patchstmt (s: stmt) =
5387: match s.skind with
5388: Goto (sr, l) ->
5389: (* Make a copy of the reference *)
5390: let sr' = ref (findStmt !sr.sid) in
5391: s.skind <- Goto (sr',l)
5392: | Switch (e, body, cases, l) ->
5393: s.skind <- Switch (e, body,
5394: List.map (fun cs -> findStmt cs.sid) cases, l)
5395: | _ -> ()
5396: in
5397: List.iter patchstmt !patches;
5398: f'
5399: in
5400: patches := [];
5401: sid := 0;
5402: H.clear stmtmap;
5403: ChangeDoChildrenPost (f', patchfunction)
5404:
5405: (* We must create a new varinfo for each declaration. Memoize to
5406: * maintain sharing *)
5407: method vvdec (v: varinfo) =
5408: (* Some varinfo have empty names. Give them some name *)
5409: if v.vname = "" then begin
5410: v.vname <- "arg" ^ string_of_int !argid; incr argid
5411: end;
5412: try
5413: ChangeTo (H.find map v.vname)
5414: with Not_found -> begin
5415: let v' = {v with vid = !nextGlobalVID} in
5416: incr nextGlobalVID;
5417: H.add map v.vname v';
5418: ChangeDoChildrenPost (v', fun x -> x)
5419: end
5420:
5421: (* We must replace references to local variables *)
5422: method vvrbl (v: varinfo) =
5423: if v.vglob then SkipChildren else
5424: try
5425: ChangeTo (H.find map v.vname)
5426: with Not_found ->
5427: E.s (bug "Cannot find the new copy of local variable %s" v.vname)
5428:
5429:
5430: (* Replace statements. *)
5431: method vstmt (s: stmt) : stmt visitAction =
5432: s.sid <- !sid; incr sid;
5433: let s' = {s with sid = s.sid} in
5434: H.add stmtmap s.sid s'; (* Remember where we copied this *)
5435: (* if we have a Goto or a Switch remember them to fixup at end *)
5436: (match s'.skind with
5437: (Goto _ | Switch _) -> patches := s' :: !patches
5438: | _ -> ());
5439: (* Do the children *)
5440: ChangeDoChildrenPost (s', fun x -> x)
5441:
5442: (* Copy blocks since they are mutable *)
5443: method vblock (b: block) =
5444: ChangeDoChildrenPost ({b with bstmts = b.bstmts}, fun x -> x)
5445:
5446:
5447: method vglob _ = E.s (bug "copyFunction should not be used on globals")
5448: end
5449:
5450: (* We need a function that copies a CIL function. *)
5451: let copyFunction (f: fundec) (newname: string) : fundec =
5452: visitCilFunction (new copyFunctionVisitor(newname)) f
5453:
5454: (********* Compute the CFG ********)
5455: let sid_counter = ref 0
5456: let statements : stmt list ref = ref []
5457: (* Clear all info about the CFG in statements *)
5458: class clear : cilVisitor = object
5459: inherit nopCilVisitor
5460: method vstmt s = begin
5461: s.sid <- !sid_counter ;
5462: incr sid_counter ;
5463: statements := s :: !statements;
5464: s.succs <- [] ;
5465: s.preds <- [] ;
5466: DoChildren
5467: end
5468: method vexpr _ = SkipChildren
5469: method vtype _ = SkipChildren
5470: method vinst _ = SkipChildren
5471: end
5472:
5473: let link source dest = begin
5474: if not (List.mem dest source.succs) then
5475: source.succs <- dest :: source.succs ;
5476: if not (List.mem source dest.preds) then
5477: dest.preds <- source :: dest.preds
5478: end
5479: let trylink source dest_option = match dest_option with
5480: None -> ()
5481: | Some(dest) -> link source dest
5482:
5483: let rec succpred_block b fallthrough =
5484: let rec handle sl = match sl with
5485: [] -> ()
5486: | [a] -> succpred_stmt a fallthrough
5487: | hd :: tl -> succpred_stmt hd (Some(List.hd tl)) ;
5488: handle tl
5489: in handle b.bstmts
5490: and succpred_stmt s fallthrough =
5491: match s.skind with
5492: Instr _ -> trylink s fallthrough
5493: | Return _ -> ()
5494: | Goto(dest,l) -> link s !dest
5495: | Break _
5496: | Continue _
5497: | Switch _ ->
5498: failwith "computeCFGInfo: cannot be called on functions with break, continue or switch statements. Use prepareCFG first to remove them."
5499: | If(e1,b1,b2,l) ->
5500: (match b1.bstmts with
5501: [] -> trylink s fallthrough
5502: | hd :: tl -> (link s hd ; succpred_block b1 fallthrough )) ;
5503: (match b2.bstmts with
5504: [] -> trylink s fallthrough
5505: | hd :: tl -> (link s hd ; succpred_block b2 fallthrough ))
5506: | Loop(b,l,_,_) -> begin match b.bstmts with
5507: [] -> failwith "computeCFGInfo: empty loop"
5508: | hd :: tl ->
5509: link s hd ;
5510: succpred_block b (Some(hd))
5511: end
5512: | Block(b) -> begin match b.bstmts with
5513: [] -> trylink s fallthrough
5514: | hd :: tl -> link s hd ;
5515: succpred_block b fallthrough
5516: end
5517: | TryExcept _ | TryFinally _ ->
5518: failwith "computeCFGInfo: structured exception handling not implemented"
5519:
5520: (* [weimer] Sun May 5 12:25:24 PDT 2002
5521: * This code was pulled from ext/switch.ml because it looks like we really
5522: * want it to be part of CIL.
5523: *
5524: * Here is the magic handling to
5525: * (1) replace switch statements with if/goto
5526: * (2) remove "break"
5527: * (3) remove "default"
5528: * (4) remove "continue"
5529: *)
5530: let is_case_label l = match l with
5531: | Case _ | Default _ -> true
5532: | _ -> false
5533:
5534: let switch_count = ref (-1)
5535: let get_switch_count () =
5536: switch_count := 1 + !switch_count ;
5537: !switch_count
5538:
5539: let switch_label = ref (-1)
5540:
5541: let rec xform_switch_stmt s break_dest cont_dest label_index = begin
5542: s.labels <- List.map (fun lab -> match lab with
5543: Label _ -> lab
5544: | Case(e,l) ->
5545: let suffix =
5546: match isInteger e with
5547: | Some value ->
5548: if value < Int64.zero then
5549: "neg_" ^ Int64.to_string (Int64.neg value)
5550: else
5551: Int64.to_string value
5552: | None ->
5553: incr switch_label;
5554: "exp_" ^ string_of_int !switch_label
5555: in
5556: let str = Flx_cil_pretty.sprint 80
5557: (Flx_cil_pretty.dprintf "switch_%d_%s" label_index suffix) in
5558: (Label(str,l,false))
5559: | Default(l) -> (Label(Printf.sprintf
5560: "switch_%d_default" label_index,l,false))
5561: ) s.labels ;
5562: match s.skind with
5563: | Instr _ | Return _ | Goto _ -> ()
5564: | Break(l) -> begin try
5565: s.skind <- Goto(break_dest (),l)
5566: with e ->
5567: ignore (error "prepareCFG: break: %a@!" d_stmt s) ;
5568: raise e
5569: end
5570: | Continue(l) -> begin try
5571: s.skind <- Goto(cont_dest (),l)
5572: with e ->
5573: ignore (error "prepareCFG: continue: %a@!" d_stmt s) ;
5574: raise e
5575: end
5576: | If(e,b1,b2,l) -> xform_switch_block b1 break_dest cont_dest label_index ;
5577: xform_switch_block b2 break_dest cont_dest label_index
5578: | Switch(e,b,sl,l) -> begin
5579: (* change
5580: * switch (se) {
5581: * case 0: s0 ;
5582: * case 1: s1 ; break;
5583: * ...
5584: * }
5585: *
5586: * into:
5587: *
5588: * if (se == 0) goto label_0;
5589: * else if (se == 1) goto label_1;
5590: * ...
5591: * else if (0) { // body_block
5592: * label_0: s0;
5593: * label_1: s1; goto label_break;
5594: * ...
5595: * } else if (0) { // break_block
5596: * label_break: ; // break_stmt
5597: * }
5598: *)
5599: let i = get_switch_count () in
5600: let break_stmt = mkStmt (Instr []) in
5601: break_stmt.labels <-
5602: [Label((Printf.sprintf "switch_%d_break" i),l,false)] ;
5603: let break_block = mkBlock [ break_stmt ] in
5604: let body_block = b in
5605: let body_if_stmtkind = (If(zero,body_block,break_block,l)) in
5606:
5607: (* The default case, if present, must be used only if *all*
5608: non-default cases fail [ISO/IEC 9899:1999, §6.8.4.2, ¶5]. As a
5609: result, we sort the order in which we handle the labels (but not the
5610: order in which we print out the statements, so fall-through still
5611: works as expected). *)
5612: let compare_choices s1 s2 = match s1.labels, s2.labels with
5613: | (Default(_) :: _), _ -> 1
5614: | _, (Default(_) :: _) -> -1
5615: | _, _ -> 0
5616: in
5617:
5618: let rec handle_choices sl = match sl with
5619: [] -> body_if_stmtkind
5620: | stmt_hd :: stmt_tl -> begin
5621: let rec handle_labels lab_list = begin
5622: match lab_list with
5623: [] -> handle_choices stmt_tl
5624: | Case(ce,cl) :: lab_tl ->
5625: let pred = BinOp(Eq,e,ce,intType) in
5626: let then_block = mkBlock [ mkStmt (Goto(ref stmt_hd,cl)) ] in
5627: let else_block = mkBlock [ mkStmt (handle_labels lab_tl) ] in
5628: If(pred,then_block,else_block,cl)
5629: | Default(dl) :: lab_tl ->
5630: (* ww: before this was 'if (1) goto label', but as Ben points
5631: out this might confuse someone down the line who doesn't have
5632: special handling for if(1) into thinking that there are two
5633: paths here. The simpler 'goto label' is what we want. *)
5634: Block(mkBlock [ mkStmt (Goto(ref stmt_hd,dl)) ;
5635: mkStmt (handle_labels lab_tl) ])
5636: | Label(_,_,_) :: lab_tl -> handle_labels lab_tl
5637: end in
5638: handle_labels stmt_hd.labels
5639: end in
5640: s.skind <- handle_choices (List.sort compare_choices sl) ;
5641: xform_switch_block b (fun () -> ref break_stmt) cont_dest i
5642: end
5643: | Loop(b,l,_,_) ->
5644: let i = get_switch_count () in
5645: let break_stmt = mkStmt (Instr []) in
5646: break_stmt.labels <-
5647: [Label((Printf.sprintf "while_%d_break" i),l,false)] ;
5648: let cont_stmt = mkStmt (Instr []) in
5649: cont_stmt.labels <-
5650: [Label((Printf.sprintf "while_%d_continue" i),l,false)] ;
5651: b.bstmts <- cont_stmt :: b.bstmts ;
5652: let this_stmt = mkStmt
5653: (Loop(b,l,Some(cont_stmt),Some(break_stmt))) in
5654: let break_dest () = ref break_stmt in
5655: let cont_dest () = ref cont_stmt in
5656: xform_switch_block b break_dest cont_dest label_index ;
5657: break_stmt.succs <- s.succs ;
5658: let new_block = mkBlock [ this_stmt ; break_stmt ] in
5659: s.skind <- Block new_block
5660: | Block(b) -> xform_switch_block b break_dest cont_dest label_index
5661:
5662: | TryExcept _ | TryFinally _ ->
5663: failwith "xform_switch_statement: structured exception handling not implemented"
5664:
5665: end and xform_switch_block b break_dest cont_dest label_index =
5666: try
5667: let rec link_succs sl = match sl with
5668: | [] -> ()
5669: | hd :: tl -> (if hd.succs = [] then hd.succs <- tl) ; link_succs tl
5670: in
5671: link_succs b.bstmts ;
5672: List.iter (fun stmt ->
5673: xform_switch_stmt stmt break_dest cont_dest label_index) b.bstmts ;
5674: with e ->
5675: List.iter (fun stmt -> ignore
5676: (warn "prepareCFG: %a@!" d_stmt stmt)) b.bstmts ;
5677: raise e
5678:
5679: (* prepare a function for computeCFGInfo by removing break, continue,
5680: * default and switch statements/labels and replacing them with Ifs and
5681: * Gotos. *)
5682: let prepareCFG (fd : fundec) : unit =
5683: xform_switch_block fd.sbody
5684: (fun () -> failwith "prepareCFG: break with no enclosing loop")
5685: (fun () -> failwith "prepareCFG: continue with no enclosing loop") (-1)
5686:
5687: (* make the cfg and return a list of statements *)
5688: let computeCFGInfo (f : fundec) (global_numbering : bool) : stmt list =
5689: let clear_it = new clear in
5690: if not global_numbering then
5691: sid_counter := 0 ;
5692: statements := [];
5693: ignore (visitCilBlock clear_it f.sbody) ;
5694: f.smaxstmtid <- Some (!sid_counter) ;
5695: succpred_block f.sbody (None);
5696: let res = !statements in
5697: statements := [];
5698: res
5699:
5700: let initCIL () =
5701: (* Set the machine *)
5702: theMachine := if !msvcMode then M.msvc else M.gcc;
5703: (* Pick type for string literals *)
5704: stringLiteralType := if !theMachine.const_string_literals then
5705: charConstPtrType
5706: else
5707: charPtrType;
5708: (* Find the right ikind given the size *)
5709: let findIkind (unsigned: bool) (sz: int) : ikind =
5710: (* Test the most common sizes first *)
5711: if sz = !theMachine.sizeof_int then
5712: if unsigned then IUInt else IInt
5713: else if sz = !theMachine.sizeof_long then
5714: if unsigned then IULong else ILong
5715: else if sz = 1 then
5716: if unsigned then IUChar else IChar
5717: else if sz = !theMachine.sizeof_short then
5718: if unsigned then IUShort else IShort
5719: else if sz = !theMachine.sizeof_longlong then
5720: if unsigned then IULongLong else ILongLong
5721: else
5722: E.s(E.unimp "initCIL: cannot find the right ikind for size %d\n" sz)
5723: in
5724: upointType := TInt(findIkind true !theMachine.sizeof_ptr, []);
5725: kindOfSizeOf := findIkind true !theMachine.sizeof_size;
5726: typeOfSizeOf := TInt(!kindOfSizeOf, []);
5727: H.add gccBuiltins "__builtin_memset"
5728: (voidPtrType, [ voidPtrType; intType; intType ], false);
5729: wcharKind := findIkind false !theMachine.sizeof_wchar;
5730: wcharType := TInt(!wcharKind, []);
5731: char_is_unsigned := !theMachine.char_is_unsigned;
5732: little_endian := !theMachine.little_endian;
5733: nextGlobalVID := 1;
5734: nextCompinfoKey := 1
5735:
5736:
5737: (* We want to bring all type declarations before the data declarations. This
5738: * is needed for code of the following form:
5739:
5740: int f(); // Prototype without arguments
5741: typedef int FOO;
5742: int f(FOO x) { ... }
5743:
5744: In CIL the prototype also lists the type of the argument as being FOO,
5745: which is undefined.
5746:
5747: There is one catch with this scheme. If the type contains an array whose
5748: length refers to variables then those variables must be declared before
5749: the type *)
5750:
5751: let pullTypesForward = true
5752:
5753:
5754: (* Scan a type and collect the variables that are refered *)
5755: class getVarsInGlobalClass (pacc: varinfo list ref) = object
5756: inherit nopCilVisitor
5757: method vvrbl (vi: varinfo) =
5758: pacc := vi :: !pacc;
5759: SkipChildren
5760:
5761: method vglob = function
5762: GType _ | GCompTag _ -> DoChildren
5763: | _ -> SkipChildren
5764:
5765: end
5766:
5767: let getVarsInGlobal (g : global) : varinfo list =
5768: let pacc : varinfo list ref = ref [] in
5769: let v : cilVisitor = new getVarsInGlobalClass pacc in
5770: ignore (visitCilGlobal v g);
5771: !pacc
5772:
5773: let hasPrefix p s =
5774: let pl = String.length p in
5775: (String.length s >= pl) && String.sub s 0 pl = p
5776:
5777: let pushGlobal (g: global)
5778: ~(types:global list ref)
5779: ~(variables: global list ref) =
5780: if not pullTypesForward then
5781: variables := g :: !variables
5782: else
5783: begin
5784: (* Collect a list of variables that are refered from the type. Return
5785: * Some if the global should go with the types and None if it should go
5786: * to the variables. *)
5787: let varsintype : (varinfo list * location) option =
5788: match g with
5789: GType (_, l) | GCompTag (_, l) -> Some (getVarsInGlobal g, l)
5790: | GEnumTag (_, l) | GPragma (Attr("pack", _), l)
5791: | GCompTagDecl (_, l) | GEnumTagDecl (_, l) -> Some ([], l)
5792: (** Move the warning pragmas early
5793: | GPragma(Attr(s, _), l) when hasPrefix "warning" s -> Some ([], l)
5794: *)
5795: | _ -> None (* Does not go with the types *)
5796: in
5797: match varsintype with
5798: None -> variables := g :: !variables
5799: | Some (vl, loc) ->
5800: types :=
5801: (* insert declarations for referred variables ('vl'), before
5802: * the type definition 'g' itself *)
5803: g :: (List.fold_left (fun acc v -> GVarDecl(v, loc) :: acc)
5804: !types vl)
5805: end
5806:
5807:
5808: type formatArg =
5809: Fe of exp
5810: | Feo of exp option (** For array lengths *)
5811: | Fu of unop
5812: | Fb of binop
5813: | Fk of ikind
5814: | FE of exp list (** For arguments in a function call *)
5815: | Ff of (string * typ * attributes) (** For a formal argument *)
5816: | FF of (string * typ * attributes) list (* For formal argument lists *)
5817: | Fva of bool (** For the ellipsis in a function type *)
5818: | Fv of varinfo
5819: | Fl of lval
5820: | Flo of lval option (** For the result of a function call *)
5821: | Fo of offset
5822: | Fc of compinfo
5823: | Fi of instr
5824: | FI of instr list
5825: | Ft of typ
5826: | Fd of int
5827: | Fg of string
5828: | Fs of stmt
5829: | FS of stmt list
5830: | FA of attributes
5831:
5832: | Fp of attrparam
5833: | FP of attrparam list
5834:
5835: | FX of string
5836:
5837: let d_formatarg () = function
5838: Fe e -> dprintf "Fe(%a)" d_exp e
5839: | Feo None -> dprintf "Feo(None)"
5840: | Feo (Some e) -> dprintf "Feo(%a)" d_exp e
5841: | FE _ -> dprintf "FE()"
5842: | Fk ik -> dprintf "Fk()"
5843: | Fva b -> dprintf "Fva(%b)" b
5844: | Ff (an, _, _) -> dprintf "Ff(%s)" an
5845: | FF _ -> dprintf "FF(...)"
5846: | FA _ -> dprintf "FA(...)"
5847: | Fu uo -> dprintf "Fu()"
5848: | Fb bo -> dprintf "Fb()"
5849: | Fv v -> dprintf "Fv(%s)" v.vname
5850: | Fl l -> dprintf "Fl(%a)" d_lval l
5851: | Flo None -> dprintf "Flo(None)"
5852: | Flo (Some l) -> dprintf "Flo(%a)" d_lval l
5853: | Fo o -> dprintf "Fo"
5854: | Fc ci -> dprintf "Fc(%s)" ci.cname
5855: | Fi i -> dprintf "Fi(...)"
5856: | FI i -> dprintf "FI(...)"
5857: | Ft t -> dprintf "Ft(%a)" d_type t
5858: | Fd n -> dprintf "Fd(%d)" n
5859: | Fg s -> dprintf "Fg(%s)" s
5860: | Fp _ -> dprintf "Fp(...)"
5861: | FP n -> dprintf "FP(...)"
5862: | Fs _ -> dprintf "FS"
5863: | FS _ -> dprintf "FS"
5864:
5865: | FX _ -> dprintf "FX()"
5866:
5867:
5868:
Start ocaml section to src/flx_cil_cil.mli[1
/1
]
1: # 7000 "./lpsrc/flx_cil.ipk"
2:
3: (*
4: * CIL: An intermediate language for analyzing C programs.
5: *
6: * George Necula
7: *
8: *)
9:
10: (** CIL API Documentation. An html version of this document can be found at
11: * http://manju.cs.berkeley.edu/cil. *)
12:
13: (** Call this function to perform some initialization. Call if after you have
14: * set {!Flx_cil_cil.msvcMode}. *)
15: val initCIL: unit -> unit
16:
17:
18: (** This are the CIL version numbers. A CIL version is a number of the form
19: * M.m.r (major, minor and release) *)
20: val cilVersion: string
21: val cilVersionMajor: int
22: val cilVersionMinor: int
23: val cilVersionRevision: int
24:
25: (** This module defines the abstract syntax of CIL. It also provides utility
26: * functions for traversing the CIL data structures, and pretty-printing
27: * them. The parser for both the GCC and MSVC front-ends can be invoked as
28: * [Flx_cil_frontc.parse: string -> unit ->] {!Flx_cil_cil.file}. This function must be given
29: * the name of a preprocessed C file and will return the top-level data
30: * structure that describes a whole source file. By default the parsing and
31: * elaboration into CIL is done as for GCC source. If you want to use MSVC
32: * source you must set the {!Flx_cil_cil.msvcMode} to [true] and must also invoke the
33: * function [Flx_cil_frontc.setMSVCMode: unit -> unit]. *)
34:
35:
36: (** {b The Abstract Syntax of CIL} *)
37:
38:
39: (** The top-level representation of a CIL source file (and the result of the
40: * parsing and elaboration). Its main contents is the list of global
41: * declarations and definitions. You can iterate over the globals in a
42: * {!Flx_cil_cil.file} using the following iterators: {!Flx_cil_cil.mapGlobals},
43: * {!Flx_cil_cil.iterGlobals} and {!Flx_cil_cil.foldGlobals}. You can also use the
44: * {!Flx_cil_cil.dummyFile} when you need a {!Flx_cil_cil.file} as a placeholder. For each
45: * global item CIL stores the source location where it appears (using the
46: * type {!Flx_cil_cil.location}) *)
47:
48: type file =
49: { mutable fileName: string; (** The complete file name *)
50: mutable globals: global list; (** List of globals as they will appear
51: in the printed file *)
52: mutable globinit: fundec option;
53: (** An optional global initializer function. This is a function where
54: * you can put stuff that must be executed before the program is
55: * started. This function, is conceptually at the end of the file,
56: * although it is not part of the globals list. Use {!Flx_cil_cil.getGlobInit}
57: * to create/get one. *)
58: mutable globinitcalled: bool;
59: (** Whether the global initialization function is called in main. This
60: should always be false if there is no global initializer. When
61: you create a global initialization CIL will try to insert code in
62: main to call it. *)
63: }
64: (** Top-level representation of a C source file *)
65:
66: (** {b Globals}. The main type for representing global declarations and
67: * definitions. A list of these form a CIL file. The order of globals in the
68: * file is generally important. *)
69:
70: (** A global declaration or definition *)
71: and global =
72: | GType of typeinfo * location
73: (** A typedef. All uses of type names (through the [TNamed] constructor)
74: must be preceded in the file by a definition of the name. The string
75: is the defined name and always not-empty. *)
76:
77: | GCompTag of compinfo * location
78: (** Defines a struct/union tag with some fields. There must be one of
79: these for each struct/union tag that you use (through the [TComp]
80: constructor) since this is the only context in which the fields are
81: printed. Consequently nested structure tag definitions must be
82: broken into individual definitions with the innermost structure
83: defined first. *)
84:
85: | GCompTagDecl of compinfo * location
86: (** Declares a struct/union tag. Use as a forward declaration. This is
87: * printed without the fields. *)
88:
89: | GEnumTag of enuminfo * location
90: (** Declares an enumeration tag with some fields. There must be one of
91: these for each enumeration tag that you use (through the [TEnum]
92: constructor) since this is the only context in which the items are
93: printed. *)
94:
95: | GEnumTagDecl of enuminfo * location
96: (** Declares an enumeration tag. Use as a forward declaration. This is
97: * printed without the items. *)
98:
99: | GVarDecl of varinfo * location
100: (** A variable declaration (not a definition). If the variable has a
101: function type then this is a prototype. There can be several
102: declarations and at most one definition for a given variable. If both
103: forms appear then they must share the same varinfo structure. A
104: prototype shares the varinfo with the fundec of the definition. Either
105: has storage Extern or there must be a definition in this file *)
106:
107: | GVar of varinfo * initinfo * location
108: (** A variable definition. Can have an initializer. The initializer is
109: * updateable so that you can change it without requiring to recreate
110: * the list of globals. There can be at most one definition for a
111: * variable in an entire program. Cannot have storage Extern or function
112: * type. *)
113:
114: | GFun of fundec * location
115: (** A function definition. *)
116:
117: | GAsm of string * location (** Global asm statement. These ones
118: can contain only a template *)
119: | GPragma of attribute * location (** Pragmas at top level. Use the same
120: syntax as attributes *)
121: | GText of string (** Some text (printed verbatim) at
122: top level. E.g., this way you can
123: put comments in the output. *)
124:
125: (** {b Types}. A C type is represented in CIL using the type {!Flx_cil_cil.typ}.
126: * Among types we differentiate the integral types (with different kinds
127: * denoting the sign and precision), floating point types, enumeration types,
128: * array and pointer types, and function types. Every type is associated with
129: * a list of attributes, which are always kept in sorted order. Use
130: * {!Flx_cil_cil.addAttribute} and {!Flx_cil_cil.addAttributes} to construct list of
131: * attributes. If you want to inspect a type, you should use
132: * {!Flx_cil_cil.unrollType} or {!Flx_cil_cil.unrollTypeDeep} to see through the uses of
133: * named types. *)
134: (** CIL is configured at build-time with the sizes and alignments of the
135: * underlying compiler (GCC or MSVC). CIL contains functions that can compute
136: * the size of a type (in bits) {!Flx_cil_cil.bitsSizeOf}, the alignment of a type
137: * (in bytes) {!Flx_cil_cil.alignOf_int}, and can convert an offset into a start and
138: * width (both in bits) using the function {!Flx_cil_cil.bitsOffset}. At the moment
139: * these functions do not take into account the [packed] attributes and
140: * pragmas. *)
141:
142: and typ =
143: TVoid of attributes (** Void type. Also predefined as {!Flx_cil_cil.voidType} *)
144: | TInt of ikind * attributes
145: (** An integer type. The kind specifies the sign and width. Several
146: * useful variants are predefined as {!Flx_cil_cil.intType}, {!Flx_cil_cil.uintType},
147: * {!Flx_cil_cil.longType}, {!Flx_cil_cil.charType}. *)
148:
149:
150: | TFloat of fkind * attributes
151: (** A floating-point type. The kind specifies the precision. You can
152: * also use the predefined constant {!Flx_cil_cil.doubleType}. *)
153:
154: | TPtr of typ * attributes
155: (** Pointer type. Several useful variants are predefined as
156: * {!Flx_cil_cil.charPtrType}, {!Flx_cil_cil.charConstPtrType} (pointer to a
157: * constant character), {!Flx_cil_cil.voidPtrType},
158: * {!Flx_cil_cil.intPtrType} *)
159:
160: | TArray of typ * exp option * attributes
161: (** Array type. It indicates the base type and the array length. *)
162:
163: | TFun of typ * (string * typ * attributes) list option * bool * attributes
164: (** Function type. Indicates the type of the result, the name, type
165: * and name attributes of the formal arguments ([None] if no
166: * arguments were specified, as in a function whose definition or
167: * prototype we have not seen; [Some \[\]] means void). Use
168: * {!Flx_cil_cil.argsToList} to obtain a list of arguments. The boolean
169: * indicates if it is a variable-argument function. If this is the
170: * type of a varinfo for which we have a function declaration then
171: * the information for the formals must match that in the
172: * function's sformals. Use {!Flx_cil_cil.setFormals} or
173: * {!Flx_cil_cil.setFunctionType} for this purpose. *)
174:
175: | TNamed of typeinfo * attributes
176: (* The use of a named type. Each such type name must be preceded
177: * in the file by a [GType] global. This is printed as just the
178: * type name. The actual referred type is not printed here and is
179: * carried only to simplify processing. To see through a sequence
180: * of named type references, use {!Flx_cil_cil.unrollType} or
181: * {!Flx_cil_cil.unrollTypeDeep}. The attributes are in addition to those
182: * given when the type name was defined. *)
183:
184: | TComp of compinfo * attributes
185: (** The most delicate issue for C types is that recursion that is possible by
186: * using structures and pointers. To address this issue we have a more
187: * complex representation for structured types (struct and union). Each such
188: * type is represented using the {!Flx_cil_cil.compinfo} type. For each composite
189: * type the {!Flx_cil_cil.compinfo} structure must be declared at top level using
190: * [GCompTag] and all references to it must share the same copy of the
191: * structure. The attributes given are those pertaining to this use of the
192: * type and are in addition to the attributes that were given at the
193: * definition of the type and which are stored in the {!Flx_cil_cil.compinfo}. *)
194:
195: | TEnum of enuminfo * attributes
196: (** A reference to an enumeration type. All such references must
197: share the enuminfo among them and with a [GEnumTag] global that
198: precedes all uses. The attributes refer to this use of the
199: enumeration and are in addition to the attributes of the
200: enumeration itself, which are stored inside the enuminfo *)
201:
202:
203: | TBuiltin_va_list of attributes
204: (** This is the same as the gcc's type with the same name *)
205:
206: (**
207: There are a number of functions for querying the kind of a type. These are
208: {!Flx_cil_cil.isIntegralType},
209: {!Flx_cil_cil.isArithmeticType},
210: {!Flx_cil_cil.isPointerType},
211: {!Flx_cil_cil.isFunctionType},
212: {!Flx_cil_cil.isArrayType}.
213:
214: There are two easy ways to scan a type. First, you can use the
215: {!Flx_cil_cil.existsType} to return a boolean answer about a type. This function
216: is controlled by a user-provided function that is queried for each type that is
217: used to construct the current type. The function can specify whether to
218: terminate the scan with a boolean result or to continue the scan for the
219: nested types.
220:
221: The other method for scanning types is provided by the visitor interface (see
222: {!Flx_cil_cil.cilVisitor}).
223:
224: If you want to compare types (or to use them as hash-values) then you should
225: use instead type signatures (represented as {!Flx_cil_cil.typsig}). These
226: contain the same information as types but canonicalized such that simple Ocaml
227: structural equality will tell whether two types are equal. Use
228: {!Flx_cil_cil.typeSig} to compute the signature of a type. If you want to ignore
229: certain type attributes then use {!Flx_cil_cil.typeSigWithAttrs}.
230:
231: *)
232:
233:
234: (** Various kinds of integers *)
235: and ikind =
236: IBool (** [_Bool] *)
237: | IChar (** [char] *)
238: | ISChar (** [signed char] *)
239: | IUChar (** [unsigned char] *)
240: | IInt (** [int] *)
241: | IUInt (** [unsigned int] *)
242: | IShort (** [short] *)
243: | IUShort (** [unsigned short] *)
244: | ILong (** [long] *)
245: | IULong (** [unsigned long] *)
246: | ILongLong (** [long long] (or [_int64] on Microsoft Visual C) *)
247: | IULongLong (** [unsigned long long] (or [unsigned _int64] on Microsoft
248: Visual C) *)
249:
250: (** Various kinds of floating-point numbers*)
251: and fkind =
252: | FFloat (** [float] *)
253: | FDouble (** [double] *)
254: | FLongDouble (** [long double] *)
255:
256: | CFloat (** [float _Complex] *)
257: | CDouble (** [double _Complex] *)
258: | CLongDouble (** [long double _Complex] *)
259:
260: | IFloat (** [float _Imaginary] *)
261: | IDouble (** [double _Imaginary] *)
262: | ILongDouble (** [long double _Imaginary] *)
263:
264:
265: (** {b Attributes.} *)
266:
267: and attribute = Attr of string * attrparam list
268: (** An attribute has a name and some optional parameters. The name should not
269: * start or end with underscore. When CIL parses attribute names it will
270: * strip leading and ending underscores (to ensure that the multitude of GCC
271: * attributes such as const, __const and __const__ all mean the same thing.) *)
272:
273: (** Attributes are lists sorted by the attribute name. Use the functions
274: * {!Flx_cil_cil.addAttribute} and {!Flx_cil_cil.addAttributes} to insert attributes in an
275: * attribute list and maintain the sortedness. *)
276: and attributes = attribute list
277:
278: (** The type of parameters of attributes *)
279: and attrparam =
280: | AInt of int (** An integer constant *)
281: | AStr of string (** A string constant *)
282: | ACons of string * attrparam list (** Constructed attributes. These
283: are printed [foo(a1,a2,...,an)].
284: The list of parameters can be
285: empty and in that case the
286: parentheses are not printed. *)
287: | ASizeOf of typ (** A way to talk about types *)
288: | ASizeOfE of attrparam
289: | AAlignOf of typ
290: | AAlignOfE of attrparam
291: | AUnOp of unop * attrparam
292: | ABinOp of binop * attrparam * attrparam
293: | ADot of attrparam * string (** a.foo **)
294:
295: (** {b Structures.} The {!Flx_cil_cil.compinfo} describes the definition of a
296: * structure or union type. Each such {!Flx_cil_cil.compinfo} must be defined at the
297: * top-level using the [GCompTag] constructor and must be shared by all
298: * references to this type (using either the [TComp] type constructor or from
299: * the definition of the fields.
300:
301: If all you need is to scan the definition of each
302: * composite type once, you can do that by scanning all top-level [GCompTag].
303:
304: * Constructing a {!Flx_cil_cil.compinfo} can be tricky since it must contain fields
305: * that might refer to the host {!Flx_cil_cil.compinfo} and furthermore the type of
306: * the field might need to refer to the {!Flx_cil_cil.compinfo} for recursive types.
307: * Use the {!Flx_cil_cil.mkCompInfo} function to create a {!Flx_cil_cil.compinfo}. You can
308: * easily fetch the {!Flx_cil_cil.fieldinfo} for a given field in a structure with
309: * {!Flx_cil_cil.getCompField}. *)
310:
311: (** The definition of a structure or union type. Use {!Flx_cil_cil.mkCompInfo} to
312: * make one and use {!Flx_cil_cil.copyCompInfo} to copy one (this ensures that a new
313: * key is assigned and that the fields have the right pointers to parents.). *)
314: and compinfo = {
315: mutable cstruct: bool;
316: (** True if struct, False if union *)
317: mutable cname: string;
318: (** The name. Always non-empty. Use {!Flx_cil_cil.compFullName} to get the full
319: * name of a comp (along with the struct or union) *)
320: mutable ckey: int;
321: (** A unique integer. This is assigned by {!Flx_cil_cil.mkCompInfo} using a
322: * global variable in the Flx_cil_cil module. Thus two identical structs in two
323: * different files might have different keys. Use {!Flx_cil_cil.copyCompInfo} to
324: * copy structures so that a new key is assigned. *)
325: mutable cfields: fieldinfo list;
326: (** Information about the fields. Notice that each fieldinfo has a
327: * pointer back to the host compinfo. This means that you should not
328: * share fieldinfo's between two compinfo's *)
329: mutable cattr: attributes;
330: (** The attributes that are defined at the same time as the composite
331: * type. These attributes can be supplemented individually at each
332: * reference to this [compinfo] using the [TComp] type constructor. *)
333: mutable cdefined: bool;
334: (** This boolean flag can be used to distinguish between structures
335: that have not been defined and those that have been defined but have
336: no fields (such things are allowed in gcc). *)
337: mutable creferenced: bool;
338: (** True if used. Initially set to false. *)
339: }
340:
341: (** {b Structure fields.} The {!Flx_cil_cil.fieldinfo} structure is used to describe
342: * a structure or union field. Fields, just like variables, can have
343: * attributes associated with the field itself or associated with the type of
344: * the field (stored along with the type of the field). *)
345:
346: (** Information about a struct/union field *)
347: and fieldinfo = {
348: mutable fcomp: compinfo;
349: (** The host structure that contains this field. There can be only one
350: * [compinfo] that contains the field. *)
351: mutable fname: string;
352: (** The name of the field. Might be the value of {!Flx_cil_cil.missingFieldName}
353: * in which case it must be a bitfield and is not printed and it does not
354: * participate in initialization *)
355: mutable ftype: typ;
356: (** The type *)
357: mutable fbitfield: int option;
358: (** If a bitfield then ftype should be an integer type and the width of
359: * the bitfield must be 0 or a positive integer smaller or equal to the
360: * width of the integer type. A field of width 0 is used in C to control
361: * the alignment of fields. *)
362: mutable fattr: attributes;
363: (** The attributes for this field (not for its type) *)
364: mutable floc: location;
365: (** The location where this field is defined *)
366: mutable fstorage: storage;
367: (** Must be NoStorage or Static,
368: * indicates nonstatic or static member *)
369: }
370:
371:
372:
373: (** {b Enumerations.} Information about an enumeration. This is shared by all
374: * references to an enumeration. Make sure you have a [GEnumTag] for each of
375: * of these. *)
376:
377: (** Information about an enumeration *)
378: and enuminfo = {
379: mutable ename: string;
380: (** The name. Always non-empty. *)
381: mutable eitems: (string * exp * location) list;
382: (** Items with names and values. This list should be non-empty. The item
383: * values must be compile-time constants. *)
384: mutable eattr: attributes;
385: (** The attributes that are defined at the same time as the enumeration
386: * type. These attributes can be supplemented individually at each
387: * reference to this [enuminfo] using the [TEnum] type constructor. *)
388: mutable ereferenced: bool;
389: (** True if used. Initially set to false*)
390: }
391:
392: (** {b Enumerations.} Information about an enumeration. This is shared by all
393: * references to an enumeration. Make sure you have a [GEnumTag] for each of
394: * of these. *)
395:
396: (** Information about a defined type *)
397: and typeinfo = {
398: mutable tname: string;
399: (** The name. Can be empty only in a [GType] when introducing a composite
400: * or enumeration tag. If empty cannot be referred to from the file *)
401: mutable ttype: typ;
402: (** The actual type. This includes the attributes that were present in
403: * the typedef *)
404: mutable treferenced: bool;
405: (** True if used. Initially set to false*)
406: }
407:
408: (** {b Variables.}
409: Each local or global variable is represented by a unique {!Flx_cil_cil.varinfo}
410: structure. A global {!Flx_cil_cil.varinfo} can be introduced with the [GVarDecl] or
411: [GVar] or [GFun] globals. A local varinfo can be introduced as part of a
412: function definition {!Flx_cil_cil.fundec}.
413:
414: All references to a given global or local variable must refer to the same
415: copy of the [varinfo]. Each [varinfo] has a globally unique identifier that
416: can be used to index maps and hashtables (the name can also be used for this
417: purpose, except for locals from different functions). This identifier is
418: constructor using a global counter.
419:
420: It is very important that you construct [varinfo] structures using only one
421: of the following functions:
422: - {!Flx_cil_cil.makeGlobalVar} : to make a global variable
423: - {!Flx_cil_cil.makeTempVar} : to make a temporary local variable whose name
424: will be generated so that to avoid conflict with other locals.
425: - {!Flx_cil_cil.makeLocalVar} : like {!Flx_cil_cil.makeTempVar} but you can specify the
426: exact name to be used.
427: - {!Flx_cil_cil.copyVarinfo}: make a shallow copy of a varinfo assigning a new name
428: and a new unique identifier
429:
430: A [varinfo] is also used in a function type to denote the list of formals.
431:
432: *)
433:
434: (** Information about a variable. *)
435: and varinfo = {
436: mutable vname: string;
437: (** The name of the variable. Cannot be empty. It is primarily your
438: * responsibility to ensure the uniqueness of a variable name. For local
439: * variables {!Flx_cil_cil.makeTempVar} helps you ensure that the name is unique.
440: *)
441:
442: mutable vtype: typ;
443: (** The declared type of the variable. *)
444:
445: mutable vattr: attributes;
446: (** A list of attributes associated with the variable.*)
447: mutable vstorage: storage;
448: (** The storage-class *)
449:
450: mutable vglob: bool;
451: (** True if this is a global variable*)
452:
453: mutable vinline: bool;
454: (** Whether this varinfo is for an inline function. *)
455:
456: mutable vdecl: location;
457: (** Location of variable declaration. *)
458:
459: mutable vid: int;
460: (** A unique integer identifier. This field will be
461: * set for you if you use one of the {!Flx_cil_cil.makeFormalVar},
462: * {!Flx_cil_cil.makeLocalVar}, {!Flx_cil_cil.makeTempVar}, {!Flx_cil_cil.makeGlobalVar}, or
463: * {!Flx_cil_cil.copyVarinfo}. *)
464:
465: mutable vaddrof: bool;
466: (** True if the address of this variable is taken. CIL will set these
467: * flags when it parses C, but you should make sure to set the flag
468: * whenever your transformation create [AddrOf] expression. *)
469:
470: mutable vreferenced: bool;
471: (** True if this variable is ever referenced. This is computed by
472: * [removeUnusedVars]. It is safe to just initialize this to False *)
473: }
474:
475: (** Storage-class information *)
476: and storage =
477: | NoStorage (** The default storage. Nothing is
478: * printed *)
479: | Static
480: | Register
481: | Extern
482:
483:
484: (** {b Expressions.} The CIL expression language contains only the side-effect free expressions of
485: C. They are represented as the type {!Flx_cil_cil.exp}. There are several
486: interesting aspects of CIL expressions:
487:
488: Integer and floating point constants can carry their textual representation.
489: This way the integer 15 can be printed as 0xF if that is how it occurred in the
490: source.
491:
492: CIL uses 64 bits to represent the integer constants and also stores the width
493: of the integer type. Care must be taken to ensure that the constant is
494: representable with the given width. Use the functions {!Flx_cil_cil.kinteger},
495: {!Flx_cil_cil.kinteger64} and {!Flx_cil_cil.integer} to construct constant
496: expressions. CIL predefines the constants {!Flx_cil_cil.zero},
497: {!Flx_cil_cil.one} and {!Flx_cil_cil.mone} (for -1).
498:
499: Use the functions {!Flx_cil_cil.isConstant} and {!Flx_cil_cil.isInteger} to test if
500: an expression is a constant and a constant integer respectively.
501:
502: CIL keeps the type of all unary and binary expressions. You can think of that
503: type qualifying the operator. Furthermore there are different operators for
504: arithmetic and comparisons on arithmetic types and on pointers.
505:
506: Another unusual aspect of CIL is that the implicit conversion between an
507: expression of array type and one of pointer type is made explicit, using the
508: [StartOf] expression constructor (which is not printed). If you apply the
509: [AddrOf}]constructor to an lvalue of type [T] then you will be getting an
510: expression of type [TPtr(T)].
511:
512: You can find the type of an expression with {!Flx_cil_cil.typeOf}.
513:
514: You can perform constant folding on expressions using the function
515: {!Flx_cil_cil.constFold}.
516: *)
517:
518: (** Expressions (Side-effect free)*)
519: and exp =
520: Const of constant (** Constant *)
521: | Lval of lval (** Lvalue *)
522: | SizeOf of typ
523: (** sizeof(<type>). Has [unsigned int] type (ISO 6.5.3.4). This is not
524: * turned into a constant because some transformations might want to
525: * change types *)
526:
527: | SizeOfE of exp
528: (** sizeof(<expression>) *)
529:
530: | SizeOfStr of string
531: (** sizeof(string_literal). We separate this case out because this is the
532: * only instance in which a string literal should not be treated as
533: * having type pointer to character. *)
534:
535: | AlignOf of typ
536: (** This corresponds to the GCC __alignof_. Has [unsigned int] type *)
537: | AlignOfE of exp
538:
539:
540: | UnOp of unop * exp * typ
541: (** Unary operation. Includes the type of the result. *)
542:
543: | BinOp of binop * exp * exp * typ
544: (** Binary operation. Includes the type of the result. The arithmetic
545: * conversions are made explicit for the arguments. *)
546:
547: | CastE of typ * exp
548: (** Use {!Flx_cil_cil.mkCast} to make casts. *)
549:
550: | AddrOf of lval
551: (** Always use {!Flx_cil_cil.mkAddrOf} to construct one of these. Apply to an
552: * lvalue of type [T] yields an expression of type [TPtr(T)] *)
553:
554: | StartOf of lval
555: (** Conversion from an array to a pointer to the beginning of the array.
556: * Given an lval of type [TArray(T)] produces an expression of type
557: * [TPtr(T)]. In C this operation is implicit, the [StartOf] operator is
558: * not printed. We have it in CIL because it makes the typing rules
559: * simpler. *)
560:
561: (** {b Constants.} *)
562:
563: (** Literal constants *)
564: and constant =
565: | CInt64 of int64 * ikind * string option
566: (** Integer constant. Give the ikind (see ISO9899 6.1.3.2) and the
567: * textual representation, if available. (This allows us to print a
568: * constant as, for example, 0xF instead of 15.) Use {!Flx_cil_cil.integer} or
569: * {!Flx_cil_cil.kinteger} to create these. Watch out for integers that cannot be
570: * represented on 64 bits. OCAML does not give Overflow exceptions. *)
571: | CStr of string
572: (* String constant. The escape characters inside the string have been
573: * already interpreted. This constant has pointer to character type! The
574: * only case when you would like a string literal to have an array type
575: * is when it is an argument to sizeof. In that case you should use
576: * SizeOfStr. *)
577: | CWStr of int64 list
578: (* Wide character string constant. Note that the local interpretation
579: * of such a literal depends on {!Flx_cil_cil.wcharType} and {!Flx_cil_cil.wcharKind}.
580: * Such a constant has type pointer to {!Flx_cil_cil.wcharType}. The
581: * escape characters in the string have not been "interpreted" in
582: * the sense that L"A\xabcd" remains "A\xabcd" rather than being
583: * represented as the wide character list with two elements: 65 and
584: * 43981. That "interpretation" depends on the underlying wide
585: * character type. *)
586: | CChr of char
587: (** Character constant *)
588: | CReal of float * fkind * string option
589: (** Floating point constant. Give the fkind (see ISO 6.4.4.2) and also
590: * the textual representation, if available. *)
591:
592: (** Unary operators *)
593: and unop =
594: Neg (** Unary minus *)
595: | BNot (** Bitwise complement (~) *)
596: | LNot (** Logical Not (!) *)
597:
598: (** Binary operations *)
599: and binop =
600: PlusA (** arithmetic + *)
601: | PlusPI (** pointer + integer *)
602: | IndexPI (** pointer + integer but only when
603: * it arises from an expression
604: * [e\[i\]] when [e] is a pointer and
605: * not an array. This is semantically
606: * the same as PlusPI but CCured uses
607: * this as a hint that the integer is
608: * probably positive. *)
609: | MinusA (** arithmetic - *)
610: | MinusPI (** pointer - integer *)
611: | MinusPP (** pointer - pointer *)
612: | Mult (** * *)
613: | Div (** / *)
614: | Mod (** % *)
615: | Shiftlt (** shift left *)
616: | Shiftrt (** shift right *)
617:
618: | Lt (** < (arithmetic comparison) *)
619: | Gt (** > (arithmetic comparison) *)
620: | Le (** <= (arithmetic comparison) *)
621: | Ge (** > (arithmetic comparison) *)
622: | Eq (** == (arithmetic comparison) *)
623: | Ne (** != (arithmetic comparison) *)
624: | BAnd (** bitwise and *)
625: | BXor (** exclusive-or *)
626: | BOr (** inclusive-or *)
627:
628: | LAnd (** logical and. Unlike other
629: * expressions this one does not
630: * always evaluate both operands. If
631: * you want to use these, you must
632: * set {!Flx_cil_cil.useLogicalOperators}. *)
633: | LOr (** logical or. Unlike other
634: * expressions this one does not
635: * always evaluate both operands. If
636: * you want to use these, you must
637: * set {!Flx_cil_cil.useLogicalOperators}. *)
638:
639: (** {b Lvalues.} Lvalues are the sublanguage of expressions that can appear at the left of an assignment or as operand to the address-of operator.
640: In C the syntax for lvalues is not always a good indication of the meaning
641: of the lvalue. For example the C value
642: {v
643: a[0][1][2]
644: v}
645: might involve 1, 2 or 3 memory reads when used in an expression context,
646: depending on the declared type of the variable [a]. If [a] has type [int
647: \[4\]\[4\]\[4\]] then we have one memory read from somewhere inside the area
648: that stores the array [a]. On the other hand if [a] has type [int ***] then
649: the expression really means [* ( * ( * (a + 0) + 1) + 2)], in which case it is
650: clear that it involves three separate memory operations.
651:
652: An lvalue denotes the contents of a range of memory addresses. This range
653: is denoted as a host object along with an offset within the object. The
654: host object can be of two kinds: a local or global variable, or an object
655: whose address is in a pointer expression. We distinguish the two cases so
656: that we can tell quickly whether we are accessing some component of a
657: variable directly or we are accessing a memory location through a pointer.
658: To make it easy to
659: tell what an lvalue means CIL represents lvalues as a host object and an
660: offset (see {!Flx_cil_cil.lval}). The host object (represented as
661: {!Flx_cil_cil.lhost}) can be a local or global variable or can be the object
662: pointed-to by a pointer expression. The offset (represented as
663: {!Flx_cil_cil.offset}) is a sequence of field or array index designators.
664:
665: Both the typing rules and the meaning of an lvalue is very precisely
666: specified in CIL.
667:
668: The following are a few useful function for operating on lvalues:
669: - {!Flx_cil_cil.mkMem} - makes an lvalue of [Mem] kind. Use this to ensure
670: that certain equivalent forms of lvalues are canonized.
671: For example, [*&x = x].
672: - {!Flx_cil_cil.typeOfLval} - the type of an lvalue
673: - {!Flx_cil_cil.typeOffset} - the type of an offset, given the type of the
674: host.
675: - {!Flx_cil_cil.addOffset} and {!Flx_cil_cil.addOffsetLval} - extend sequences
676: of offsets.
677: - {!Flx_cil_cil.removeOffset} and {!Flx_cil_cil.removeOffsetLval} - shrink sequences
678: of offsets.
679:
680: The following equivalences hold {v
681: Mem(AddrOf(Mem a, aoff)), off = Mem a, aoff + off
682: Mem(AddrOf(Var v, aoff)), off = Var v, aoff + off
683: AddrOf (Mem a, NoOffset) = a
684: v}
685:
686: *)
687: (** An lvalue *)
688: and lval =
689: lhost * offset
690:
691: (** The host part of an {!Flx_cil_cil.lval}. *)
692: and lhost =
693: | Var of varinfo
694: (** The host is a variable. *)
695:
696: | Mem of exp
697: (** The host is an object of type [T] when the expression has pointer
698: * [TPtr(T)]. *)
699:
700:
701: (** The offset part of an {!Flx_cil_cil.lval}. Each offset can be applied to certain
702: * kinds of lvalues and its effect is that it advances the starting address
703: * of the lvalue and changes the denoted type, essentially focusing to some
704: * smaller lvalue that is contained in the original one. *)
705: and offset =
706: | NoOffset (** No offset. Can be applied to any lvalue and does
707: * not change either the starting address or the type.
708: * This is used when the lval consists of just a host
709: * or as a terminator in a list of other kinds of
710: * offsets. *)
711:
712: | Field of fieldinfo * offset
713: (** A field offset. Can be applied only to an lvalue
714: * that denotes a structure or a union that contains
715: * the mentioned field. This advances the offset to the
716: * beginning of the mentioned field and changes the
717: * type to the type of the mentioned field. *)
718:
719: | Index of exp * offset
720: (** An array index offset. Can be applied only to an
721: * lvalue that denotes an array. This advances the
722: * starting address of the lval to the beginning of the
723: * mentioned array element and changes the denoted type
724: * to be the type of the array element *)
725:
726:
727: (** {b Initializers.}
728: A special kind of expressions are those that can appear as initializers for
729: global variables (initialization of local variables is turned into
730: assignments). The initializers are represented as type {!Flx_cil_cil.init}. You
731: can create initializers with {!Flx_cil_cil.makeZeroInit} and you can conveniently
732: scan compound initializers them with {!Flx_cil_cil.foldLeftCompound} or with {!Flx_cil_cil.foldLeftCompoundAll}.
733: *)
734: (** Initializers for global variables. *)
735: and init =
736: | SingleInit of exp (** A single initializer *)
737: | CompoundInit of typ * (offset * init) list
738: (** Used only for initializers of structures, unions and arrays. The
739: * offsets are all of the form [Field(f, NoOffset)] or [Index(i,
740: * NoOffset)] and specify the field or the index being initialized. For
741: * structures all fields must have an initializer (except the unnamed
742: * bitfields), in the proper order. This is necessary since the offsets
743: * are not printed. For unions there must be exactly one initializer. If
744: * the initializer is not for the first field then a field designator is
745: * printed, so you better be on GCC since MSVC does not understand this.
746: * For arrays, however, we allow you to give only a prefix of the
747: * initializers. You can scan an initializer list with
748: * {!Flx_cil_cil.foldLeftCompound} or with {!Flx_cil_cil.foldLeftCompoundAll}. *)
749:
750:
751: (** We want to be able to update an initializer in a global variable, so we
752: * define it as a mutable field *)
753: and initinfo = {
754: mutable init : init option;
755: }
756:
757: (** {b Function definitions.}
758: A function definition is always introduced with a [GFun] constructor at the
759: top level. All the information about the function is stored into a
760: {!Flx_cil_cil.fundec}. Some of the information (e.g. its name, type,
761: storage, attributes) is stored as a {!Flx_cil_cil.varinfo} that is a field of the
762: [fundec]. To refer to the function from the expression language you must use
763: the [varinfo].
764:
765: The function definition contains, in addition to the body, a list of all the
766: local variables and separately a list of the formals. Both kind of variables
767: can be referred to in the body of the function. The formals must also be shared
768: with the formals that appear in the function type. For that reason, to
769: manipulate formals you should use the provided functions
770: {!Flx_cil_cil.makeFormalVar} and {!Flx_cil_cil.setFormals}.
771: *)
772: (** Function definitions. *)
773: and fundec =
774: { mutable svar: varinfo;
775: (** Holds the name and type as a variable, so we can refer to it
776: * easily from the program. All references to this function either
777: * in a function call or in a prototype must point to the same
778: * [varinfo]. *)
779: mutable sformals: varinfo list;
780: (** Formals. These must be in the same order and with the same
781: * information as the formal information in the type of the function.
782: * Use {!Flx_cil_cil.setFormals} or
783: * {!Flx_cil_cil.setFunctionType} to set these formals and ensure that they
784: * are reflected in the function type. Do not make copies of these
785: * because the body refers to them. *)
786: mutable slocals: varinfo list;
787: (** Locals. Does NOT include the sformals. Do not make copies of
788: * these because the body refers to them. *)
789: mutable smaxid: int; (** Max local id. Starts at 0. Used for
790: * creating the names of new temporary
791: * variables. Updated by
792: * {!Flx_cil_cil.makeLocalVar} and
793: * {!Flx_cil_cil.makeTempVar}. You can also use
794: * {!Flx_cil_cil.setMaxId} to set it after you
795: * have added the formals and locals. *)
796: mutable sbody: block; (** The function body. *)
797: mutable smaxstmtid: int option; (** max id of a (reachable) statement
798: * in this function, if we have
799: * computed it. range = 0 ...
800: * (smaxstmtid-1) *)
801: }
802:
803:
804: (** A block is a sequence of statements with the control falling through from
805: one element to the next *)
806: and block =
807: { mutable battrs: attributes; (** Attributes for the block *)
808: mutable bstmts: stmt list; (** The statements comprising the block*)
809: }
810:
811:
812: (** {b Statements}.
813: CIL statements are the structural elements that make the CFG. They are
814: represented using the type {!Flx_cil_cil.stmt}. Every
815: statement has a (possibly empty) list of labels. The
816: {!Flx_cil_cil.stmtkind} field of a statement indicates what kind of statement it
817: is.
818:
819: Use {!Flx_cil_cil.mkStmt} to make a statement and the fill-in the fields.
820:
821: CIL also comes with support for control-flow graphs. The [sid] field in
822: [stmt] can be used to give unique numbers to statements, and the [succs]
823: and [preds] fields can be used to maintain a list of successors and
824: predecessors for every statement. The CFG information is not computed by
825: default. Instead you must explicitly use the functions
826: {!Flx_cil_cil.prepareCFG} and {!Flx_cil_cil.computeCFGInfo} to do it.
827:
828: *)
829: (** Statements. *)
830: and stmt = {
831: mutable labels: label list;
832: (** Whether the statement starts with some labels, case statements or
833: * default statements. *)
834:
835: mutable skind: stmtkind;
836: (** The kind of statement *)
837:
838: mutable sid: int;
839: (** A number (>= 0) that is unique in a function. Filled in only after
840: * the CFG is computed. *)
841: mutable succs: stmt list;
842: (** The successor statements. They can always be computed from the skind
843: * and the context in which this statement appears. Filled in only after
844: * the CFG is computed. *)
845: mutable preds: stmt list;
846: (** The inverse of the succs function. *)
847: }
848:
849: (** Labels *)
850: and label =
851: Label of string * location * bool
852: (** A real label. If the bool is "true", the label is from the
853: * input source program. If the bool is "false", the label was
854: * created by CIL or some other transformation *)
855: | Case of exp * location (** A case statement *)
856: | Default of location (** A default statement *)
857:
858:
859:
860: (** The various kinds of control-flow statements statements *)
861: and stmtkind =
862: | Instr of instr list
863: (** A group of instructions that do not contain control flow. Control
864: * implicitly falls through. *)
865:
866: | Return of exp option * location
867: (** The return statement. This is a leaf in the CFG. *)
868:
869: | Goto of stmt ref * location
870: (** A goto statement. Appears from actual goto's in the code or from
871: * goto's that have been inserted during elaboration. The reference
872: * points to the statement that is the target of the Goto. This means that
873: * you have to update the reference whenever you replace the target
874: * statement. The target statement MUST have at least a label. *)
875:
876: | Break of location
877: (** A break to the end of the nearest enclosing Loop or Switch *)
878:
879: | Continue of location
880: (** A continue to the start of the nearest enclosing [Loop] *)
881: | If of exp * block * block * location
882: (** A conditional. Two successors, the "then" and the "else" branches.
883: * Both branches fall-through to the successor of the If statement. *)
884:
885: | Switch of exp * block * (stmt list) * location
886: (** A switch statement. The statements that implement the cases can be
887: * reached through the provided list. For each such target you can find
888: * among its labels what cases it implements. The statements that
889: * implement the cases are somewhere within the provided [block]. *)
890:
891: | Loop of block * location * (stmt option) * (stmt option)
892: (** A [while(1)] loop. The termination test is implemented in the body of
893: * a loop using a [Break] statement. If prepareCFG has been called,
894: * the first stmt option will point to the stmt containing the continue
895: * label for this loop and the second will point to the stmt containing
896: * the break label for this loop. *)
897:
898: | Block of block
899: (** Just a block of statements. Use it as a way to keep some block
900: * attributes local *)
901:
902: (** On MSVC we support structured exception handling. This is what you
903: * might expect. Control can get into the finally block either from the
904: * end of the body block, or if an exception is thrown. *)
905: | TryFinally of block * block * location
906:
907: (** On MSVC we support structured exception handling. The try/except
908: * statement is a bit tricky:
909: [__try { blk }
910: __except (e) {
911: handler
912: }]
913:
914: The argument to __except must be an expression. However, we keep a
915: list of instructions AND an expression in case you need to make
916: function calls. We'll print those as a comma expression. The control
917: can get to the __except expression only if an exception is thrown.
918: After that, depending on the value of the expression the control
919: goes to the handler, propagates the exception, or retries the
920: exception !!!
921: *)
922: | TryExcept of block * (instr list * exp) * block * location
923:
924:
925: (** {b Instructions}.
926: An instruction {!Flx_cil_cil.instr} is a statement that has no local
927: (intraprocedural) control flow. It can be either an assignment,
928: function call, or an inline assembly instruction. *)
929:
930: (** Instructions. *)
931: and instr =
932: Set of lval * exp * location
933: (** An assignment. The type of the expression is guaranteed to be the same
934: * with that of the lvalue *)
935: | Call of lval option * exp * exp list * location
936: (** A function call with the (optional) result placed in an lval. It is
937: * possible that the returned type of the function is not identical to
938: * that of the lvalue. In that case a cast is printed. The type of the
939: * actual arguments are identical to those of the declared formals. The
940: * number of arguments is the same as that of the declared formals, except
941: * for vararg functions. This construct is also used to encode a call to
942: * "__builtin_va_arg". In this case the second argument (which should be a
943: * type T) is encoded SizeOf(T) *)
944:
945: | Asm of attributes * (* Really only const and volatile can appear
946: * here *)
947: string list * (* templates (CR-separated) *)
948: (string * lval) list * (* outputs must be lvals with
949: * constraints. I would like these
950: * to be actually variables, but I
951: * run into some trouble with ASMs
952: * in the Linux sources *)
953: (string * exp) list * (* inputs with constraints *)
954: string list * (* register clobbers *)
955: location
956: (** There are for storing inline assembly. They follow the GCC
957: * specification:
958: {v
959: asm [volatile] ("...template..." "..template.."
960: : "c1" (o1), "c2" (o2), ..., "cN" (oN)
961: : "d1" (i1), "d2" (i2), ..., "dM" (iM)
962: : "r1", "r2", ..., "nL" );
963: v}
964:
965: where the parts are
966:
967: - [volatile] (optional): when present, the assembler instruction
968: cannot be removed, moved, or otherwise optimized
969: - template: a sequence of strings, with %0, %1, %2, etc. in the string to
970: refer to the input and output expressions. I think they're numbered
971: consecutively, but the docs don't specify. Each string is printed on
972: a separate line. This is the only part that is present for MSVC inline
973: assembly.
974: - "ci" (oi): pairs of constraint-string and output-lval; the
975: constraint specifies that the register used must have some
976: property, like being a floating-point register; the constraint
977: string for outputs also has "=" to indicate it is written, or
978: "+" to indicate it is both read and written; 'oi' is the
979: name of a C lvalue (probably a variable name) to be used as
980: the output destination
981: - "dj" (ij): pairs of constraint and input expression; the constraint
982: is similar to the "ci"s. the 'ij' is an arbitrary C expression
983: to be loaded into the corresponding register
984: - "rk": registers to be regarded as "clobbered" by the instruction;
985: "memory" may be specified for arbitrary memory effects
986:
987: an example (from gcc manual):
988: {v
989: asm volatile ("movc3 %0,%1,%2"
990: : /* no outputs */
991: : "g" (from), "g" (to), "g" (count)
992: : "r0", "r1", "r2", "r3", "r4", "r5");
993: v}
994: *)
995:
996: (** Describes a location in a source file *)
997: and location = {
998: line: int; (** The line number. -1 means "do not know" *)
999: file: string; (** The name of the source file*)
1000: byte: int; (** The byte position in the source file *)
1001: }
1002:
1003:
1004:
1005: (** To be able to add/remove features easily, each feature should be package
1006: * as an interface with the following interface. These features should be *)
1007: type featureDescr = {
1008: fd_enabled: bool ref;
1009: (** The enable flag. Set to default value *)
1010:
1011: fd_name: string;
1012: (** This is used to construct an option "--doxxx" and "--dontxxx" that
1013: * enable and disable the feature *)
1014:
1015: fd_description: string;
1016: (* A longer name that can be used to document the new options *)
1017:
1018: fd_extraopt: (string * Arg.spec * string) list;
1019: (** Additional command line options *)
1020:
1021: fd_doit: (file -> unit);
1022: (** This performs the transformation *)
1023:
1024: fd_post_check: bool;
1025: (* Whether to perform a CIL consistency checking after this stage, if
1026: * checking is enabled (--check is passed to cilly). Set this to true if
1027: * your feature makes any changes for the program. *)
1028: }
1029:
1030: (** Comparison function for locations.
1031: ** Compares first by filename, then line, then byte *)
1032: val compareLoc: location -> location -> int
1033:
1034: (** {b Values for manipulating globals} *)
1035:
1036: (** Make an empty function *)
1037: val emptyFunction: string -> fundec
1038:
1039: (** Update the formals of a [fundec] and make sure that the function type
1040: has the same information. Will copy the name as well into the type. *)
1041: val setFormals: fundec -> varinfo list -> unit
1042:
1043: (** Set the types of arguments and results as given by the function type
1044: * passed as the second argument. Will not copy the names from the function
1045: * type to the formals *)
1046: val setFunctionType: fundec -> typ -> unit
1047:
1048: (** Update the smaxid after you have populated with locals and formals
1049: * (unless you constructed those using {!Flx_cil_cil.makeLocalVar} or
1050: * {!Flx_cil_cil.makeTempVar}. *)
1051: val setMaxId: fundec -> unit
1052:
1053: (** A dummy function declaration handy when you need one as a placeholder. It
1054: * contains inside a dummy varinfo. *)
1055: val dummyFunDec: fundec
1056:
1057: (** A dummy file *)
1058: val dummyFile: file
1059:
1060: (** Write a {!Flx_cil_cil.file} in binary form to the filesystem. The file can be
1061: * read back in later using {!Flx_cil_cil.loadBinaryFile}, possibly saving parsing
1062: * time. The second argument is the name of the file that should be
1063: * created. *)
1064: val saveBinaryFile : file -> string -> unit
1065:
1066: (** Write a {!Flx_cil_cil.file} in binary form to the filesystem. The file can be
1067: * read back in later using {!Flx_cil_cil.loadBinaryFile}, possibly saving parsing
1068: * time. Does not close the channel. *)
1069: val saveBinaryFileChannel : file -> out_channel -> unit
1070:
1071: (** Read a {!Flx_cil_cil.file} in binary form from the filesystem. The first
1072: * argument is the name of a file previously created by
1073: * {!Flx_cil_cil.saveBinaryFile}. *)
1074: val loadBinaryFile : string -> file
1075:
1076: (** Get the global initializer and create one if it does not already exist.
1077: * When it creates a global initializer it attempts to place a call to it in
1078: * the main function named by the optional argument (default "main") *)
1079: val getGlobInit: ?main_name:string -> file -> fundec
1080:
1081: (** Iterate over all globals, including the global initializer *)
1082: val iterGlobals: file -> (global -> unit) -> unit
1083:
1084: (** Fold over all globals, including the global initializer *)
1085: val foldGlobals: file -> ('a -> global -> 'a) -> 'a -> 'a
1086:
1087: (** Map over all globals, including the global initializer and change things
1088: in place *)
1089: val mapGlobals: file -> (global -> global) -> unit
1090:
1091: (** Prepare a function for CFG information computation by
1092: * {!Flx_cil_cil.computeCFGInfo}. This function converts all [Break], [Switch],
1093: * [Default] and [Continue] {!Flx_cil_cil.stmtkind}s and {!Flx_cil_cil.label}s into [If]s
1094: * and [Goto]s, giving the function body a very CFG-like character. This
1095: * function modifies its argument in place. *)
1096: val prepareCFG: fundec -> unit
1097:
1098: (** Compute the CFG information for all statements in a fundec and return a
1099: * list of the statements. The input fundec cannot have [Break], [Switch],
1100: * [Default], or [Continue] {!Flx_cil_cil.stmtkind}s or {!Flx_cil_cil.label}s. Use
1101: * {!Flx_cil_cil.prepareCFG} to transform them away. The second argument should
1102: * be [true] if you wish a global statement number, [false] if you wish a
1103: * local (per-function) statement numbering. *)
1104: val computeCFGInfo: fundec -> bool -> stmt list
1105:
1106:
1107: (** Create a deep copy of a function. There should be no sharing between the
1108: * copy and the original function *)
1109: val copyFunction: fundec -> string -> fundec
1110:
1111:
1112: (** CIL keeps the types at the beginning of the file and the variables at the
1113: * end of the file. This function will take a global and add it to the
1114: * corresponding stack. Its operation is actually more complicated because if
1115: * the global declares a type that contains references to variables (e.g. in
1116: * sizeof in an array length) then it will also add declarations for the
1117: * variables to the types stack *)
1118: val pushGlobal: global -> types: global list ref
1119: -> variables: global list ref -> unit
1120:
1121: (** A list of the GCC built-in functions. Maps the name to the result and
1122: * argument types, and whether it is vararg *)
1123: val gccBuiltins: (string, typ * typ list * bool) Hashtbl.t
1124:
1125:
1126: (** A list of the MSVC built-in functions. Maps the name to the result and
1127: * argument types, and whether it is vararg *)
1128: val msvcBuiltins: (string, typ * typ list * bool) Hashtbl.t
1129:
1130: (** {b Values for manipulating initializers} *)
1131:
1132:
1133: (** Make a initializer for zero-ing a data type *)
1134: val makeZeroInit: typ -> init
1135:
1136:
1137: (** Fold over the list of initializers in a Compound. [doinit] is called on
1138: * every present initializer, even if it is of compound type. In the case of
1139: * arrays there might be missing zero-initializers at the end of the list.
1140: * These are not scanned. This is much like [List.fold_left] except we also
1141: * pass the type of the initializer *)
1142: val foldLeftCompound:
1143: doinit: (offset -> init -> typ -> 'a -> 'a) ->
1144: ct: typ ->
1145: initl: (offset * init) list ->
1146: acc: 'a -> 'a
1147:
1148:
1149: (** Fold over the list of initializers in a Compound, like
1150: * {!Flx_cil_cil.foldLeftCompound} but in the case of an array it scans even missing
1151: * zero initializers at the end of the array *)
1152: val foldLeftCompoundAll:
1153: doinit: (offset -> init -> typ -> 'a -> 'a) ->
1154: ct: typ ->
1155: initl: (offset * init) list ->
1156: acc: 'a -> 'a
1157:
1158:
1159:
1160: (** {b Values for manipulating types} *)
1161:
1162: (** void *)
1163: val voidType: typ
1164:
1165: (* is the given type "void"? *)
1166: val isVoidType: typ -> bool
1167:
1168: (* is the given type "void *"? *)
1169: val isVoidPtrType: typ -> bool
1170:
1171: (** int *)
1172: val intType: typ
1173:
1174: (** unsigned int *)
1175: val uintType: typ
1176:
1177: (** long *)
1178: val longType: typ
1179:
1180: (** unsigned long *)
1181: val ulongType: typ
1182:
1183: (** char *)
1184: val charType: typ
1185:
1186: (** char * *)
1187: val charPtrType: typ
1188:
1189: (** wchar_t (depends on architecture) and is set when you call
1190: * {!Flx_cil_cil.initCIL}. *)
1191: val wcharKind: ikind ref
1192: val wcharType: typ ref
1193:
1194: (** char const * *)
1195: val charConstPtrType: typ
1196:
1197: (** void * *)
1198: val voidPtrType: typ
1199:
1200: (** int * *)
1201: val intPtrType: typ
1202:
1203: (** unsigned int * *)
1204: val uintPtrType: typ
1205:
1206: (** double *)
1207: val doubleType: typ
1208:
1209: (* An unsigned integer type that fits pointers. Depends on {!Flx_cil_cil.msvcMode}
1210: * and is set when you call {!Flx_cil_cil.initCIL}. *)
1211: val upointType: typ ref
1212:
1213: (* An unsigned integer type that is the type of sizeof. Depends on
1214: * {!Flx_cil_cil.msvcMode} and is set when you call {!Flx_cil_cil.initCIL}. *)
1215: val typeOfSizeOf: typ ref
1216:
1217: (** Returns true if and only if the given integer type is signed. *)
1218: val isSigned: ikind -> bool
1219:
1220: (** Creates a a (potentially recursive) composite type. The arguments are:
1221: * (1) a boolean indicating whether it is a struct or a union, (2) the name
1222: * (always non-empty), (3) a function that when given a representation of the
1223: * structure type constructs the type of the fields recursive type (the first
1224: * argument is only useful when some fields need to refer to the type of the
1225: * structure itself), and (4) a list of attributes to be associated with the
1226: * composite type. The resulting compinfo has the field "cdefined" only if
1227: * the list of fields is non-empty. *)
1228: val mkCompInfo: bool -> (* whether it is a struct or a union *)
1229: string -> (* name of the composite type; cannot be empty *)
1230: (compinfo ->
1231: (string * typ * int option * attributes * location * storage) list) ->
1232: (* a function that when given a forward
1233: representation of the structure type constructs the type of
1234: the fields. The function can ignore this argument if not
1235: constructing a recursive type. *)
1236: attributes -> compinfo
1237:
1238: (** Makes a shallow copy of a {!Flx_cil_cil.compinfo} changing the name and the key.*)
1239: val copyCompInfo: compinfo -> string -> compinfo
1240:
1241: (** This is a constant used as the name of an unnamed bitfield. These fields
1242: do not participate in initialization and their name is not printed. *)
1243: val missingFieldName: string
1244:
1245: (** Get the full name of a comp *)
1246: val compFullName: compinfo -> string
1247:
1248: (** Returns true if this is a complete type.
1249: This means that sizeof(t) makes sense.
1250: Incomplete types are not yet defined
1251: structures and empty arrays. *)
1252: val isCompleteType: typ -> bool
1253:
1254: (** Unroll a type until it exposes a non
1255: * [TNamed]. Will drop the top-level attributes appearing in [TNamed]!!! *)
1256: val unrollType: typ -> typ (* Might drop some attributes !! *)
1257:
1258: (** Unroll all the TNamed in a type (even under type constructors such as
1259: * [TPtr], [TFun] or [TArray]. Does not unroll the types of fields in [TComp]
1260: * types. *)
1261: val unrollTypeDeep: typ -> typ (* Might drop some attributes !! *)
1262:
1263: (** True if the argument is an integral type (i.e. integer or enum) *)
1264: val isIntegralType: typ -> bool
1265:
1266: (** True if the argument is an arithmetic type (i.e. integer, enum or
1267: floating point *)
1268: val isArithmeticType: typ -> bool
1269:
1270: (**True if the argument is a pointer type *)
1271: val isPointerType: typ -> bool
1272:
1273: (** True if the argument is a function type *)
1274: val isFunctionType: typ -> bool
1275:
1276: (** Obtain the argument list ([] if None) *)
1277: val argsToList: (string * typ * attributes) list option
1278: -> (string * typ * attributes) list
1279:
1280: (** True if the argument is an array type *)
1281: val isArrayType: typ -> bool
1282:
1283: (** Raised when {!Flx_cil_cil.lenOfArray} fails either because the length is [None]
1284: * or because it is a non-constant expression *)
1285: exception LenOfArray
1286:
1287: (** Call to compute the array length as present in the array type, to an
1288: * integer. Raises {!Flx_cil_cil.LenOfArray} if not able to compute the length, such
1289: * as when there is no length or the length is not a constant. *)
1290: val lenOfArray: exp option -> int
1291:
1292: (** Return a named fieldinfo in compinfo, or raise Not_found *)
1293: val getCompField: compinfo -> string -> fieldinfo
1294:
1295:
1296: (** A datatype to be used in conjunction with [existsType] *)
1297: type existsAction =
1298: ExistsTrue (* We have found it *)
1299: | ExistsFalse (* Stop processing this branch *)
1300: | ExistsMaybe (* This node is not what we are
1301: * looking for but maybe its
1302: * successors are *)
1303:
1304: (** Scans a type by applying the function on all elements.
1305: When the function returns ExistsTrue, the scan stops with
1306: true. When the function returns ExistsFalse then the current branch is not
1307: scanned anymore. Care is taken to
1308: apply the function only once on each composite type, thus avoiding
1309: circularity. When the function returns ExistsMaybe then the types that
1310: construct the current type are scanned (e.g. the base type for TPtr and
1311: TArray, the type of fields for a TComp, etc). *)
1312: val existsType: (typ -> existsAction) -> typ -> bool
1313:
1314:
1315: (** Given a function type split it into return type,
1316: * arguments, is_vararg and attributes. An error is raised if the type is not
1317: * a function type *)
1318: val splitFunctionType:
1319: typ -> typ * (string * typ * attributes) list option * bool * attributes
1320: (** Same as {!Flx_cil_cil.splitFunctionType} but takes a varinfo. Prints a nicer
1321: * error message if the varinfo is not for a function *)
1322: val splitFunctionTypeVI:
1323: varinfo -> typ * (string * typ * attributes) list option * bool * attributes
1324:
1325:
1326: (** {b Type signatures} *)
1327:
1328: (** Type signatures. Two types are identical iff they have identical
1329: * signatures. These contain the same information as types but canonicalized.
1330: * For example, two function types that are identical except for the name of
1331: * the formal arguments are given the same signature. Also, [TNamed]
1332: * constructors are unrolled. *)
1333: type typsig =
1334: TSArray of typsig * exp option * attributes
1335: | TSPtr of typsig * attributes
1336: | TSComp of bool * string * attributes
1337: | TSFun of typsig * typsig list * bool * attributes
1338: | TSEnum of string * attributes
1339: | TSBase of typ
1340:
1341: (** Print a type signature *)
1342: val d_typsig: unit -> typsig -> Flx_cil_pretty.doc
1343:
1344: (** Compute a type signature *)
1345: val typeSig: typ -> typsig
1346:
1347: (** Like {!Flx_cil_cil.typeSig} but customize the incorporation of attributes *)
1348: val typeSigWithAttrs: (attributes -> attributes) -> typ -> typsig
1349:
1350: (** Replace the attributes of a signature (only at top level) *)
1351: val setTypeSigAttrs: attributes -> typsig -> typsig
1352:
1353: (** Get the top-level attributes of a signature *)
1354: val typeSigAttrs: typsig -> attributes
1355:
1356: (*********************************************************)
1357: (** LVALUES *)
1358:
1359: (** Make a varinfo. Use this (rarely) to make a raw varinfo. Use other
1360: * functions to make locals ({!Flx_cil_cil.makeLocalVar} or {!Flx_cil_cil.makeFormalVar} or
1361: * {!Flx_cil_cil.makeTempVar}) and globals ({!Flx_cil_cil.makeGlobalVar}). Note that this
1362: * function will assign a new identifier. The first argument specifies
1363: * whether the varinfo is for a global. *)
1364: val makeVarinfo: bool -> string -> typ -> varinfo
1365:
1366: (** Make a formal variable for a function. Insert it in both the sformals
1367: and the type of the function. You can optionally specify where to insert
1368: this one. If where = "^" then it is inserted first. If where = "$" then
1369: it is inserted last. Otherwise where must be the name of a formal after
1370: which to insert this. By default it is inserted at the end. *)
1371: val makeFormalVar: fundec -> ?where:string -> string -> typ -> varinfo
1372:
1373: (** Make a local variable and add it to a function's slocals (only if insert =
1374: true, which is the default). Make sure you know what you are doing if you
1375: set insert=false. *)
1376: val makeLocalVar: fundec -> ?insert:bool -> string -> typ -> varinfo
1377:
1378: (** Make a temporary variable and add it to a function's slocals. The name of
1379: the temporary variable will be generated based on the given name hint so
1380: that to avoid conflicts with other locals. *)
1381: val makeTempVar: fundec -> ?name: string -> typ -> varinfo
1382:
1383:
1384: (** Make a global variable. Your responsibility to make sure that the name
1385: is unique *)
1386: val makeGlobalVar: string -> typ -> varinfo
1387:
1388: (** Make a shallow copy of a [varinfo] and assign a new identifier *)
1389: val copyVarinfo: varinfo -> string -> varinfo
1390:
1391: (** Add an offset at the end of an lvalue. Make sure the type of the lvalue
1392: * and the offset are compatible. *)
1393: val addOffsetLval: offset -> lval -> lval
1394:
1395: (** [addOffset o1 o2] adds [o1] to the end of [o2]. *)
1396: val addOffset: offset -> offset -> offset
1397:
1398: (** Remove ONE offset from the end of an lvalue. Returns the lvalue with the
1399: * trimmed offset and the final offset. If the final offset is [NoOffset]
1400: * then the original [lval] did not have an offset. *)
1401: val removeOffsetLval: lval -> lval * offset
1402:
1403: (** Remove ONE offset from the end of an offset sequence. Returns the
1404: * trimmed offset and the final offset. If the final offset is [NoOffset]
1405: * then the original [lval] did not have an offset. *)
1406: val removeOffset: offset -> offset * offset
1407:
1408: (** Compute the type of an lvalue *)
1409: val typeOfLval: lval -> typ
1410:
1411: (** Compute the type of an offset from a base type *)
1412: val typeOffset: typ -> offset -> typ
1413:
1414:
1415: (*******************************************************)
1416: (** {b Values for manipulating expressions} *)
1417:
1418:
1419: (* Construct integer constants *)
1420:
1421: (** 0 *)
1422: val zero: exp
1423:
1424: (** 1 *)
1425: val one: exp
1426:
1427: (** -1 *)
1428: val mone: exp
1429:
1430:
1431: (** Construct an integer of a given kind, using OCaml's int64 type. If needed
1432: * it will truncate the integer to be within the representable range for the
1433: * given kind. *)
1434: val kinteger64: ikind -> int64 -> exp
1435:
1436: (** Construct an integer of a given kind. Converts the integer to int64 and
1437: * then uses kinteger64. This might truncate the value if you use a kind
1438: * that cannot represent the given integer. This can only happen for one of
1439: * the Char or Short kinds *)
1440: val kinteger: ikind -> int -> exp
1441:
1442: (** Construct an integer of kind IInt. You can use this always since the
1443: OCaml integers are 31 bits and are guaranteed to fit in an IInt *)
1444: val integer: int -> exp
1445:
1446:
1447: (** True if the given expression is a (possibly cast'ed)
1448: character or an integer constant *)
1449: val isInteger: exp -> int64 option
1450:
1451: (** True if the expression is a compile-time constant *)
1452: val isConstant: exp -> bool
1453:
1454: (** True if the given expression is a (possibly cast'ed) integer or character
1455: constant with value zero *)
1456: val isZero: exp -> bool
1457:
1458: (** Do constant folding on an expression. If the first argument is true then
1459: will also compute compiler-dependent expressions such as sizeof *)
1460: val constFold: bool -> exp -> exp
1461:
1462: (** Do constant folding on a binary operation. The bulk of the work done by
1463: [constFold] is done here. If the first argument is true then
1464: will also compute compiler-dependent expressions such as sizeof *)
1465: val constFoldBinOp: bool -> binop -> exp -> exp -> typ -> exp
1466:
1467: (** Increment an expression. Can be arithmetic or pointer type *)
1468: val increm: exp -> int -> exp
1469:
1470:
1471: (** Makes an lvalue out of a given variable *)
1472: val var: varinfo -> lval
1473:
1474: (** Make an AddrOf. Given an lvalue of type T will give back an expression of
1475: type ptr(T). It optimizes somewhat expressions like "& v" and "& v[0]" *)
1476: val mkAddrOf: lval -> exp
1477:
1478:
1479: (** Like mkAddrOf except if the type of lval is an array then it uses
1480: StartOf. This is the right operation for getting a pointer to the start
1481: of the storage denoted by lval. *)
1482: val mkAddrOrStartOf: lval -> exp
1483:
1484: (** Make a Mem, while optimizing AddrOf. The type of the addr must be
1485: TPtr(t) and the type of the resulting lval is t. Note that in CIL the
1486: implicit conversion between an array and the pointer to the first
1487: element does not apply. You must do the conversion yourself using
1488: StartOf *)
1489: val mkMem: addr:exp -> off:offset -> lval
1490:
1491: (** Make an expression that is a string constant (of pointer type) *)
1492: val mkString: string -> exp
1493:
1494: (** Construct a cast when having the old type of the expression. If the new
1495: * type is the same as the old type, then no cast is added. *)
1496: val mkCastT: e:exp -> oldt:typ -> newt:typ -> exp
1497:
1498: (** Like {!Flx_cil_cil.mkCastT} but uses typeOf to get [oldt] *)
1499: val mkCast: e:exp -> newt:typ -> exp
1500:
1501: (** Compute the type of an expression *)
1502: val typeOf: exp -> typ
1503:
1504: (** Convert a string representing a C integer literal to an expression.
1505: * Handles the prefixes 0x and 0 and the suffixes L, U, UL, LL, ULL *)
1506: val parseInt: string -> exp
1507:
1508:
1509: (**********************************************)
1510: (** {b Values for manipulating statements} *)
1511:
1512: (** Construct a statement, given its kind. Initialize the [sid] field to -1,
1513: and [labels], [succs] and [preds] to the empty list *)
1514: val mkStmt: stmtkind -> stmt
1515:
1516: (** Construct a block with no attributes, given a list of statements *)
1517: val mkBlock: stmt list -> block
1518:
1519: (** Construct a statement consisting of just one instruction *)
1520: val mkStmtOneInstr: instr -> stmt
1521:
1522: (** Try to compress statements so as to get maximal basic blocks *)
1523: (* use this instead of List.@ because you get fewer basic blocks *)
1524: val compactStmts: stmt list -> stmt list
1525:
1526: (** Returns an empty statement (of kind [Instr]) *)
1527: val mkEmptyStmt: unit -> stmt
1528:
1529: (** A instr to serve as a placeholder *)
1530: val dummyInstr: instr
1531:
1532: (** A statement consisting of just [dummyInstr] *)
1533: val dummyStmt: stmt
1534:
1535: (** Make a while loop. Can contain Break or Continue *)
1536: val mkWhile: guard:exp -> body:stmt list -> stmt list
1537:
1538: (** Make a for loop for(i=start; i<past; i += incr) \{ ... \}. The body
1539: can contain Break but not Continue. Can be used with i a pointer
1540: or an integer. Start and done must have the same type but incr
1541: must be an integer *)
1542: val mkForIncr: iter:varinfo -> first:exp -> stopat:exp -> incr:exp
1543: -> body:stmt list -> stmt list
1544:
1545: (** Make a for loop for(start; guard; next) \{ ... \}. The body can
1546: contain Break but not Continue !!! *)
1547: val mkFor: start:stmt list -> guard:exp -> next: stmt list ->
1548: body: stmt list -> stmt list
1549:
1550:
1551:
1552: (**************************************************)
1553: (** {b Values for manipulating attributes} *)
1554:
1555: (** Various classes of attributes *)
1556: type attributeClass =
1557: AttrName of bool
1558: (** Attribute of a name. If argument is true and we are on MSVC then
1559: the attribute is printed using __declspec as part of the storage
1560: specifier *)
1561: | AttrFunType of bool
1562: (** Attribute of a function type. If argument is true and we are on
1563: MSVC then the attribute is printed just before the function name *)
1564: | AttrType (** Attribute of a type *)
1565:
1566: (** This table contains the mapping of predefined attributes to classes.
1567: Extend this table with more attributes as you need. This table is used to
1568: determine how to associate attributes with names or types *)
1569: val attributeHash: (string, attributeClass) Hashtbl.t
1570:
1571: (** Partition the attributes into classes:name attributes, function type,
1572: and type attributes *)
1573: val partitionAttributes: default:attributeClass ->
1574: attributes -> attribute list * (* AttrName *)
1575: attribute list * (* AttrFunType *)
1576: attribute list (* AttrType *)
1577:
1578: (** Add an attribute. Maintains the attributes in sorted order of the second
1579: argument *)
1580: val addAttribute: attribute -> attributes -> attributes
1581:
1582: (** Add a list of attributes. Maintains the attributes in sorted order. The
1583: second argument must be sorted, but not necessarily the first *)
1584: val addAttributes: attribute list -> attributes -> attributes
1585:
1586: (** Remove all attributes with the given name. Maintains the attributes in
1587: sorted order. *)
1588: val dropAttribute: string -> attributes -> attributes
1589:
1590: (** Retains attributes with the given name *)
1591: val filterAttributes: string -> attributes -> attributes
1592:
1593: (** True if the named attribute appears in the attribute list. The list of
1594: attributes must be sorted. *)
1595: val hasAttribute: string -> attributes -> bool
1596:
1597: (** Returns all the attributes contained in a type. This requires a traversal
1598: of the type structure, in case of composite, enumeration and named types *)
1599: val typeAttrs: typ -> attribute list
1600:
1601: val setTypeAttrs: typ -> attributes -> typ (* Resets the attributes *)
1602:
1603:
1604: (** Add some attributes to a type *)
1605: val typeAddAttributes: attribute list -> typ -> typ
1606:
1607: (** Remove all attributes with the given names from a type. Note that this
1608: does not remove attributes from typedef and tag definitions, just from
1609: their uses *)
1610: val typeRemoveAttributes: string list -> typ -> typ
1611:
1612:
1613: (******************
1614: ****************** VISITOR
1615: ******************)
1616: (** {b The visitor} *)
1617:
1618: (** Different visiting actions. 'a will be instantiated with [exp], [instr],
1619: etc. *)
1620: type 'a visitAction =
1621: SkipChildren (** Do not visit the children. Return
1622: the node as it is. *)
1623: | DoChildren (** Continue with the children of this
1624: node. Rebuild the node on return
1625: if any of the children changes
1626: (use == test) *)
1627: | ChangeTo of 'a (** Replace the expression with the
1628: given one *)
1629: | ChangeDoChildrenPost of 'a * ('a -> 'a) (** First consider that the entire
1630: exp is replaced by the first
1631: parameter. Then continue with
1632: the children. On return rebuild
1633: the node if any of the children
1634: has changed and then apply the
1635: function on the node *)
1636:
1637:
1638:
1639: (** A visitor interface for traversing CIL trees. Create instantiations of
1640: * this type by specializing the class {!Flx_cil_cil.nopCilVisitor}. Each of the
1641: * specialized visiting functions can also call the [queueInstr] to specify
1642: * that some instructions should be inserted before the current instruction
1643: * or statement. Use syntax like [self#queueInstr] to call a method
1644: * associated with the current object. *)
1645: class type cilVisitor = object
1646: method vvdec: varinfo -> varinfo visitAction
1647: (** Invoked for each variable declaration. The subtrees to be traversed
1648: * are those corresponding to the type and attributes of the variable.
1649: * Note that variable declarations are all the [GVar], [GVarDecl], [GFun],
1650: * all the [varinfo] in formals of function types, and the formals and
1651: * locals for function definitions. This means that the list of formals
1652: * in a function definition will be traversed twice, once as part of the
1653: * function type and second as part of the formals in a function
1654: * definition. *)
1655:
1656: method vvrbl: varinfo -> varinfo visitAction
1657: (** Invoked on each variable use. Here only the [SkipChildren] and
1658: * [ChangeTo] actions make sense since there are no subtrees. Note that
1659: * the type and attributes of the variable are not traversed for a
1660: * variable use *)
1661:
1662: method vexpr: exp -> exp visitAction
1663: (** Invoked on each expression occurrence. The subtrees are the
1664: * subexpressions, the types (for a [Cast] or [SizeOf] expression) or the
1665: * variable use. *)
1666:
1667: method vlval: lval -> lval visitAction
1668: (** Invoked on each lvalue occurrence *)
1669:
1670: method voffs: offset -> offset visitAction
1671: (** Invoked on each offset occurrence that is *not* as part
1672: * of an initializer list specification, i.e. in an lval or
1673: * recursively inside an offset. *)
1674:
1675: method vinitoffs: offset -> offset visitAction
1676: (** Invoked on each offset appearing in the list of a
1677: * CompoundInit initializer. *)
1678:
1679: method vinst: instr -> instr list visitAction
1680: (** Invoked on each instruction occurrence. The [ChangeTo] action can
1681: * replace this instruction with a list of instructions *)
1682:
1683: method vstmt: stmt -> stmt visitAction
1684: (** Control-flow statement. The default [DoChildren] action does not
1685: * create a new statement when the components change. Instead it updates
1686: * the contents of the original statement. This is done to preserve the
1687: * sharing with [Goto] and [Case] statements that point to the original
1688: * statement. If you use the [ChangeTo] action then you should take care
1689: * of preserving that sharing yourself. *)
1690:
1691: method vblock: block -> block visitAction (** Block. *)
1692: method vfunc: fundec -> fundec visitAction (** Function definition.
1693: Replaced in place. *)
1694: method vglob: global -> global list visitAction (** Global (vars, types,
1695: etc.) *)
1696: method vinit: init -> init visitAction (** Initializers for globals *)
1697: method vtype: typ -> typ visitAction (** Use of some type. Note
1698: * that for structure/union
1699: * and enumeration types the
1700: * definition of the
1701: * composite type is not
1702: * visited. Use [vglob] to
1703: * visit it. *)
1704: method vattr: attribute -> attribute list visitAction
1705: (** Attribute. Each attribute can be replaced by a list *)
1706:
1707: (** Add here instructions while visiting to queue them to preceede the
1708: * current statement or instruction being processed. Use this method only
1709: * when you are visiting an expression that is inside a function body, or
1710: * a statement, because otherwise there will no place for the visitor to
1711: * place your instructions. *)
1712: method queueInstr: instr list -> unit
1713:
1714: (** Gets the queue of instructions and resets the queue. This is done
1715: * automatically for you when you visit statments. *)
1716: method unqueueInstr: unit -> instr list
1717:
1718: end
1719:
1720: (** Default Visitor. Traverses the CIL tree without modifying anything *)
1721: class nopCilVisitor: cilVisitor
1722:
1723: (* other cil constructs *)
1724:
1725: (** Visit a file. This will will re-cons all globals TWICE (so that it is
1726: * tail-recursive). Use {!Flx_cil_cil.visitCilFileSameGlobals} if your visitor will
1727: * not change the list of globals. *)
1728: val visitCilFile: cilVisitor -> file -> unit
1729:
1730: (** A visitor for the whole file that does not change the globals (but maybe
1731: * changes things inside the globals). Use this function instead of
1732: * {!Flx_cil_cil.visitCilFile} whenever appropriate because it is more efficient for
1733: * long files. *)
1734: val visitCilFileSameGlobals: cilVisitor -> file -> unit
1735:
1736: (** Visit a global *)
1737: val visitCilGlobal: cilVisitor -> global -> global list
1738:
1739: (** Visit a function definition *)
1740: val visitCilFunction: cilVisitor -> fundec -> fundec
1741:
1742: (* Visit an expression *)
1743: val visitCilExpr: cilVisitor -> exp -> exp
1744:
1745: (** Visit an lvalue *)
1746: val visitCilLval: cilVisitor -> lval -> lval
1747:
1748: (** Visit an lvalue or recursive offset *)
1749: val visitCilOffset: cilVisitor -> offset -> offset
1750:
1751: (** Visit an initializer offset *)
1752: val visitCilInitOffset: cilVisitor -> offset -> offset
1753:
1754: (** Visit an instruction *)
1755: val visitCilInstr: cilVisitor -> instr -> instr list
1756:
1757: (** Visit a statement *)
1758: val visitCilStmt: cilVisitor -> stmt -> stmt
1759:
1760: (** Visit a block *)
1761: val visitCilBlock: cilVisitor -> block -> block
1762:
1763: (** Visit a type *)
1764: val visitCilType: cilVisitor -> typ -> typ
1765:
1766: (** Visit a variable declaration *)
1767: val visitCilVarDecl: cilVisitor -> varinfo -> varinfo
1768:
1769: (** Visit an initializer *)
1770: val visitCilInit: cilVisitor -> init -> init
1771:
1772:
1773: (** Visit a list of attributes *)
1774: val visitCilAttributes: cilVisitor -> attribute list -> attribute list
1775:
1776: (* And some generic visitors. The above are built with these *)
1777:
1778:
1779:
1780:
1781: (** {b Flx_cil_utility functions} *)
1782:
1783: (** Whether the pretty printer should print output for the MS VC compiler.
1784: Default is GCC. After you set this function you should call {!Flx_cil_cil.initCIL}. *)
1785: val msvcMode: bool ref
1786:
1787:
1788: (** Whether to use the logical operands LAnd and LOr. By default, do not use
1789: * them because they are unlike other expressions and do not evaluate both of
1790: * their operands *)
1791: val useLogicalOperators: bool ref
1792:
1793: (** Styles of printing line directives *)
1794: type lineDirectiveStyle =
1795: | LineComment
1796: | LinePreprocessorInput
1797: | LinePreprocessorOutput
1798:
1799: (** How to print line directives *)
1800: val lineDirectiveStyle: lineDirectiveStyle option ref
1801:
1802: (** Whether we print something that will only be used as input to our own
1803: * parser. In that case we are a bit more liberal in what we print *)
1804: val print_CIL_Input: bool ref
1805:
1806: (** Whether to print the CIL as they are, without trying to be smart and
1807: * print nicer code. Normally this is false, in which case the pretty
1808: * printer will turn the while(1) loops of CIL into nicer loops, will not
1809: * print empty "else" blocks, etc. These is one case howewer in which if you
1810: * turn this on you will get code that does not compile: if you use varargs
1811: * the __builtin_va_arg function will be printed in its internal form. *)
1812: val printCilAsIs: bool ref
1813:
1814: (** {b Debugging support} *)
1815:
1816: (** A reference to the current location. If you are careful to set this to
1817: * the current location then you can use some built-in logging functions that
1818: * will print the location. *)
1819: val currentLoc: location ref
1820:
1821: (** CIL has a fairly easy to use mechanism for printing error messages. This
1822: * mechanism is built on top of the pretty-printer mechanism (see
1823: * {!Flx_cil_pretty.doc}) and the error-message modules (see {!Flx_cil_errormsg.error}).
1824:
1825: Here is a typical example for printing a log message: {v
1826: ignore (Flx_cil_errormsg.log "Expression %a is not positive (at %s:%i)\n"
1827: d_exp e loc.file loc.line)
1828: v}
1829:
1830: and here is an example of how you print a fatal error message that stop the
1831: * execution: {v
1832: Flx_cil_errormsg.s (Flx_cil_errormsg.bug "Why am I here?")
1833: v}
1834:
1835: Notice that you can use C format strings with some extension. The most
1836: useful extension is "%a" that means to consumer the next two argument from
1837: the argument list and to apply the first to [unit] and then to the second
1838: and to print the resulting {!Flx_cil_pretty.doc}. For each major type in CIL there is
1839: a corresponding function that pretty-prints an element of that type:
1840: *)
1841:
1842:
1843: (** Flx_cil_pretty-print a location *)
1844: val d_loc: unit -> location -> Flx_cil_pretty.doc
1845:
1846: (** Flx_cil_pretty-print the {!Flx_cil_cil.currentLoc} *)
1847: val d_thisloc: unit -> Flx_cil_pretty.doc
1848:
1849: (** Flx_cil_pretty-print an integer of a given kind *)
1850: val d_ikind: unit -> ikind -> Flx_cil_pretty.doc
1851:
1852: (** Flx_cil_pretty-print a floating-point kind *)
1853: val d_fkind: unit -> fkind -> Flx_cil_pretty.doc
1854:
1855: (** Flx_cil_pretty-print storage-class information *)
1856: val d_storage: unit -> storage -> Flx_cil_pretty.doc
1857:
1858: (** Flx_cil_pretty-print a constant *)
1859: val d_const: unit -> constant -> Flx_cil_pretty.doc
1860:
1861:
1862: (** A printer interface for CIL trees. Create instantiations of
1863: * this type by specializing the class {!Flx_cil_cil.defaultCilPrinterClass}. *)
1864: class type cilPrinter = object
1865: method pVDecl: unit -> varinfo -> Flx_cil_pretty.doc
1866: (** Invoked for each variable declaration. Note that variable
1867: * declarations are all the [GVar], [GVarDecl], [GFun], all the [varinfo]
1868: * in formals of function types, and the formals and locals for function
1869: * definitions. *)
1870:
1871: method pVar: varinfo -> Flx_cil_pretty.doc
1872: (** Invoked on each variable use. *)
1873:
1874: method pLval: unit -> lval -> Flx_cil_pretty.doc
1875: (** Invoked on each lvalue occurrence *)
1876:
1877: method pOffset: Flx_cil_pretty.doc -> offset -> Flx_cil_pretty.doc
1878: (** Invoked on each offset occurrence. The second argument is the base. *)
1879:
1880: method pInstr: unit -> instr -> Flx_cil_pretty.doc
1881: (** Invoked on each instruction occurrence. *)
1882:
1883: method pLabel: unit -> label -> Flx_cil_pretty.doc
1884: (** Print a label. *)
1885:
1886: method pStmt: unit -> stmt -> Flx_cil_pretty.doc
1887: (** Control-flow statement. This is used by
1888: * {!Flx_cil_cil.printGlobal} and by {!Flx_cil_cil.dumpGlobal}. *)
1889:
1890: method dStmt: out_channel -> int -> stmt -> unit
1891: (** Dump a control-flow statement to a file with a given indentation.
1892: * This is used by {!Flx_cil_cil.dumpGlobal}. *)
1893:
1894: method dBlock: out_channel -> int -> block -> unit
1895: (** Dump a control-flow block to a file with a given indentation.
1896: * This is used by {!Flx_cil_cil.dumpGlobal}. *)
1897:
1898: method pBlock: unit -> block -> Flx_cil_pretty.doc
1899:
1900: method pBlock: unit -> block -> Flx_cil_pretty.doc
1901: (** Print a block. *)
1902:
1903: method pGlobal: unit -> global -> Flx_cil_pretty.doc
1904: (** Global (vars, types, etc.). This can be slow and is used only by
1905: * {!Flx_cil_cil.printGlobal} but not by {!Flx_cil_cil.dumpGlobal}. *)
1906:
1907: method dGlobal: out_channel -> global -> unit
1908: (** Dump a global to a file with a given indentation. This is used by
1909: * {!Flx_cil_cil.dumpGlobal} *)
1910:
1911: method pFieldDecl: unit -> fieldinfo -> Flx_cil_pretty.doc
1912: (** A field declaration *)
1913:
1914: method pType: Flx_cil_pretty.doc option -> unit -> typ -> Flx_cil_pretty.doc
1915: (* Use of some type in some declaration. The first argument is used to print
1916: * the declared element, or is None if we are just printing a type with no
1917: * name being declared. Note that for structure/union and enumeration types
1918: * the definition of the composite type is not visited. Use [vglob] to
1919: * visit it. *)
1920:
1921: method pAttr: attribute -> Flx_cil_pretty.doc * bool
1922: (** Attribute. Also return an indication whether this attribute must be
1923: * printed inside the __attribute__ list or not. *)
1924:
1925: method pAttrParam: unit -> attrparam -> Flx_cil_pretty.doc
1926: (** Attribute parameter *)
1927:
1928: method pAttrs: unit -> attributes -> Flx_cil_pretty.doc
1929: (** Attribute lists *)
1930:
1931: method pLineDirective: ?forcefile:bool -> location -> Flx_cil_pretty.doc
1932: (** Print a line-number. This is assumed to come always on an empty line.
1933: * If the forcefile argument is present and is true then the file name
1934: * will be printed always. Otherwise the file name is printed only if it
1935: * is different from the last time time this function is called. The last
1936: * file name is stored in a private field inside the cilPrinter object. *)
1937:
1938: method pStmtKind : stmt -> unit -> stmtkind -> Flx_cil_pretty.doc
1939: (** Print a statement kind. The code to be printed is given in the
1940: * {!Flx_cil_cil.stmtkind} argument. The initial {!Flx_cil_cil.stmt} argument
1941: * records the statement which follows the one being printed;
1942: * {!Flx_cil_cil.defaultCilPrinterClass} uses this information to prettify
1943: * statement printing in certain special cases. *)
1944:
1945: method pExp: unit -> exp -> Flx_cil_pretty.doc
1946: (** Print expressions *)
1947:
1948: method pInit: unit -> init -> Flx_cil_pretty.doc
1949: (** Print initializers. This can be slow and is used by
1950: * {!Flx_cil_cil.printGlobal} but not by {!Flx_cil_cil.dumpGlobal}. *)
1951:
1952: method dInit: out_channel -> int -> init -> unit
1953: (** Dump a global to a file with a given indentation. This is used by
1954: * {!Flx_cil_cil.dumpGlobal} *)
1955: end
1956:
1957: class defaultCilPrinterClass: cilPrinter
1958: val defaultCilPrinter: cilPrinter
1959:
1960: (* Top-level printing functions *)
1961: (** Print a type given a pretty printer *)
1962: val printType: cilPrinter -> unit -> typ -> Flx_cil_pretty.doc
1963:
1964: (** Print an expression given a pretty printer *)
1965: val printExp: cilPrinter -> unit -> exp -> Flx_cil_pretty.doc
1966:
1967: (** Print an lvalue given a pretty printer *)
1968: val printLval: cilPrinter -> unit -> lval -> Flx_cil_pretty.doc
1969:
1970: (** Print a global given a pretty printer *)
1971: val printGlobal: cilPrinter -> unit -> global -> Flx_cil_pretty.doc
1972:
1973: (** Print an attribute given a pretty printer *)
1974: val printAttr: cilPrinter -> unit -> attribute -> Flx_cil_pretty.doc
1975:
1976: (** Print a set of attributes given a pretty printer *)
1977: val printAttrs: cilPrinter -> unit -> attributes -> Flx_cil_pretty.doc
1978:
1979: (** Print an instruction given a pretty printer *)
1980: val printInstr: cilPrinter -> unit -> instr -> Flx_cil_pretty.doc
1981:
1982: (** Print a statement given a pretty printer. This can take very long
1983: * (or even overflow the stack) for huge statements. Use {!Flx_cil_cil.dumpStmt}
1984: * instead. *)
1985: val printStmt: cilPrinter -> unit -> stmt -> Flx_cil_pretty.doc
1986:
1987: (** Print a block given a pretty printer. This can take very long
1988: * (or even overflow the stack) for huge block. Use {!Flx_cil_cil.dumpBlock}
1989: * instead. *)
1990: val printBlock: cilPrinter -> unit -> block -> Flx_cil_pretty.doc
1991:
1992: (** Dump a statement to a file using a given indentation. Use this instead of
1993: * {!Flx_cil_cil.printStmt} whenever possible. *)
1994: val dumpStmt: cilPrinter -> out_channel -> int -> stmt -> unit
1995:
1996: (** Dump a block to a file using a given indentation. Use this instead of
1997: * {!Flx_cil_cil.printBlock} whenever possible. *)
1998: val dumpBlock: cilPrinter -> out_channel -> int -> block -> unit
1999:
2000: (** Print an initializer given a pretty printer. This can take very long
2001: * (or even overflow the stack) for huge initializers. Use {!Flx_cil_cil.dumpInit}
2002: * instead. *)
2003: val printInit: cilPrinter -> unit -> init -> Flx_cil_pretty.doc
2004:
2005: (** Dump an initializer to a file using a given indentation. Use this instead of
2006: * {!Flx_cil_cil.printInit} whenever possible. *)
2007: val dumpInit: cilPrinter -> out_channel -> int -> init -> unit
2008:
2009: (** Flx_cil_pretty-print a type using {!Flx_cil_cil.defaultCilPrinter} *)
2010: val d_type: unit -> typ -> Flx_cil_pretty.doc
2011:
2012: (** Flx_cil_pretty-print an expression using {!Flx_cil_cil.defaultCilPrinter} *)
2013: val d_exp: unit -> exp -> Flx_cil_pretty.doc
2014:
2015: (** Flx_cil_pretty-print an lvalue using {!Flx_cil_cil.defaultCilPrinter} *)
2016: val d_lval: unit -> lval -> Flx_cil_pretty.doc
2017:
2018: (** Flx_cil_pretty-print an offset using {!Flx_cil_cil.defaultCilPrinter}, given the pretty
2019: * printing for the base. *)
2020: val d_offset: Flx_cil_pretty.doc -> unit -> offset -> Flx_cil_pretty.doc
2021:
2022: (** Flx_cil_pretty-print an initializer using {!Flx_cil_cil.defaultCilPrinter}. This can be
2023: * extremely slow (or even overflow the stack) for huge initializers. Use
2024: * {!Flx_cil_cil.dumpInit} instead. *)
2025: val d_init: unit -> init -> Flx_cil_pretty.doc
2026:
2027: (** Flx_cil_pretty-print a binary operator *)
2028: val d_binop: unit -> binop -> Flx_cil_pretty.doc
2029:
2030: (** Flx_cil_pretty-print an attribute using {!Flx_cil_cil.defaultCilPrinter} *)
2031: val d_attr: unit -> attribute -> Flx_cil_pretty.doc
2032:
2033: (** Flx_cil_pretty-print an argument of an attribute using {!Flx_cil_cil.defaultCilPrinter} *)
2034: val d_attrparam: unit -> attrparam -> Flx_cil_pretty.doc
2035:
2036: (** Flx_cil_pretty-print a list of attributes using {!Flx_cil_cil.defaultCilPrinter} *)
2037: val d_attrlist: unit -> attributes -> Flx_cil_pretty.doc
2038:
2039: (** Flx_cil_pretty-print an instruction using {!Flx_cil_cil.defaultCilPrinter} *)
2040: val d_instr: unit -> instr -> Flx_cil_pretty.doc
2041:
2042: (** Flx_cil_pretty-print a label using {!Flx_cil_cil.defaultCilPrinter} *)
2043: val d_label: unit -> label -> Flx_cil_pretty.doc
2044:
2045: (** Flx_cil_pretty-print a statement using {!Flx_cil_cil.defaultCilPrinter}. This can be
2046: * extremely slow (or even overflow the stack) for huge statements. Use
2047: * {!Flx_cil_cil.dumpStmt} instead. *)
2048: val d_stmt: unit -> stmt -> Flx_cil_pretty.doc
2049:
2050: (** Flx_cil_pretty-print a block using {!Flx_cil_cil.defaultCilPrinter}. This can be
2051: * extremely slow (or even overflow the stack) for huge blocks. Use
2052: * {!Flx_cil_cil.dumpBlock} instead. *)
2053: val d_block: unit -> block -> Flx_cil_pretty.doc
2054:
2055: (** Flx_cil_pretty-print the internal representation of a global using
2056: * {!Flx_cil_cil.defaultCilPrinter}. This can be extremely slow (or even overflow the
2057: * stack) for huge globals (such as arrays with lots of initializers). Use
2058: * {!Flx_cil_cil.dumpGlobal} instead. *)
2059: val d_global: unit -> global -> Flx_cil_pretty.doc
2060:
2061:
2062: (** Versions of the above pretty printers, that don't print #line directives *)
2063: val dn_exp : unit -> exp -> Flx_cil_pretty.doc
2064: val dn_lval : unit -> lval -> Flx_cil_pretty.doc
2065: (* dn_offset is missing because it has a different interface *)
2066: val dn_init : unit -> init -> Flx_cil_pretty.doc
2067: val dn_type : unit -> typ -> Flx_cil_pretty.doc
2068: val dn_global : unit -> global -> Flx_cil_pretty.doc
2069: val dn_attrlist : unit -> attributes -> Flx_cil_pretty.doc
2070: val dn_attr : unit -> attribute -> Flx_cil_pretty.doc
2071: val dn_attrparam : unit -> attrparam -> Flx_cil_pretty.doc
2072: val dn_stmt : unit -> stmt -> Flx_cil_pretty.doc
2073: val dn_instr : unit -> instr -> Flx_cil_pretty.doc
2074:
2075:
2076: (** Flx_cil_pretty-print a short description of the global. This is useful for error
2077: * messages *)
2078: val d_shortglobal: unit -> global -> Flx_cil_pretty.doc
2079:
2080: (** Flx_cil_pretty-print a global. Here you give the channel where the printout
2081: * should be sent. *)
2082: val dumpGlobal: cilPrinter -> out_channel -> global -> unit
2083:
2084: (** Flx_cil_pretty-print an entire file. Here you give the channel where the printout
2085: * should be sent. *)
2086: val dumpFile: cilPrinter -> out_channel -> file -> unit
2087:
2088:
2089: (* the following error message producing functions also print a location in
2090: * the code. use {!Flx_cil_errormsg.bug} and {!Flx_cil_errormsg.unimp} if you do not want
2091: * that *)
2092:
2093: (** Like {!Flx_cil_errormsg.bug} except that {!Flx_cil_cil.currentLoc} is also printed *)
2094: val bug: ('a,unit,Flx_cil_pretty.doc) format -> 'a
2095:
2096: (** Like {!Flx_cil_errormsg.unimp} except that {!Flx_cil_cil.currentLoc}is also printed *)
2097: val unimp: ('a,unit,Flx_cil_pretty.doc) format -> 'a
2098:
2099: (** Like {!Flx_cil_errormsg.error} except that {!Flx_cil_cil.currentLoc} is also printed *)
2100: val error: ('a,unit,Flx_cil_pretty.doc) format -> 'a
2101:
2102: (** Like {!Flx_cil_cil.error} except that it explicitly takes a location argument,
2103: * instead of using the {!Flx_cil_cil.currentLoc} *)
2104: val errorLoc: location -> ('a,unit,Flx_cil_pretty.doc) format -> 'a
2105:
2106: (** Like {!Flx_cil_errormsg.warn} except that {!Flx_cil_cil.currentLoc} is also printed *)
2107: val warn: ('a,unit,Flx_cil_pretty.doc) format -> 'a
2108:
2109:
2110: (** Like {!Flx_cil_errormsg.warnOpt} except that {!Flx_cil_cil.currentLoc} is also printed.
2111: * This warning is printed only of {!Flx_cil_errormsg.warnFlag} is set. *)
2112: val warnOpt: ('a,unit,Flx_cil_pretty.doc) format -> 'a
2113:
2114: (** Like {!Flx_cil_errormsg.warn} except that {!Flx_cil_cil.currentLoc} and context
2115: is also printed *)
2116: val warnContext: ('a,unit,Flx_cil_pretty.doc) format -> 'a
2117:
2118: (** Like {!Flx_cil_errormsg.warn} except that {!Flx_cil_cil.currentLoc} and context is also
2119: * printed. This warning is printed only of {!Flx_cil_errormsg.warnFlag} is set. *)
2120: val warnContextOpt: ('a,unit,Flx_cil_pretty.doc) format -> 'a
2121:
2122: (** Like {!Flx_cil_cil.warn} except that it explicitly takes a location argument,
2123: * instead of using the {!Flx_cil_cil.currentLoc} *)
2124: val warnLoc: location -> ('a,unit,Flx_cil_pretty.doc) format -> 'a
2125:
2126: (** Sometimes you do not want to see the syntactic sugar that the above
2127: * pretty-printing functions add. In that case you can use the following
2128: * pretty-printing functions. But note that the output of these functions is
2129: * not valid C *)
2130:
2131: (** Flx_cil_pretty-print the internal representation of an expression *)
2132: val d_plainexp: unit -> exp -> Flx_cil_pretty.doc
2133:
2134: (** Flx_cil_pretty-print the internal representation of an integer *)
2135: val d_plaininit: unit -> init -> Flx_cil_pretty.doc
2136:
2137: (** Flx_cil_pretty-print the internal representation of an lvalue *)
2138: val d_plainlval: unit -> lval -> Flx_cil_pretty.doc
2139:
2140: (** Flx_cil_pretty-print the internal representation of an lvalue offset
2141: val d_plainoffset: unit -> offset -> Flx_cil_pretty.doc *)
2142:
2143: (** Flx_cil_pretty-print the internal representation of a type *)
2144: val d_plaintype: unit -> typ -> Flx_cil_pretty.doc
2145:
2146:
2147:
2148: (** {b ALPHA conversion} *)
2149:
2150: (** This is the type of the elements that are recorded by the alpha
2151: * conversion functions in order to be able to undo changes to the tables
2152: * they modify. Useful for implementing
2153: * scoping *)
2154: type undoAlphaElement
2155:
2156: (** This is the type of the elements of the alpha renaming table. *)
2157: type alphaTableData
2158:
2159:
2160: (** Create a new name based on a given name. The new name is formed from a
2161: * prefix (obtained from the given name by stripping a suffix consisting of _
2162: * followed by only digits), followed by a special separator and then by a
2163: * positive integer suffix. The first argument is a table mapping name
2164: * prefixes to some data that specifies what suffixes have been used and how
2165: * to create the new one. This function updates the table with the new
2166: * largest suffix generated. The "undolist" argument, when present, will be
2167: * used by the function to record information that can be used by
2168: * {!Flx_cil_cil.undoAlphaChanges} to undo those changes. Note that the undo
2169: * information will be in reverse order in which the action occurred. Returns
2170: * the new name and, if different from the lookupname, the location of the
2171: * previous occurrence. This function knows about the location implicitly
2172: * from the {!Flx_cil_cil.currentLoc}. *)
2173: val newAlphaName: alphaTable:(string, alphaTableData ref) Hashtbl.t ->
2174: undolist: undoAlphaElement list ref option ->
2175: lookupname:string -> string * location
2176:
2177:
2178: (** Register a name with an alpha conversion table to ensure that when later
2179: * we call newAlphaName we do not end up generating this one *)
2180: val registerAlphaName: alphaTable:(string, alphaTableData ref) Hashtbl.t ->
2181: undolist: undoAlphaElement list ref option ->
2182: lookupname:string -> unit
2183:
2184: (** Split the name in preparation for newAlphaName. The prefix returned is
2185: used to index into the hashtable. The next result value is a separator
2186: (either empty or the separator chosen to separate the original name from
2187: the index) *)
2188: val docAlphaTable: unit -> (string, alphaTableData ref) Hashtbl.t -> Flx_cil_pretty.doc
2189:
2190:
2191: val getAlphaPrefix: lookupname:string -> string
2192:
2193: (** Undo the changes to a table *)
2194: val undoAlphaChanges: alphaTable:(string, alphaTableData ref) Hashtbl.t ->
2195: undolist:undoAlphaElement list -> unit
2196:
2197: (** Assign unique names to local variables. This might be necessary after you
2198: * transformed the code and added or renamed some new variables. Names are
2199: * not used by CIL internally, but once you print the file out the compiler
2200: * downstream might be confused. You might
2201: * have added a new global that happens to have the same name as a local in
2202: * some function. Rename the local to ensure that there would never be
2203: * confusioin. Or, viceversa, you might have added a local with a name that
2204: * conflicts with a global *)
2205: val uniqueVarNames: file -> unit
2206:
2207: (** {b Optimization Passes} *)
2208:
2209: (** A peephole optimizer that processes two adjacent statements and possibly
2210: replaces them both. If some replacement happens, then the new statements
2211: are themselves subject to optimization *)
2212: val peepHole2: (instr * instr -> instr list option) -> stmt list -> unit
2213:
2214: (** Similar to [peepHole2] except that the optimization window consists of
2215: one statement, not two *)
2216: val peepHole1: (instr -> instr list option) -> stmt list -> unit
2217:
2218: (** {b Machine dependency} *)
2219:
2220:
2221: (** Raised when one of the bitsSizeOf functions cannot compute the size of a
2222: type. This can happen because the type contains array-length expressions
2223: that we don't know how to compute or because it is a type whose size is
2224: not defined (e.g. TFun or an undefined compinfo) *)
2225: exception SizeOfError of typ
2226:
2227: (** The size of a type, in bits. Trailing padding is added for structs and
2228: * arrays. Raises {!Flx_cil_cil.SizeOfError} when it cannot compute the size. This
2229: * function is architecture dependent, so you should only call this after you
2230: * call {!Flx_cil_cil.initCIL}. Remember that on GCC sizeof(void) is 1! *)
2231: val bitsSizeOf: typ -> int
2232:
2233: (* The size of a type, in bytes. Returns a constant expression or a "sizeof"
2234: * expression if it cannot compute the size. This function is architecture
2235: * dependent, so you should only call this after you call {!Flx_cil_cil.initCIL}. *)
2236: val sizeOf: typ -> exp
2237:
2238: (** The minimum alignment (in bytes) for a type. This function is
2239: * architecture dependent, so you should only call this after you call
2240: * {!Flx_cil_cil.initCIL}. *)
2241: val alignOf_int: typ -> int
2242:
2243: (** Give a type of a base and an offset, returns the number of bits from the
2244: * base address and the width (also expressed in bits) for the subobject
2245: * denoted by the offset. Raises {!Flx_cil_cil.SizeOfError} when it cannot compute
2246: * the size. This function is architecture dependent, so you should only call
2247: * this after you call {!Flx_cil_cil.initCIL}. *)
2248: val bitsOffset: typ -> offset -> int * int
2249:
2250:
2251: (** Whether "char" is unsigned. Set after you call {!Flx_cil_cil.initCIL} *)
2252: val char_is_unsigned: bool ref
2253:
2254: (** Whether the machine is little endian. Set after you call {!Flx_cil_cil.initCIL} *)
2255: val little_endian: bool ref
2256:
2257: (** Represents a location that cannot be determined *)
2258: val locUnknown: location
2259:
2260: (** Return the location of an instruction *)
2261: val get_instrLoc: instr -> location
2262:
2263: (** Return the location of a global, or locUnknown *)
2264: val get_globalLoc: global -> location
2265:
2266: (** Return the location of a statement, or locUnknown *)
2267: val get_stmtLoc: stmtkind -> location
2268:
2269:
2270: (** Generate an {!Flx_cil_cil.exp} to be used in case of errors. *)
2271: val dExp: Flx_cil_pretty.doc -> exp
2272:
2273: (** Generate an {!Flx_cil_cil.instr} to be used in case of errors. *)
2274: val dInstr: Flx_cil_pretty.doc -> location -> instr
2275:
2276: (** Generate a {!Flx_cil_cil.global} to be used in case of errors. *)
2277: val dGlobal: Flx_cil_pretty.doc -> location -> global
2278:
2279: (** Like map but try not to make a copy of the list *)
2280: val mapNoCopy: ('a -> 'a) -> 'a list -> 'a list
2281:
2282: (** Like map but each call can return a list. Try not to make a copy of the
2283: list *)
2284: val mapNoCopyList: ('a -> 'a list) -> 'a list -> 'a list
2285:
2286: (** sm: return true if the first is a prefix of the second string *)
2287: val startsWith: string -> string -> bool
2288:
2289:
2290: (** {b An Interpreter for constructing CIL constructs} *)
2291:
2292: (** The type of argument for the interpreter *)
2293: type formatArg =
2294: Fe of exp
2295: | Feo of exp option (** For array lengths *)
2296: | Fu of unop
2297: | Fb of binop
2298: | Fk of ikind
2299: | FE of exp list (** For arguments in a function call *)
2300: | Ff of (string * typ * attributes) (** For a formal argument *)
2301: | FF of (string * typ * attributes) list (** For formal argument lists *)
2302: | Fva of bool (** For the ellipsis in a function type *)
2303: | Fv of varinfo
2304: | Fl of lval
2305: | Flo of lval option
2306:
2307: | Fo of offset
2308:
2309: | Fc of compinfo
2310: | Fi of instr
2311: | FI of instr list
2312: | Ft of typ
2313: | Fd of int
2314: | Fg of string
2315: | Fs of stmt
2316: | FS of stmt list
2317: | FA of attributes
2318:
2319: | Fp of attrparam
2320: | FP of attrparam list
2321:
2322: | FX of string
2323:
2324:
2325: (** Flx_cil_pretty-prints a format arg *)
2326: val d_formatarg: unit -> formatArg -> Flx_cil_pretty.doc
2327:
Start ocaml section to src/flx_cil_cilutil.mli[1
/1
]
1: # 9328 "./lpsrc/flx_cil.ipk"
2:
3: val doFlx_cil_check : bool ref
4: val logCalls : bool ref
5: val logWrites : bool ref
6: val doPartial : bool ref
7: val doSimpleMem : bool ref
8: val doOneRet : bool ref
9: val doStackGuard : bool ref
10: val doHeapify : bool ref
11: val makeCFG : bool ref
12: val printFlx_cil_stats : bool ref
13: val sliceGlobal : bool ref
14: val printStages : bool ref
15: val doCxxPP : bool ref
16: val libDir : string ref
17:
Start ocaml section to src/flx_cil_cilutil.ml[1
/1
]
1: # 9346 "./lpsrc/flx_cil.ipk"
2:
3: (* Keep here the globally-visible flags *)
4: let doFlx_cil_check= ref false (* Whether to check CIL *)
5:
6: let logCalls = ref false (* Whether to produce a log with all the function
7: * calls made *)
8: let logWrites = ref false (* Whether to produce a log with all the mem
9: * writes made *)
10: let doPartial = ref false (* Whether to do partial evaluation and constant
11: * folding *)
12: let doSimpleMem = ref false (* reduce complex memory expressions so that
13: * they contain at most one lval *)
14: let doOneRet = ref false (* make a functions have at most one 'return' *)
15: let doStackGuard = ref false (* instrument function calls and returns to
16: maintain a separate stack for return addresses *)
17: let doHeapify = ref false (* move stack-allocated arrays to the heap *)
18: let makeCFG = ref false (* turn the input CIL file into something more like
19: * a CFG *)
20: let printFlx_cil_stats = ref false
21:
22: (* when 'sliceGlobal' is set, then when 'rmtmps' runs, only globals*)
23: (* marked with #pragma cilnoremove(whatever) are kept; when used with *)
24: (* cilly.asm.exe, the effect is to slice the input on the noremove symbols *)
25: let sliceGlobal = ref false
26:
27:
28: let printStages = ref false
29:
30:
31: let doCxxPP = ref false
32:
33: let libDir = ref ""
34:
Start ocaml section to src/flx_cil_clist.ml[1
/1
]
1: # 9381 "./lpsrc/flx_cil.ipk"
2:
3: open Flx_cil_pretty
4: open Flx_cil_trace
5:
6: (* We often need to concatenate sequences and using lists for this purpose is
7: * expensive. So we define a kind of "concatenable lists" that are easier to
8: * concatenate *)
9: type 'a clist =
10: | CList of 'a list (* This is the only representation for empty
11: * *)
12: | CConsL of 'a * 'a clist
13: | CConsR of 'a clist * 'a
14: | CSeq of 'a clist * 'a clist (* We concatenate only two of them at this
15: * time. Neither is CEmpty. To be sure
16: * always use append to make these *)
17:
18: let rec listifyOnto (tail: 'a list) = function
19: CList l -> l @ tail
20: | CConsL (x, l) -> x :: listifyOnto tail l
21: | CConsR (l, x) -> listifyOnto (x :: tail) l
22: | CSeq (l1, l2) -> listifyOnto (listifyOnto tail l2) l1
23:
24: let toList l = listifyOnto [] l
25: let fromList l = CList l
26:
27:
28: let single x = CList [x]
29: let empty = CList []
30:
31: let checkBeforeAppend (l1: 'a clist) (l2: 'a clist) : bool =
32: l1 != l2 || l1 = (CList [])
33:
34: let append l1 l2 =
35: if l1 = CList [] then l2 else
36: if l2 = CList [] then l1 else
37: begin
38: if l1 == l2 then
39: raise (Failure "You should not use Flx_cil_clist.append to double a list");
40: CSeq (l1, l2)
41: end
42:
43: let rec length (acc: int) = function
44: CList l -> acc + (List.length l)
45: | CConsL (x, l) -> length (acc + 1) l
46: | CConsR (l, _) -> length (acc + 1) l
47: | CSeq (l1, l2) -> length (length acc l1) l2
48: let length l = length 0 l (* The external version *)
49:
50: let map (f: 'a -> 'b) (l: 'a clist) : 'b clist =
51: let rec loop = function
52: CList l -> CList (List.map f l)
53: | CConsL (x, l) -> let x' = f x in CConsL (x', loop l)
54: | CConsR (l, x) -> let l' = loop l in CConsR (l', f x)
55: | CSeq (l1, l2) -> let l1' = loop l1 in CSeq (l1', loop l2)
56: in
57: loop l
58:
59:
60: let fold_left (f: 'acc -> 'a -> 'acc) (start: 'acc) (l: 'a clist) =
61: let rec loop (start: 'acc) = function
62: CList l -> List.fold_left f start l
63: | CConsL (x, l) -> loop (f start x) l
64: | CConsR (l, x) -> let res = loop start l in f res x
65: | CSeq (l1, l2) ->
66: let res1 = loop start l1 in
67: loop res1 l2
68: in
69: loop start l
70:
71: let iter (f: 'a -> unit) (l: 'a clist) : unit =
72: let rec loop = function
73: CList l -> List.iter f l
74: | CConsL (x, l) -> f x; loop l
75: | CConsR (l, x) -> loop l; f x
76: | CSeq (l1, l2) -> loop l1; loop l2
77: in
78: loop l
79:
80:
81: let rec rev = function
82: CList l -> CList (List.rev l)
83: | CConsL (x, l) -> CConsR (rev l, x)
84: | CConsR (l, x) -> CConsL (x, rev l)
85: | CSeq (l1, l2) -> CSeq (rev l2, rev l1)
86:
87:
88: let docCList (sep: doc) (doone: 'a -> doc) () (dl: 'a clist) =
89: fold_left
90: (fun (acc: doc) (elem: 'a) ->
91: let elemd = doone elem in
92: if acc == nil then elemd else acc ++ sep ++ elemd)
93: nil
94: dl
95:
96:
97: (* let debugFlx_cil_check (lst: 'a clist) : unit =*)
98: (* (* use a hashtable to store values encountered *)*)
99: (* let tbl : 'a bool H.t = (H.create 13) in*)
100:
101: (* letrec recurse (node: 'a clist) =*)
102: (* (* have we seen*)*)
103:
104: (* match node with*)
105: (* | CList*)
106:
107:
108: (* --------------- testing ----------------- *)
109: type boxedInt =
110: | BI of int
111: | SomethingElse
112:
113: let d_boxedInt () b =
114: match b with
115: | BI(i) -> (dprintf "%d" i)
116: | SomethingElse -> (text "somethingElse")
117:
118:
119: (* sm: some simple tests of CLists *)
120: let testCList () : unit =
121: begin
122: (trace "sm" (dprintf "in testCList\n"));
123:
124: let clist1 = (fromList [BI(1); BI(2); BI(3)]) in
125: (trace "sm" (dprintf "length of clist1 is %d\n"
126: (length clist1) ));
127:
128: let flattened = (toList clist1) in
129: (trace "sm" (dprintf "flattened: %a\n"
130: (docList (chr ',' ++ break) (d_boxedInt ()))
131: flattened));
132:
133:
134: end
Start ocaml section to src/flx_cil_clist.mli[1
/1
]
1: # 9516 "./lpsrc/flx_cil.ipk"
2:
3: (** Flx_cil_utilities for managing "concatenable lists" (clists). We often need to
4: concatenate sequences, and using lists for this purpose is expensive. This
5: module provides routines to manage such lists more efficiently. In this
6: model, we never do cons or append explicitly. Instead we maintain
7: the elements of the list in a special data structure. Routines are provided
8: to convert to/from ordinary lists, and carry out common list operations.*)
9:
10: (** The clist datatype. A clist can be an ordinary list, or a clist preceded
11: or followed by an element, or two clists implicitly appended together*)
12: type 'a clist =
13: | CList of 'a list (** The only representation for the empty
14: list. Try to use sparingly. *)
15: | CConsL of 'a * 'a clist (** Do not use this a lot because scanning
16: * it is not tail recursive *)
17: | CConsR of 'a clist * 'a
18: | CSeq of 'a clist * 'a clist (** We concatenate only two of them at this
19: time. Neither is the empty clist. To be
20: sure always use append to make these *)
21:
22:
23: (** Convert a clist to an ordinary list *)
24: val toList: 'a clist -> 'a list
25:
26: (** Convert an ordinary list to a clist *)
27: val fromList: 'a list -> 'a clist
28:
29: (** Create a clist containing one element *)
30: val single: 'a -> 'a clist
31:
32: (** The empty clist *)
33: val empty: 'a clist
34:
35:
36: (** Append two clists *)
37: val append: 'a clist -> 'a clist -> 'a clist
38:
39: (** A useful check to assert before an append. It checks that the two lists
40: * are not identically the same (Except if they are both empty) *)
41: val checkBeforeAppend: 'a clist -> 'a clist -> bool
42:
43: (** Find the length of a clist *)
44: val length: 'a clist -> int
45:
46: (** Map a function over a clist. Returns another clist *)
47: val map: ('a -> 'b) -> 'a clist -> 'b clist
48:
49:
50: (** A version of fold_left that works on clists *)
51: val fold_left: ('acc -> 'a -> 'acc) -> 'acc -> 'a clist -> 'acc
52:
53: (** A version of iter that works on clists *)
54: val iter: ('a -> unit) -> 'a clist -> unit
55:
56: (** Reverse a clist *)
57: val rev: 'a clist -> 'a clist
58:
59: (** A document for printing a clist (similar to [docList]) *)
60: val docCList:
61: Flx_cil_pretty.doc -> ('a -> Flx_cil_pretty.doc) -> unit -> 'a clist -> Flx_cil_pretty.doc
62:
Start ocaml section to src/flx_cil_formatcil.ml[1
/1
]
1: # 9579 "./lpsrc/flx_cil.ipk"
2: open Flx_cil_cil
3: open Flx_cil_pretty
4: open Flx_cil_trace (* sm: 'trace' function *)
5: module E = Flx_cil_errormsg
6: module H = Hashtbl
7:
8: let noMemoize = ref false
9:
10: let expMemoTable :
11: (string, (((string * formatArg) list -> exp) *
12: (exp -> formatArg list option))) H.t = H.create 23
13:
14: let typeMemoTable :
15: (string, (((string * formatArg) list -> typ) *
16: (typ -> formatArg list option))) H.t = H.create 23
17:
18: let lvalMemoTable :
19: (string, (((string * formatArg) list -> lval) *
20: (lval -> formatArg list option))) H.t = H.create 23
21:
22: let instrMemoTable :
23: (string, ((location -> (string * formatArg) list -> instr) *
24: (instr -> formatArg list option))) H.t = H.create 23
25:
26: let stmtMemoTable :
27: (string, ((string -> typ -> varinfo) ->
28: location ->
29: (string * formatArg) list -> stmt)) H.t = H.create 23
30:
31: let stmtsMemoTable :
32: (string, ((string -> typ -> varinfo) ->
33: location ->
34: (string * formatArg) list -> stmt list)) H.t = H.create 23
35:
36:
37: let doParse (prog: string)
38: (theParser: (Lexing.lexbuf -> Flx_cil_formatparse.token)
39: -> Lexing.lexbuf -> 'a)
40: (memoTable: (string, 'a) H.t) : 'a =
41: try
42: if !noMemoize then raise Not_found else
43: H.find memoTable prog
44: with Not_found -> begin
45: let lexbuf = Flx_cil_formatlex.init prog in
46: try
47: Flx_cil_formatparse.initialize Flx_cil_formatlex.initial lexbuf;
48: let res = theParser Flx_cil_formatlex.initial lexbuf in
49: H.add memoTable prog res;
50: Flx_cil_formatlex.finish ();
51: res
52: with Parsing.Parse_error -> begin
53: Flx_cil_formatlex.finish ();
54: E.s (E.error "Parsing error: %s" prog)
55: end
56: | e -> begin
57: ignore (E.log "Caught %s while parsing\n" (Printexc.to_string e));
58: Flx_cil_formatlex.finish ();
59: raise e
60: end
61: end
62:
63:
64: let cExp (prog: string) : (string * formatArg) list -> exp =
65: let cf = doParse prog Flx_cil_formatparse.expression expMemoTable in
66: (fst cf)
67:
68: let cLval (prog: string) : (string * formatArg) list -> lval =
69: let cf = doParse prog Flx_cil_formatparse.lval lvalMemoTable in
70: (fst cf)
71:
72: let cType (prog: string) : (string * formatArg) list -> typ =
73: let cf = doParse prog Flx_cil_formatparse.typename typeMemoTable in
74: (fst cf)
75:
76: let cInstr (prog: string) : location -> (string * formatArg) list -> instr =
77: let cf = doParse prog Flx_cil_formatparse.instr instrMemoTable in
78: (fst cf)
79:
80: let cStmt (prog: string) : (string -> typ -> varinfo) ->
81: location -> (string * formatArg) list -> stmt =
82: let cf = doParse prog Flx_cil_formatparse.stmt stmtMemoTable in
83: cf
84:
85: let cStmts (prog: string) :
86: (string -> typ -> varinfo) ->
87: location -> (string * formatArg) list -> stmt list =
88: let cf = doParse prog Flx_cil_formatparse.stmt_list stmtsMemoTable in
89: cf
90:
91:
92:
93: (* Match an expression *)
94: let dExp (prog: string) : exp -> formatArg list option =
95: let df = doParse prog Flx_cil_formatparse.expression expMemoTable in
96: (snd df)
97:
98: (* Match an lvalue *)
99: let dLval (prog: string) : lval -> formatArg list option =
100: let df = doParse prog Flx_cil_formatparse.lval lvalMemoTable in
101: (snd df)
102:
103:
104: (* Match a type *)
105: let dType (prog: string) : typ -> formatArg list option =
106: let df = doParse prog Flx_cil_formatparse.typename typeMemoTable in
107: (snd df)
108:
109:
110:
111: (* Match an instruction *)
112: let dInstr (prog: string) : instr -> formatArg list option =
113: let df = doParse prog Flx_cil_formatparse.instr instrMemoTable in
114: (snd df)
115:
116:
117: let test () =
118: (* Construct a dummy function *)
119: let func = emptyFunction "test_formatcil" in
120: (* Construct a few varinfo *)
121: let res = makeLocalVar func "res" (TPtr(intType, [])) in
122: let arr = makeLocalVar func "arr" (TArray(TPtr(intType, []),
123: Some (integer 8), [])) in
124: let fptr = makeLocalVar func "fptr"
125: (TPtr(TFun(intType, None, false, []), [])) in
126: (* Construct an instruction *)
127: let makeInstr () =
128: Call(Some (var res),
129: Lval (Mem (CastE(TPtr(TFun(TPtr(intType, []),
130: Some [ ("", intType, []);
131: ("a2", TPtr(intType, []), []);
132: ("a3", TPtr(TPtr(intType, []),
133: []), []) ],
134: false, []), []),
135: Lval (var fptr))),
136: NoOffset),
137: [ ], locUnknown)
138: in
139: let times = 100000 in
140: (* Make the instruction the regular way *)
141: Flx_cil_stats.time "make instruction regular"
142: (fun _ -> for i = 0 to times do ignore (makeInstr ()) done)
143: ();
144: (* Now make the instruction interpreted *)
145: noMemoize := true;
146: Flx_cil_stats.time "make instruction interpreted"
147: (fun _ -> for i = 0 to times do
148: let ins =
149: cInstr "%v:res = (* ((int * (*)(int, int * a2, int * * a3))%v:fptr))();"
150: locUnknown [ ("res", Fv res);
151: ("fptr", Fv fptr) ]
152: in
153: ()
154: done)
155: ();
156: (* Now make the instruction interpreted with memoization *)
157: noMemoize := false;
158: Flx_cil_stats.time "make instruction interpreted memoized"
159: (fun _ -> for i = 0 to times do
160: let ins =
161: cInstr "%v:res = (* ((int * (*)(int, int * a2, int * * a3))%v:fptr))();"
162: locUnknown [ ("res", Fv res); ("fptr", Fv fptr) ]
163: in
164: ()
165: done)
166: ();
167: (* Now make the instruction interpreted with partial application *)
168: let partInstr =
169: cInstr "%v:res = (* ((int * (*)(int, int * a2, int * * a3))%v:fptr))();" in
170: Flx_cil_stats.time "make instruction interpreted partial"
171: (fun _ -> for i = 0 to times do
172: let ins =
173: partInstr
174: locUnknown [ ("res", Fv res); ("fptr", Fv fptr) ]
175: in
176: ()
177: done)
178: ();
179:
180: ()
181:
182:
Start ocaml section to src/flx_cil_formatcil.mli[1
/1
]
1: # 9762 "./lpsrc/flx_cil.ipk"
2:
3: (** {b An Interpreter for constructing CIL constructs} *)
4:
5:
6: (** Constructs an expression based on the program and the list of arguments.
7: * Each argument consists of a name followed by the actual data. This
8: * argument will be placed instead of occurrences of "%v:name" in the pattern
9: * (where the "v" is dependent on the type of the data). The parsing of the
10: * string is memoized. * Only the first expression is parsed. *)
11: val cExp: string -> (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.exp
12:
13: (** Constructs an lval based on the program and the list of arguments.
14: * Only the first lvalue is parsed.
15: * The parsing of the string is memoized. *)
16: val cLval: string -> (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.lval
17:
18: (** Constructs a type based on the program and the list of arguments.
19: * Only the first type is parsed.
20: * The parsing of the string is memoized. *)
21: val cType: string -> (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.typ
22:
23:
24: (** Constructs an instruction based on the program and the list of arguments.
25: * Only the first instruction is parsed.
26: * The parsing of the string is memoized. *)
27: val cInstr: string -> Flx_cil_cil.location ->
28: (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.instr
29:
30: (* Constructs a statement based on the program and the list of arguments. We
31: * also pass a function that can be used to make new varinfo's for the
32: * declared variables, and a location to be used for the statements. Only the
33: * first statement is parsed. The parsing of the string is memoized. *)
34: val cStmt: string ->
35: (string -> Flx_cil_cil.typ -> Flx_cil_cil.varinfo) ->
36: Flx_cil_cil.location -> (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.stmt
37:
38: (** Constructs a list of statements *)
39: val cStmts: string ->
40: (string -> Flx_cil_cil.typ -> Flx_cil_cil.varinfo) ->
41: Flx_cil_cil.location -> (string * Flx_cil_cil.formatArg) list ->
42: Flx_cil_cil.stmt list
43:
44: (** Deconstructs an expression based on the program. Produces an optional
45: * list of format arguments. The parsing of the string is memoized. *)
46: val dExp: string -> Flx_cil_cil.exp -> Flx_cil_cil.formatArg list option
47:
48: (** Deconstructs an lval based on the program. Produces an optional
49: * list of format arguments. The parsing of the string is memoized. *)
50: val dLval: string -> Flx_cil_cil.lval -> Flx_cil_cil.formatArg list option
51:
52:
53: (** Deconstructs a type based on the program. Produces an optional list of
54: * format arguments. The parsing of the string is memoized. *)
55: val dType: string -> Flx_cil_cil.typ -> Flx_cil_cil.formatArg list option
56:
57:
58: (** Deconstructs an instruction based on the program. Produces an optional
59: * list of format arguments. The parsing of the string is memoized. *)
60: val dInstr: string -> Flx_cil_cil.instr -> Flx_cil_cil.formatArg list option
61:
62:
63: (** If set then will not memoize the parsed patterns *)
64: val noMemoize: bool ref
65:
66: (** Just a testing function *)
67: val test: unit -> unit
68:
Start ocaml section to src/flx_cil_formatlex.mli[1
/1
]
1: # 9831 "./lpsrc/flx_cil.ipk"
2:
3: exception Eof
4: exception InternalError of string
5:
6: val keywords : (string, Flx_cil_formatparse.token) Hashtbl.t
7: val scan_ident : string -> Flx_cil_formatparse.token
8: val init : prog:string -> Lexing.lexbuf
9: val finish : unit -> unit
10: val error : string -> 'a
11: val scan_escape : string -> string
12: val get_value : char -> int
13: val scan_hex_escape : string -> string
14: val scan_oct_escape : string -> string
15: val wbtowc : string -> string
16: val wstr_to_warray : string -> string
17: val getArgName : Lexing.lexbuf -> int -> string
18: val initial : Lexing.lexbuf -> Flx_cil_formatparse.token
19: val comment : Lexing.lexbuf -> unit
20: val endline : Lexing.lexbuf -> Flx_cil_formatparse.token
21:
Start data section to src/flx_cil_formatlex.mll[1
/1
]
1: (* A simple lexical analyzer for constructing CIL based on format strings *)
2: {
3: open Flx_cil_formatparse
4: exception Eof
5: exception InternalError of string
6: module H = Hashtbl
7: module E = Flx_cil_errormsg
8: (*
9: ** Keyword hashtable
10: *)
11: let keywords = H.create 211
12:
13: (*
14: ** Useful primitives
15: *)
16: let scan_ident id =
17: try H.find keywords id
18: with Not_found -> IDENT id (* default to variable name *)
19:
20: (*
21: ** Buffer processor
22: *)
23:
24:
25: let init ~(prog: string) : Lexing.lexbuf =
26: H.clear keywords;
27: Flx_cil_lexerhack.currentPattern := prog;
28: List.iter
29: (fun (key, token) -> H.add keywords key token)
30: [ ("const", CONST); ("__const", CONST); ("__const__", CONST);
31: ("static", STATIC);
32: ("extern", EXTERN);
33: ("long", LONG);
34: ("short", SHORT);
35: ("signed", SIGNED);
36: ("unsigned", UNSIGNED);
37: ("volatile", VOLATILE);
38: ("char", CHAR);
39: ("int", INT);
40: ("_Imaginary", IMAGINARY);
41: ("_Complex", COMPLEX);
42: ("_Bool", BOOL);
43: ("float", FLOAT);
44: ("double", DOUBLE);
45: ("void", VOID);
46: ("enum", ENUM);
47: ("struct", STRUCT);
48: ("typedef", TYPEDEF);
49: ("union", UNION);
50: ("break", BREAK);
51: ("continue", CONTINUE);
52: ("goto", GOTO);
53: ("return", RETURN);
54: ("switch", SWITCH);
55: ("case", CASE);
56: ("default", DEFAULT);
57: ("while", WHILE);
58: ("do", DO);
59: ("for", FOR);
60: ("if", IF);
61: ("else", ELSE);
62: ("__attribute__", ATTRIBUTE); ("__attribute", ATTRIBUTE);
63: ("__int64", INT64);
64: ("__builtin_va_arg", BUILTIN_VA_ARG);
65: ];
66: E.startParsingFromString prog
67:
68: let finish () =
69: E.finishParsing ()
70:
71: (*** Error handling ***)
72: let error msg =
73: E.parse_error msg
74:
75:
76: (*** escape character management ***)
77: let scan_escape str =
78: match str with
79: "n" -> "\n"
80: | "r" -> "\r"
81: | "t" -> "\t"
82: | "b" -> "\b"
83: | "f" -> "\012" (* ASCII code 12 *)
84: | "v" -> "\011" (* ASCII code 11 *)
85: | "a" -> "\007" (* ASCII code 7 *)
86: | "e" -> "\027" (* ASCII code 27. This is a GCC extension *)
87: | _ -> str
88:
89: let get_value chr =
90: match chr with
91: '0'..'9' -> (Char.code chr) - (Char.code '0')
92: | 'a'..'z' -> (Char.code chr) - (Char.code 'a') + 10
93: | 'A'..'Z' -> (Char.code chr) - (Char.code 'A') + 10
94: | _ -> 0
95: let scan_hex_escape str =
96: String.make 1 (Char.chr (
97: (get_value (String.get str 0)) * 16
98: + (get_value (String.get str 1))
99: ))
100: let scan_oct_escape str =
101: (* weimer: wide-character constants like L'\400' may be bigger than
102: * 256 (in fact, may be up to 511), so Char.chr cannot be used directly *)
103: let the_value = (get_value (String.get str 0)) * 64
104: + (get_value (String.get str 1)) * 8
105: + (get_value (String.get str 2)) in
106: if the_value < 256 then String.make 1 (Char.chr the_value )
107: else (String.make 1 (Char.chr (the_value / 256))) ^
108: (String.make 1 (Char.chr (the_value mod 256)))
109:
110: (* ISO standard locale-specific function to convert a wide character
111: * into a sequence of normal characters. Here we work on strings.
112: * We convert L"Hi" to "H\000i\000" *)
113: let wbtowc wstr =
114: let len = String.length wstr in
115: let dest = String.make (len * 2) '\000' in
116: for i = 0 to len-1 do
117: dest.[i*2] <- wstr.[i] ;
118: done ;
119: dest
120:
121: (* This function converst the "Hi" in L"Hi" to { L'H', L'i', L'\0' } *)
122: let wstr_to_warray wstr =
123: let len = String.length wstr in
124: let res = ref "{ " in
125: for i = 0 to len-1 do
126: res := !res ^ (Printf.sprintf "L'%c', " wstr.[i])
127: done ;
128: res := !res ^ "}" ;
129: !res
130:
131: let getArgName (l: Lexing.lexbuf) (prefixlen: int) =
132: let lexeme = Lexing.lexeme l in
133: let ll = String.length lexeme in
134: if ll > prefixlen then
135: String.sub lexeme (prefixlen + 1) (ll - prefixlen - 1)
136: else
137: ""
138: }
139:
140: let decdigit = ['0'-'9']
141: let octdigit = ['0'-'7']
142: let hexdigit = ['0'-'9' 'a'-'f' 'A'-'F']
143: let letter = ['a'- 'z' 'A'-'Z']
144:
145: let floatsuffix = ['f' 'F' 'l' 'L']
146:
147: let usuffix = ['u' 'U']
148: let lsuffix = "l"|"L"|"ll"|"LL"
149: let intsuffix = lsuffix | usuffix | usuffix lsuffix | lsuffix usuffix
150:
151: let intnum = decdigit+ intsuffix?
152: let octnum = '0' octdigit+ intsuffix?
153: let hexnum = '0' ['x' 'X'] hexdigit+ intsuffix?
154:
155: let exponent = ['e' 'E']['+' '-']? decdigit+
156: let fraction = '.' decdigit+
157: let floatraw = (intnum? fraction)
158: |(intnum exponent)
159: |(intnum? fraction exponent)
160: |(intnum '.')
161: |(intnum '.' exponent)
162: let floatnum = floatraw floatsuffix?
163:
164: let ident = (letter|'_')(letter|decdigit|'_')*
165: let attribident = (letter|'_')(letter|decdigit|'_'|':')
166: let blank = [' ' '\t' '\012' '\r']
167: let escape = '\\' _
168: let hex_escape = '\\' ['x' 'X'] hexdigit hexdigit
169: let oct_escape = '\\' octdigit octdigit octdigit
170:
171:
172: (* The arguments are of the form %l:foo *)
173: let argname = ':' ident
174:
175: rule initial =
176: parse blank { initial lexbuf}
177: | "/*" { let _ = comment lexbuf in
178: initial lexbuf}
179: | "//" { endline lexbuf }
180: | "\n" { E.newline (); initial lexbuf}
181: | floatnum {CST_FLOAT (Lexing.lexeme lexbuf)}
182: | hexnum {CST_INT (Lexing.lexeme lexbuf)}
183: | octnum {CST_INT (Lexing.lexeme lexbuf)}
184: | intnum {CST_INT (Lexing.lexeme lexbuf)}
185: | "..." {ELLIPSIS}
186: | "-=" {MINUS_EQ}
187: | "+=" {PLUS_EQ}
188: | "*=" {STAR_EQ}
189: | "<<" {INF_INF}
190: | ">>" {SUP_SUP}
191: | "==" {EQ_EQ}
192: | "!=" {EXCLAM_EQ}
193: | "<=" {INF_EQ}
194: | ">=" {SUP_EQ}
195: | "=" {EQ}
196: | "<" {INF}
197: | ">" {SUP}
198: | "++" {PLUS_PLUS}
199: | "--" {MINUS_MINUS}
200: | "->" {ARROW}
201: | '+' {PLUS}
202: | '-' {MINUS}
203: | '*' {STAR}
204: | '/' {SLASH}
205: | '!' {EXCLAM}
206: | '&' {AND}
207: | '|' {PIPE}
208: | '^' {CIRC}
209: | '~' {TILDE}
210: | '[' {LBRACKET}
211: | ']' {RBRACKET}
212: | '{' {LBRACE}
213: | '}' {RBRACE}
214: | '(' {LPAREN}
215: | ')' {RPAREN}
216: | ';' {SEMICOLON}
217: | ',' {COMMA}
218: | '.' {DOT}
219: | ':' {COLON}
220: | '?' {QUEST}
221: | "sizeof" {SIZEOF}
222:
223: | "%eo" argname {ARG_eo (getArgName lexbuf 3) }
224: | "%e" argname {ARG_e (getArgName lexbuf 2) }
225: | "%E" argname {ARG_E (getArgName lexbuf 2) }
226: | "%u" argname {ARG_u (getArgName lexbuf 2) }
227: | "%b" argname {ARG_b (getArgName lexbuf 2) }
228: | "%t" argname {ARG_t (getArgName lexbuf 2) }
229: | "%d" argname {ARG_d (getArgName lexbuf 2) }
230: | "%lo" argname {ARG_lo (getArgName lexbuf 3) }
231: | "%l" argname {ARG_l (getArgName lexbuf 2) }
232: | "%i" argname {ARG_i (getArgName lexbuf 2) }
233: | "%I" argname {ARG_I (getArgName lexbuf 2) }
234: | "%o" argname {ARG_o (getArgName lexbuf 2) }
235: | "%va" argname {ARG_va (getArgName lexbuf 3) }
236: | "%v" argname {ARG_v (getArgName lexbuf 2) }
237: | "%k" argname {ARG_k (getArgName lexbuf 2) }
238: | "%f" argname {ARG_f (getArgName lexbuf 2) }
239: | "%F" argname {ARG_F (getArgName lexbuf 2) }
240: | "%p" argname {ARG_p (getArgName lexbuf 2) }
241: | "%P" argname {ARG_P (getArgName lexbuf 2) }
242: | "%s" argname {ARG_s (getArgName lexbuf 2) }
243: | "%S" argname {ARG_S (getArgName lexbuf 2) }
244: | "%g" argname {ARG_g (getArgName lexbuf 2) }
245: | "%A" argname {ARG_A (getArgName lexbuf 2) }
246: | "%c" argname {ARG_c (getArgName lexbuf 2) }
247:
248: | '%' {PERCENT}
249: | ident {scan_ident (Lexing.lexeme lexbuf)}
250: | eof {EOF}
251: | _ {E.parse_error
252: "Flx_cil_formatlex: Invalid symbol"
253: (Lexing.lexeme_start lexbuf)
254: (Lexing.lexeme_end lexbuf);
255: raise Parsing.Parse_error
256: }
257:
258: and comment =
259: parse
260: "*/" { () }
261: | '\n' { E.newline (); comment lexbuf }
262: | _ { comment lexbuf }
263:
264:
265: and endline = parse
266: '\n' { E.newline (); initial lexbuf}
267: | _ { endline lexbuf}
268:
269:
Start ocaml section to src/flx_cil_formatparse.mli[1
/1
]
1: # 10124 "./lpsrc/flx_cil.ipk"
2:
3: type token =
4: IDENT of string
5: | CST_CHAR of string
6: | CST_INT of string
7: | CST_FLOAT of string
8: | CST_STRING of string
9: | CST_WSTRING of string
10: | NAMED_TYPE of string
11: | EOF
12: | BOOL
13: | CHAR
14: | INT
15: | DOUBLE
16: | FLOAT
17: | COMPLEX
18: | IMAGINARY
19: | VOID
20: | INT64
21: | INT32
22: | ENUM
23: | STRUCT
24: | TYPEDEF
25: | UNION
26: | SIGNED
27: | UNSIGNED
28: | LONG
29: | SHORT
30: | VOLATILE
31: | EXTERN
32: | STATIC
33: | CONST
34: | RESTRICT
35: | AUTO
36: | REGISTER
37: | ARG_e of string
38: | ARG_eo of string
39: | ARG_E of string
40: | ARG_u of string
41: | ARG_b of string
42: | ARG_t of string
43: | ARG_d of string
44: | ARG_lo of string
45: | ARG_l of string
46: | ARG_i of string
47: | ARG_o of string
48: | ARG_va of string
49: | ARG_f of string
50: | ARG_F of string
51: | ARG_A of string
52: | ARG_v of string
53: | ARG_k of string
54: | ARG_c of string
55: | ARG_s of string
56: | ARG_p of string
57: | ARG_P of string
58: | ARG_I of string
59: | ARG_S of string
60: | ARG_g of string
61: | SIZEOF
62: | ALIGNOF
63: | EQ
64: | ARROW
65: | DOT
66: | EQ_EQ
67: | EXCLAM_EQ
68: | INF
69: | SUP
70: | INF_EQ
71: | SUP_EQ
72: | MINUS_EQ
73: | PLUS_EQ
74: | STAR_EQ
75: | PLUS
76: | MINUS
77: | STAR
78: | SLASH
79: | PERCENT
80: | TILDE
81: | AND
82: | PIPE
83: | CIRC
84: | EXCLAM
85: | AND_AND
86: | PIPE_PIPE
87: | INF_INF
88: | SUP_SUP
89: | PLUS_PLUS
90: | MINUS_MINUS
91: | RPAREN
92: | LPAREN
93: | RBRACE
94: | LBRACE
95: | LBRACKET
96: | RBRACKET
97: | COLON
98: | SEMICOLON
99: | COMMA
100: | ELLIPSIS
101: | QUEST
102: | BREAK
103: | CONTINUE
104: | GOTO
105: | RETURN
106: | SWITCH
107: | CASE
108: | DEFAULT
109: | WHILE
110: | DO
111: | FOR
112: | IF
113: | THEN
114: | ELSE
115: | ATTRIBUTE
116: | INLINE
117: | ASM
118: | TYPEOF
119: | FUNCTION__
120: | PRETTY_FUNCTION__
121: | LABEL__
122: | BUILTIN_VA_ARG
123: | BUILTIN_VA_LIST
124: | BLOCKATTRIBUTE
125: | DECLSPEC
126: | MSASM of string
127: | MSATTR of string
128: | PRAGMA
129:
130:
131: val initialize : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> unit
132: val expression :
133: (Lexing.lexbuf -> token) ->
134: Lexing.lexbuf ->
135: ((string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.exp) *
136: (Flx_cil_cil.exp -> Flx_cil_cil.formatArg list option)
137: val typename :
138: (Lexing.lexbuf -> token) ->
139: Lexing.lexbuf ->
140: ((string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.typ) *
141: (Flx_cil_cil.typ -> Flx_cil_cil.formatArg list option)
142: val offset :
143: (Lexing.lexbuf -> token) ->
144: Lexing.lexbuf ->
145: (Flx_cil_cil.typ ->
146: (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.offset) *
147: (Flx_cil_cil.offset -> Flx_cil_cil.formatArg list option)
148: val lval :
149: (Lexing.lexbuf -> token) ->
150: Lexing.lexbuf ->
151: ((string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.lval) *
152: (Flx_cil_cil.lval -> Flx_cil_cil.formatArg list option)
153: val instr :
154: (Lexing.lexbuf -> token) ->
155: Lexing.lexbuf ->
156: (Flx_cil_cil.location ->
157: (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.instr) *
158: (Flx_cil_cil.instr -> Flx_cil_cil.formatArg list option)
159: val stmt :
160: (Lexing.lexbuf -> token) ->
161: Lexing.lexbuf ->
162: (string -> Flx_cil_cil.typ -> Flx_cil_cil.varinfo) ->
163: Flx_cil_cil.location ->
164: (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.stmt
165: val stmt_list :
166: (Lexing.lexbuf -> token) ->
167: Lexing.lexbuf ->
168: (string -> Flx_cil_cil.typ -> Flx_cil_cil.varinfo) ->
169: Flx_cil_cil.location ->
170: (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.stmt list
171:
Start data section to src/flx_cil_formatparse.mly[1
/1
]
1: /*(* Parser for constructing CIL from format strings *)
2: */
3: %{
4: open Flx_cil_cil
5: open Flx_cil_pretty
6: module E = Flx_cil_errormsg
7:
8: let parse_error msg : 'a = (* sm: c++-mode highlight hack: -> ' <- *)
9: E.hadErrors := true;
10: E.parse_error
11: msg
12: (Parsing.symbol_start ()) (Parsing.symbol_end ())
13:
14:
15: let getArg (argname: string) (args: (string * formatArg) list) =
16: try
17: snd (List.find (fun (n, a) -> n = argname) args)
18: with _ ->
19: E.s (error "Pattern string %s does not have argument with name %s\n"
20: !Flx_cil_lexerhack.currentPattern argname)
21:
22: let wrongArgType (which: string) (expected: string) (found: formatArg) =
23: E.s (bug "Expecting %s argument (%s) and found %a\n"
24: expected which d_formatarg found)
25:
26: let doUnop (uo: unop) subexp =
27: ((fun args ->
28: let e = (fst subexp) args in
29: UnOp(uo, e, typeOf e)),
30:
31: (fun e -> match e with
32: UnOp(uo', e', _) when uo = uo' -> (snd subexp) e'
33: | _ -> None))
34:
35: let buildPlus e1 e2 : exp =
36: let t1 = typeOf e1 in
37: if isPointerType t1 then
38: BinOp(PlusPI, e1, e2, t1)
39: else
40: BinOp(PlusA, e1, e2, t1)
41:
42: let buildMinus e1 e2 : exp =
43: let t1 = typeOf e1 in
44: let t2 = typeOf e2 in
45: if isPointerType t1 then
46: if isPointerType t2 then
47: BinOp(MinusPP, e1, e2, intType)
48: else
49: BinOp(MinusPI, e1, e2, t1)
50: else
51: BinOp(MinusA, e1, e2, t1)
52:
53: let doBinop bop e1t e2t =
54: ((fun args ->
55: let e1 = (fst e1t) args in
56: let e2 = (fst e2t) args in
57: let t1 = typeOf e1 in
58: BinOp(bop, e1, e2, t1)),
59:
60: (fun e -> match e with
61: BinOp(bop', e1, e2, _) when bop' = bop -> begin
62: match (snd e1t) e1, (snd e2t) e2 with
63: Some m1, Some m2 -> Some (m1 @ m2)
64: | _, _ -> None
65: end
66: | _ -> None))
67:
68: (* Flx_cil_check the equivalence of two format lists *)
69: let rec checkSameFormat (fl1: formatArg list) (fl2: formatArg list) =
70: match fl1, fl2 with
71: [], [] -> true
72: | h1::t1, h2::t2 -> begin
73: let rec checkOffsetEq o1 o2 =
74: match o1, o2 with
75: NoOffset, NoOffset -> true
76: | Field(f1, o1'), Field(f2, o2') ->
77: f1.fname = f2.fname && checkOffsetEq o1' o2'
78: | Index(e1, o1'), Index(e2, o2') ->
79: checkOffsetEq o1' o2' && checkExpEq e1 e2
80: | _, _ -> false
81:
82: and checkExpEq e1 e2 =
83: match e1, e2 with
84: Const(CInt64(n1, _, _)), Const(CInt64(n2, _, _)) -> n1 = n2
85: | Lval l1, Lval l2 -> checkLvalEq l1 l2
86: | UnOp(uo1, e1, _), UnOp(uo2, e2, _) ->
87: uo1 = uo2 && checkExpEq e1 e2
88: | BinOp(bo1, e11, e12, _), BinOp(bo2, e21, e22, _) ->
89: bo1 = bo2 && checkExpEq e11 e21 && checkExpEq e21 e22
90: | AddrOf l1, AddrOf l2 -> checkLvalEq l1 l2
91: | StartOf l1, StartOf l2 -> checkLvalEq l1 l2
92: | SizeOf t1, SizeOf t2 -> typeSig t1 = typeSig t2
93: | _, _ ->
94: ignore (E.warn "checkSameFormat for Fe"); false
95:
96: and checkLvalEq l1 l2 =
97: match l1, l2 with
98: (Var v1, o1), (Var v2, o2) -> v1 == v2 && checkOffsetEq o1 o2
99: | (Mem e1, o1), (Mem e2, o2) ->
100: checkOffsetEq o1 o2 && checkExpEq e1 e2
101: | _, _ -> false
102: in
103: let hdeq =
104: match h1, h2 with
105: Fv v1, Fv v2 -> v1 == v2
106: | Fd n1, Fd n2 -> n1 = n2
107: | Fe e1, Fe e2 -> checkExpEq e1 e2
108: | Fi i1, Fi i2 -> ignore (E.warn "checkSameFormat for Fi"); false
109: | Ft t1, Ft t2 -> typeSig t1 = typeSig t2
110: | Fl l1, Fl l2 -> checkLvalEq l1 l2
111: | Fo o1, Fo o2 -> checkOffsetEq o1 o2
112: | Fc c1, Fc c2 -> c1 == c2
113: | _, _ -> false
114: in
115: hdeq || checkSameFormat t1 t2
116: end
117: | _, _ -> false
118:
119: let matchBinopEq (bopeq: binop -> bool) lvt et =
120: (fun i -> match i with
121: Set (lv, BinOp(bop', Lval (lv'), e', _), l) when bopeq bop' -> begin
122: match lvt lv, lvt lv', et e' with
123: Some m1, Some m1', Some m2 ->
124: (* Must check that m1 and m2 are the same *)
125: if checkSameFormat m1 m1' then
126: Some (m1 @ m2)
127: else
128: None
129: | _, _, _ -> None
130: end
131: | _ -> None)
132:
133: let doBinopEq bop lvt et =
134: ((fun loc args ->
135: let l = (fst lvt) args in
136: Set(l, BinOp(bop, (Lval l), (fst et) args, typeOfLval l), loc)),
137:
138: matchBinopEq (fun bop' -> bop = bop') (snd lvt) (snd et))
139:
140:
141: let getField (bt: typ) (fname: string) : fieldinfo =
142: match unrollType bt with
143: TComp(ci, _) -> begin
144: try
145: List.find (fun f -> fname = f.fname) ci.cfields
146: with Not_found ->
147: E.s (bug "Cannot find field %s in %s\n" fname (compFullName ci))
148: end
149: | t -> E.s (bug "Trying to access field %s in non-struct\n" fname)
150:
151:
152: let matchIntType (ik: ikind) (t:typ) : formatArg list option =
153: match unrollType t with
154: TInt(ik', _) when ik = ik' -> Some []
155: | _ -> None
156:
157: let matchFloatType (fk: fkind) (t:typ) : formatArg list option =
158: match unrollType t with
159: TFloat(fk', _) when fk = fk' -> Some []
160: | _ -> None
161:
162: let doAttr (id: string)
163: (aargs: (((string * formatArg) list -> attrparam list) *
164: (attrparam list -> formatArg list option)) option)
165: =
166: let t = match aargs with
167: Some t -> t
168: | None -> (fun _ -> []),
169: (function [] -> Some [] | _ -> None)
170: in
171: ((fun args -> Attr (id, (fst t) args)),
172:
173: (fun attrs ->
174: (* Find the attributes with the same ID *)
175: List.fold_left
176: (fun acc a ->
177: match acc, a with
178: Some _, _ -> acc (* We found one already *)
179: | None, Attr(id', args) when id = id' ->
180: (* Now match the arguments *)
181: (snd t) args
182: | None, _ -> acc)
183: None
184: attrs))
185:
186:
187: type falist = formatArg list
188:
189: type maybeInit =
190: NoInit
191: | InitExp of exp
192: | InitCall of lval * exp list
193:
194: %}
195:
196: %token <string> IDENT
197: %token <string> CST_CHAR
198: %token <string> CST_INT
199: %token <string> CST_FLOAT
200: %token <string> CST_STRING
201: %token <string> CST_WSTRING
202: %token <string> NAMED_TYPE
203:
204: %token EOF
205: %token BOOL CHAR INT DOUBLE FLOAT COMPLEX IMAGINARY VOID INT64 INT32
206: %token ENUM STRUCT TYPEDEF UNION
207: %token SIGNED UNSIGNED LONG SHORT
208: %token VOLATILE EXTERN STATIC CONST RESTRICT AUTO REGISTER
209:
210: %token <string> ARG_e ARG_eo ARG_E ARG_u ARG_b ARG_t ARG_d ARG_lo ARG_l ARG_i
211: %token <string> ARG_o ARG_va ARG_f ARG_F ARG_A ARG_v ARG_k ARG_c ARG_d
212: %token <string> ARG_s ARG_p ARG_P ARG_I ARG_S ARG_g
213:
214: %token SIZEOF ALIGNOF
215:
216: %token EQ
217: %token ARROW DOT
218:
219: %token EQ_EQ EXCLAM_EQ INF SUP INF_EQ SUP_EQ
220: %token MINUS_EQ PLUS_EQ STAR_EQ
221: %token PLUS MINUS STAR SLASH PERCENT
222: %token TILDE AND PIPE CIRC
223: %token EXCLAM AND_AND PIPE_PIPE
224: %token INF_INF SUP_SUP
225: %token PLUS_PLUS MINUS_MINUS
226:
227: %token RPAREN LPAREN RBRACE LBRACE LBRACKET RBRACKET
228: %token COLON SEMICOLON COMMA ELLIPSIS QUEST
229:
230: %token BREAK CONTINUE GOTO RETURN
231: %token SWITCH CASE DEFAULT
232: %token WHILE DO FOR
233: %token IF THEN ELSE
234:
235: %token ATTRIBUTE INLINE ASM TYPEOF FUNCTION__ PRETTY_FUNCTION__ LABEL__
236: %token BUILTIN_VA_ARG BUILTIN_VA_LIST
237: %token BLOCKATTRIBUTE
238: %token DECLSPEC
239: %token <string> MSASM MSATTR
240: %token PRAGMA
241:
242:
243: /* operator precedence */
244: %nonassoc IF
245: %nonassoc ELSE
246:
247:
248: %left COMMA
249:
250: /*(* Set the following precedences higer than COMMA *)*/
251: %nonassoc ARG_e ARG_d ARG_lo ARG_l ARG_i ARG_v ARG_I ARG_g
252: %right EQ PLUS_EQ MINUS_EQ STAR_EQ SLASH_EQ PERCENT_EQ
253: AND_EQ PIPE_EQ CIRC_EQ INF_INF_EQ SUP_SUP_EQ
254: %right COLON
255: %left PIPE_PIPE
256: %left AND_AND
257: %left ARG_b
258: %left PIPE
259: %left CIRC
260: %left AND
261: %left EQ_EQ EXCLAM_EQ
262: %left INF SUP INF_EQ SUP_EQ
263: %left INF_INF SUP_SUP
264: %left PLUS MINUS
265: %left STAR SLASH PERCENT CONST RESTRICT VOLATILE
266: %right ARG_u EXCLAM TILDE PLUS_PLUS MINUS_MINUS CAST RPAREN ADDROF SIZEOF ALIGNOF
267: %left LBRACKET
268: %left DOT ARROW LPAREN LBRACE
269: %nonassoc IDENT QUEST CST_INT
270:
271: %start initialize expression typename offset lval instr stmt stmt_list
272:
273:
274: %type <unit> initialize
275: %type <((string -> Flx_cil_cil.typ -> Flx_cil_cil.varinfo) -> Flx_cil_cil.location -> (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.stmt)> stmt
276: %type <((string -> Flx_cil_cil.typ -> Flx_cil_cil.varinfo) -> Flx_cil_cil.location -> (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.stmt list)> stmt_list
277:
278: %type <((string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.exp) * (Flx_cil_cil.exp -> Flx_cil_cil.formatArg list option)> expression
279:
280: %type <((string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.exp) * (Flx_cil_cil.exp -> Flx_cil_cil.formatArg list option)> constant
281:
282: %type <((string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.lval) * (Flx_cil_cil.lval -> Flx_cil_cil.formatArg list option)> lval
283:
284: %type <((string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.typ) * (Flx_cil_cil.typ -> Flx_cil_cil.formatArg list option)> typename
285:
286: %type <(Flx_cil_cil.attributes -> (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.typ) * (Flx_cil_cil.typ -> Flx_cil_cil.formatArg list option)> type_spec
287:
288: %type <((string * Flx_cil_cil.formatArg) list -> (string * Flx_cil_cil.typ * Flx_cil_cil.attributes) list option * bool) * ((string * Flx_cil_cil.typ * Flx_cil_cil.attributes) list option * bool -> Flx_cil_cil.formatArg list option)> parameters
289:
290:
291: %type <(Flx_cil_cil.location -> (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.instr) * (Flx_cil_cil.instr -> Flx_cil_cil.formatArg list option)> instr
292:
293: %type <(Flx_cil_cil.typ -> (string * Flx_cil_cil.formatArg) list -> Flx_cil_cil.offset) * (Flx_cil_cil.offset -> Flx_cil_cil.formatArg list option)> offset
294:
295:
296: %%
297:
298:
299: initialize:
300: /* empty */ { }
301: ;
302:
303: /* (*** Expressions ***) */
304:
305:
306: expression:
307: | ARG_e { (* Count arguments eagerly *)
308: let currentArg = $1 in
309: ((fun args ->
310: match getArg currentArg args with
311: Fe e -> e
312: | a -> wrongArgType currentArg
313: "expression" a),
314:
315: (fun e -> Some [ Fe e ]))
316: }
317:
318: | constant { $1 }
319:
320: | lval %prec IDENT
321: { ((fun args -> Lval ((fst $1) args)),
322:
323: (fun e -> match e with
324: Lval l -> (snd $1) l
325: | _ -> None))
326: }
327:
328: | SIZEOF expression
329: { ((fun args -> SizeOfE ((fst $2) args)),
330:
331: fun e -> match e with
332: SizeOfE e' -> (snd $2) e'
333: | _ -> None)
334: }
335:
336: | SIZEOF LPAREN typename RPAREN
337: { ((fun args -> SizeOf ((fst $3) args)),
338:
339: (fun e -> match e with
340: SizeOf t -> (snd $3) t
341: | _ -> None))
342: }
343:
344: | ALIGNOF expression
345: { ((fun args -> AlignOfE ((fst $2) args)),
346:
347: (fun e -> match e with
348: AlignOfE e' -> (snd $2) e' | _ -> None))
349: }
350:
351: | ALIGNOF LPAREN typename RPAREN
352: { ((fun args -> AlignOf ((fst $3) args)),
353:
354: (fun e -> match e with
355: AlignOf t' -> (snd $3) t' | _ -> None))
356: }
357:
358: | PLUS expression
359: { $2 }
360: | MINUS expression
361: { doUnop Neg $2 }
362:
363: | EXCLAM expression
364: { doUnop LNot $2 }
365:
366: | TILDE expression
367: { doUnop BNot $2 }
368:
369: | argu expression %prec ARG_u
370: { ((fun args ->
371: let e = (fst $2) args in
372: UnOp((fst $1) args, e, typeOf e)),
373:
374: (fun e -> match e with
375: UnOp(uo, e', _) -> begin
376: match (snd $1) uo, (snd $2) e' with
377: Some m1, Some m2 -> Some (m1 @ m2)
378: | _ -> None
379: end
380: | _ -> None))
381: }
382:
383:
384: | AND expression %prec ADDROF
385: { ((fun args ->
386: match (fst $2) args with
387: Lval l -> mkAddrOf l
388: | _ -> E.s (bug "AddrOf applied to a non lval")),
389: (fun e -> match e with
390: AddrOf l -> (snd $2) (Lval l)
391: | e -> (snd $2) (Lval (mkMem e NoOffset))))
392: }
393:
394: | LPAREN expression RPAREN
395: { $2 }
396:
397: | expression PLUS expression
398: { ((fun args -> buildPlus ((fst $1) args)
399: ((fst $3) args)),
400: (fun e -> match e with
401: BinOp((PlusPI|PlusA), e1, e2, _) -> begin
402: match (snd $1) e1, (snd $3) e2 with
403: Some m1, Some m2 -> Some (m1 @ m2)
404: | _, _ -> None
405: end
406: | _ -> None))
407: }
408:
409: | expression MINUS expression
410: { ((fun args -> buildMinus ((fst $1) args)
411: ((fst $3) args)),
412:
413: (fun e -> match e with
414: BinOp((MinusPP|MinusPI|MinusA), e1, e2, _) ->
415: begin
416: match (snd $1) e1, (snd $3) e2 with
417: Some m1, Some m2 -> Some (m1 @ m2)
418: | _, _ -> None
419: end
420: | _ -> None))
421: }
422: | expression argb expression %prec ARG_b
423: { ((fun args ->
424: let e1 = (fst $1) args in
425: let bop = (fst $2) args in
426: let e2 = (fst $3) args in
427: let t1 = typeOf e1 in
428: BinOp(bop, e1, e2, t1)),
429:
430: (fun e -> match e with
431: BinOp(bop, e1, e2, _) -> begin
432: match (snd $1) e1,(snd $2) bop,(snd $3) e2 with
433: Some m1, Some m2, Some m3 ->
434: Some (m1 @ m2 @ m3)
435: | _, _, _ -> None
436: end
437: | _ -> None))
438: }
439:
440: | expression STAR expression
441: { doBinop Mult $1 $3 }
442: | expression SLASH expression
443: { doBinop Div $1 $3 }
444: | expression PERCENT expression
445: { doBinop Mod $1 $3 }
446: | expression INF_INF expression
447: { doBinop Shiftlt $1 $3 }
448: | expression SUP_SUP expression
449: { doBinop Shiftrt $1 $3 }
450: | expression AND expression
451: { doBinop BAnd $1 $3 }
452: | expression PIPE expression
453: { doBinop BOr $1 $3 }
454: | expression CIRC expression
455: { doBinop BXor $1 $3 }
456: | expression EQ_EQ expression
457: { doBinop Eq $1 $3 }
458: | expression EXCLAM_EQ expression
459: { doBinop Ne $1 $3 }
460: | expression INF expression
461: { doBinop Lt $1 $3 }
462: | expression SUP expression
463: { doBinop Gt $1 $3 }
464: | expression INF_EQ expression
465: { doBinop Le $1 $3 }
466: | expression SUP_EQ expression
467: { doBinop Ge $1 $3 }
468:
469: | LPAREN typename RPAREN expression
470: { ((fun args ->
471: let t = (fst $2) args in
472: let e = (fst $4) args in
473: mkCast e t),
474:
475: (fun e ->
476: let t', e' =
477: match e with
478: CastE (t', e') -> t', e'
479: | _ -> typeOf e, e
480: in
481: match (snd $2) t', (snd $4 e') with
482: Some m1, Some m2 -> Some (m1 @ m2)
483: | _, _ -> None))
484: }
485: ;
486:
487: /*(* Separate the ARG_ to ensure that the counting of arguments is right *)*/
488: argu :
489: | ARG_u { let currentArg = $1 in
490: ((fun args ->
491: match getArg currentArg args with
492: Fu uo -> uo
493: | a -> wrongArgType currentArg "unnop" a),
494:
495: fun uo -> Some [ Fu uo ])
496: }
497: ;
498:
499: argb :
500: | ARG_b { let currentArg = $1 in
501: ((fun args ->
502: match getArg currentArg args with
503: Fb bo -> bo
504: | a -> wrongArgType currentArg "binop" a),
505:
506: fun bo -> Some [ Fb bo ])
507: }
508: ;
509:
510: constant:
511: | ARG_d { let currentArg = $1 in
512: ((fun args ->
513: match getArg currentArg args with
514: Fd n -> integer n
515: | a -> wrongArgType currentArg "integer" a),
516:
517: fun e -> match e with
518: Const(CInt64(n, _, _)) ->
519: Some [ Fd (Int64.to_int n) ]
520: | _ -> None)
521: }
522:
523: | ARG_g { let currentArg = $1 in
524: ((fun args ->
525: match getArg currentArg args with
526: Fg s -> Const(CStr s)
527: | a -> wrongArgType currentArg "string" a),
528:
529: fun e -> match e with
530: Const(CStr s) ->
531: Some [ Fg s ]
532: | _ -> None)
533: }
534: | CST_INT { let n = parseInt $1 in
535: ((fun args -> n),
536:
537: (fun e -> match e, n with
538: Const(CInt64(e', _, _)),
539: Const(CInt64(n', _, _)) when e' = n' -> Some []
540: | _ -> None))
541: }
542: ;
543:
544:
545: /*(***************** LVALUES *******************)*/
546: lval:
547: | ARG_l { let currentArg = $1 in
548: ((fun args ->
549: match getArg currentArg args with
550: Fl l -> l
551: | Fv v -> Var v, NoOffset
552: | a -> wrongArgType currentArg "lval" a),
553:
554: fun l -> Some [ Fl l ])
555: }
556:
557: | argv offset %prec ARG_v
558: { ((fun args ->
559: let v = (fst $1) args in
560: (Var v, (fst $2) v.vtype args)),
561:
562: (fun l -> match l with
563: Var vi, off -> begin
564: match (snd $1) vi, (snd $2) off with
565: Some m1, Some m2 -> Some (m1 @ m2)
566: | _ -> None
567: end
568: | _ -> None))
569: }
570:
571: | STAR expression { ((fun args -> mkMem ((fst $2) args) NoOffset),
572:
573: (fun l -> match l with
574: Mem e, NoOffset -> (snd $2) e
575: | _, _ -> None))
576: }
577:
578: | expression ARROW IDENT offset
579: { ((fun args ->
580: let e = (fst $1) args in
581: let baset =
582: match unrollTypeDeep (typeOf e) with
583: TPtr (t, _) -> t
584: | _ -> E.s (bug "Expecting a pointer for field %s\n" $3)
585: in
586: let fi = getField baset $3 in
587: mkMem e (Field(fi, (fst $4) fi.ftype args))),
588:
589: (fun l -> match l with
590: Mem e, Field(fi, off) when fi.fname = $3 -> begin
591: match (snd $1) e, (snd $4) off with
592: Some m1, Some m2 -> Some (m1 @ m2)
593: | _, _ -> None
594: end
595: | _, _ -> None))
596: }
597:
598: | LPAREN STAR expression RPAREN offset
599: { ((fun args ->
600: let e = (fst $3) args in
601: let baset =
602: match unrollTypeDeep (typeOf e) with
603: TPtr (t, _) -> t
604: | _ -> E.s (bug "Expecting a pointer\n")
605: in
606: mkMem e ((fst $5) baset args)),
607:
608: (fun l -> match l with
609: Mem e, off -> begin
610: match (snd $3) e, (snd $5 off) with
611: Some m1, Some m2 -> Some (m1 @ m2)
612: | _, _ -> None
613: end
614: | _, _ -> None))
615: }
616: ;
617:
618: argv :
619: | ARG_v { let currentArg = $1 in
620: ((fun args ->
621: match getArg currentArg args with
622: Fv v -> v
623: | a -> wrongArgType currentArg "varinfo" a),
624:
625: fun v -> Some [ Fv v ])
626: }
627: | IDENT { let currentArg = $1 in
628: ((fun args ->
629: match getArg currentArg args with
630: Fv v -> v
631: | a -> wrongArgType currentArg "varinfo" a),
632: (fun v ->
633: E.s (bug "identifiers (%s) are not supported for deconstruction" currentArg)))
634: }
635: ;
636:
637:
638: /*(********** OFFSETS *************)*/
639: offset:
640: | ARG_o { let currentArg = $1 in
641: ((fun t args ->
642: match getArg currentArg args with
643: Fo o -> o
644: | a -> wrongArgType currentArg "offset" a),
645:
646: (fun off -> Some [ Fo off ]))
647: }
648:
649: | /* empty */ { ((fun t args -> NoOffset),
650:
651: (fun off -> match off with
652: NoOffset -> Some []
653: | _ -> None))
654: }
655:
656: | DOT IDENT offset { ((fun t args ->
657: let fi = getField t $2 in
658: Field (fi, (fst $3) fi.ftype args)),
659:
660: (fun off -> match off with
661: Field (fi, off') when fi.fname = $2 ->
662: (snd $3) off'
663: | _ -> None))
664: }
665:
666: | LBRACKET expression RBRACKET offset
667: { ((fun t args ->
668: let bt =
669: match unrollType t with
670: TArray(bt, _, _) -> bt
671: | _ -> E.s (error "Flx_cil_formatcil: expecting an array for index")
672: in
673: let e = (fst $2) args in
674: Index(e, (fst $4) bt args)),
675:
676: (fun off -> match off with
677: Index (e, off') -> begin
678: match (snd $2) e, (snd $4) off with
679: Some m1, Some m2 -> Some (m1 @ m2)
680: | _, _ -> None
681: end
682: | _ -> None))
683: }
684: ;
685:
686:
687: /*(************ TYPES **************)*/
688: typename: one_formal { ((fun args ->
689: let (_, ft, _) = (fst $1) args in
690: ft),
691:
692: (fun t -> (snd $1) ("", t, [])))
693: }
694: ;
695:
696: one_formal:
697: /*(* Do not allow attributes for the name *)*/
698: | type_spec attributes decl
699: { ((fun args ->
700: let tal = (fst $2) args in
701: let ts = (fst $1) tal args in
702: let (fn, ft, _) = (fst $3) ts args in
703: (fn, ft, [])),
704:
705: (fun (fn, ft, fa) ->
706: match (snd $3) (fn, ft) with
707: Some (restt, m3) -> begin
708: match (snd $1) restt,
709: (snd $2) (typeAttrs restt)with
710: Some m1, Some m2 ->
711: Some (m1 @ m2 @ m3)
712: | _, _ -> None
713: end
714: | _ -> None))
715: }
716:
717: | ARG_f
718: { let currentArg = $1 in
719: ((fun args ->
720: match getArg currentArg args with
721: Ff (fn, ft, fa) -> (fn, ft, fa)
722: | a -> wrongArgType currentArg "formal" a),
723:
724: (fun (fn, ft, fa) -> Some [ Ff (fn, ft, fa) ]))
725: }
726: ;
727:
728: type_spec:
729: | ARG_t { let currentArg = $1 in
730: ((fun al args ->
731: match getArg currentArg args with
732: Ft t -> typeAddAttributes al t
733: | a -> wrongArgType currentArg "type" a),
734:
735: (fun t -> Some [ Ft t ]))
736: }
737:
738: | VOID { ((fun al args -> TVoid al),
739:
740: (fun t -> match unrollType t with
741: TVoid _ -> Some []
742: | _ -> None)) }
743:
744: | ARG_k { let currentArg = $1 in
745: ((fun al args ->
746: match getArg currentArg args with
747: Fk ik -> TInt(ik, al)
748: | a -> wrongArgType currentArg "ikind" a),
749:
750: (fun t -> match unrollType t with
751: TInt(ik, _) -> Some [ Fk ik ]
752: | _ -> None))
753: }
754:
755: | CHAR { ((fun al args -> TInt(IChar, al)),
756: (matchIntType IChar)) }
757: | UNSIGNED CHAR { ((fun al args -> TInt(IUChar, al)),
758: matchIntType IUChar) }
759:
760: | SHORT { ((fun al args -> TInt(IShort, al)),
761: matchIntType IShort) }
762: | UNSIGNED SHORT { ((fun al args -> TInt(IUShort, al)),
763: matchIntType IUShort) }
764:
765: | INT { ((fun al args -> TInt(IInt, al)),
766: matchIntType IInt) }
767: | UNSIGNED INT { ((fun al args -> TInt(IUInt, al)), matchIntType IUInt) }
768:
769: | LONG { ((fun al args -> TInt(ILong, al)),
770: matchIntType ILong) }
771: | UNSIGNED LONG { ((fun al args -> TInt(IULong, al)),
772: matchIntType IULong) }
773:
774: | LONG LONG { ((fun al args -> TInt(ILongLong, al)),
775:
776: matchIntType ILongLong)
777: }
778: | UNSIGNED LONG LONG { ((fun al args -> TInt(IULongLong, al)),
779:
780: matchIntType IULongLong)
781: }
782:
783: | FLOAT { ((fun al args -> TFloat(FFloat, al)),
784: matchFloatType FFloat)
785: }
786: | DOUBLE { ((fun al args -> TFloat(FDouble, al)),
787: matchFloatType FDouble) }
788:
789: | COMPLEX { ((fun al args -> TFloat(CFloat, al)),
790: matchFloatType CFloat ) }
791:
792: | IMAGINARY { ((fun al args -> TFloat(IFloat, al)),
793: matchFloatType IFloat) }
794:
795: | STRUCT ARG_c { let currentArg = $2 in
796: ((fun al args ->
797: match getArg currentArg args with
798: Fc ci -> TComp(ci, al)
799: | a -> wrongArgType currentArg "compinfo" a),
800:
801: (fun t -> match unrollType t with
802: TComp(ci, _) -> Some [ Fc ci ]
803: | _ -> None))
804: }
805: | UNION ARG_c { let currentArg = $2 in
806: ((fun al args ->
807: match getArg currentArg args with
808: Fc ci -> TComp(ci, al)
809: | a -> wrongArgType currentArg "compinfo" a),
810:
811: (fun t -> match unrollType t with
812: TComp(ci, _) -> Some [ Fc ci ]
813: | _ -> None))
814:
815: }
816:
817: | TYPEOF LPAREN expression RPAREN
818: { ((fun al args -> typeAddAttributes al
819: (typeOf ((fst $3) args))),
820:
821: (fun t -> E.s (bug "Cannot match typeof(e)\n")))
822: }
823: ;
824:
825: decl:
826: | STAR attributes decl
827: { ((fun ts args ->
828: let al = (fst $2) args in
829: (fst $3) (TPtr(ts, al)) args),
830:
831: (fun (fn, ft) ->
832: match (snd $3) (fn, ft) with
833: Some (TPtr(bt, al), m2) -> begin
834: match (snd $2) al with
835: Some m1 -> Some (bt, m1 @ m2)
836: | _ -> None
837: end
838: | _ -> None))
839: }
840:
841: | direct_decl { $1 }
842: ;
843:
844: direct_decl:
845: | /* empty */ { ((fun ts args -> ("", ts, [])),
846:
847: (* Match any name in this case *)
848: (fun (fn, ft) ->
849: Some (unrollType ft, [])))
850: }
851:
852: | IDENT { ((fun ts args -> ($1, ts, [])),
853:
854: (fun (fn, ft) ->
855: if fn = "" || fn = $1 then
856: Some (unrollType ft, [])
857: else
858: None))
859: }
860:
861: | LPAREN attributes decl RPAREN
862: { ((fun ts args ->
863: let al = (fst $2) args in
864: (fst $3) (typeAddAttributes al ts) args),
865:
866: (fun (fn, ft) -> begin
867: match (snd $3) (fn, ft) with
868: Some (restt, m2) -> begin
869: match (snd $2) (typeAttrs restt) with
870: Some m1 -> Some (restt, m1 @ m2)
871: | _ -> None
872: end
873: | _ -> None
874: end))
875: }
876:
877: | direct_decl LBRACKET exp_opt RBRACKET
878: { ((fun ts args ->
879: (fst $1) (TArray(ts, (fst $3) args, [])) args),
880:
881: (fun (fn, ft) ->
882: match (snd $1) (fn, ft) with
883: Some (TArray(bt, lo, _), m1) -> begin
884: match (snd $3) lo with
885: Some m2 -> Some (unrollType bt, m1 @ m2)
886: | _ -> None
887: end
888: | _ -> None))
889: }
890:
891:
892: /*(* We use parentheses around the function to avoid conflicts *)*/
893: | LPAREN attributes decl RPAREN LPAREN parameters RPAREN
894: { ((fun ts args ->
895: let al = (fst $2) args in
896: let pars, isva = (fst $6) args in
897: (fst $3) (TFun(ts, pars, isva, al)) args),
898:
899: (fun (fn, ft) ->
900: match (snd $3) (fn, ft) with
901: Some (TFun(rt, args, isva, al), m1) -> begin
902: match (snd $2) al, (snd $6) (args, isva) with
903: Some m2, Some m6
904: -> Some (unrollType rt, m1 @ m2 @ m6)
905: | _ -> None
906: end
907: | _ -> None))
908: }
909: ;
910:
911: parameters:
912: | /* empty */ { ((fun args -> (None, false)),
913:
914: (* Match any formals *)
915: (fun (pars, isva) ->
916: match pars, isva with
917: (_, false) -> Some []
918: | _ -> None))
919: }
920:
921: | parameters_ne { ((fun args ->
922: let (pars : (string * typ * attributes) list),
923: (isva : bool) = (fst $1) args in
924: (Some pars), isva),
925:
926: (function
927: ((Some pars), isva) -> (snd $1) (pars, isva)
928: | _ -> None))
929: }
930: ;
931: parameters_ne:
932: | ELLIPSIS
933: { ((fun args -> ([], true)),
934:
935: (function
936: ([], true) -> Some []
937: | _ -> None))
938: }
939:
940: | ARG_va { let currentArg = $1 in
941: ((fun args ->
942: match getArg currentArg args with
943: Fva isva -> ([], isva)
944: | a -> wrongArgType currentArg "vararg" a),
945:
946: (function
947: ([], isva) -> Some [ Fva isva ]
948: | _ -> None))
949: }
950:
951: | ARG_F { let currentArg = $1 in
952: ((fun args ->
953: match getArg currentArg args with
954: FF fl -> ( fl, false)
955: | a -> wrongArgType currentArg "formals" a),
956:
957: (function
958: (pars, false) -> Some [ FF pars ]
959: | _ -> None))
960: }
961:
962: | one_formal { ((fun args -> ([(fst $1) args], false)),
963:
964: (function
965: ([ f ], false) -> (snd $1) f
966: | _ -> None))
967: }
968:
969:
970: | one_formal COMMA parameters_ne
971: { ((fun args ->
972: let this = (fst $1) args in
973: let (rest, isva) = (fst $3) args in
974: (this :: rest, isva)),
975:
976: (function
977: ((f::rest, isva)) -> begin
978: match (snd $1) f, (snd $3) (rest, isva) with
979: Some m1, Some m2 -> Some (m1 @ m2)
980: | _, _ -> None
981: end
982: | _ -> None))
983: }
984: ;
985:
986:
987:
988:
989:
990: exp_opt:
991: /* empty */ { ((fun args -> None),
992: (* Match anything if the pattern does not have a len *)
993: (fun _ -> Some [])) }
994:
995: | expression { ((fun args -> Some ((fst $1) args)),
996:
997: (fun lo -> match lo with
998: Some e -> (snd $1) e
999: | _ -> None))
1000: }
1001: | ARG_eo { let currentArg = $1 in
1002: ((fun args ->
1003: match getArg currentArg args with
1004: Feo lo -> lo
1005: | a -> wrongArgType currentArg "exp_opt" a),
1006:
1007: fun lo -> Some [ Feo lo ])
1008: }
1009: ;
1010:
1011:
1012:
1013: attributes:
1014: /*(* Ignore other attributes *)*/
1015: /* empty */ { ((fun args -> []),
1016: (fun attrs -> Some [])) }
1017:
1018: | ARG_A { let currentArg = $1 in
1019: ((fun args ->
1020: match getArg currentArg args with
1021: FA al -> al
1022: | a -> wrongArgType currentArg "attributes" a),
1023:
1024: (fun al -> Some [ FA al ]))
1025: }
1026:
1027: | attribute attributes
1028: { ((fun args ->
1029: addAttribute ((fst $1) args) ((fst $2) args)),
1030: (* Pass all the attributes down *)
1031: (fun attrs ->
1032: match (snd $1) attrs, (snd $2) attrs with
1033: Some m1, Some m2 -> Some (m1 @ m2)
1034: | _, _ -> None))
1035: }
1036: ;
1037:
1038: attribute:
1039: | CONST { doAttr "const" None }
1040: | RESTRICT { doAttr "restrict" None }
1041: | VOLATILE { doAttr "volatile" None }
1042: | ATTRIBUTE LPAREN LPAREN attr RPAREN RPAREN
1043: { $4 }
1044:
1045: ;
1046:
1047:
1048: attr:
1049: | IDENT
1050: { doAttr $1 None }
1051:
1052: | IDENT LPAREN attr_args_ne RPAREN
1053: { doAttr $1 (Some $3) }
1054: ;
1055:
1056: attr_args_ne:
1057: attr_arg { ((fun args -> [ (fst $1) args ]),
1058:
1059: (fun aargs -> match aargs with
1060: [ arg ] -> (snd $1) arg
1061: | _ -> None))
1062: }
1063: | attr_arg COMMA attr_args_ne { ((fun args ->
1064: let this = (fst $1) args in
1065: this :: ((fst $3) args)),
1066:
1067: (fun aargs -> match aargs with
1068: h :: rest -> begin
1069: match (snd $1) h, (snd $3) rest with
1070: Some m1, Some m2 -> Some (m1 @ m2)
1071: | _, _ -> None
1072: end
1073: | _ -> None))
1074: }
1075: | ARG_P { let currentArg = $1 in
1076: ((fun args ->
1077: match getArg currentArg args with
1078: FP al -> al
1079: | a -> wrongArgType currentArg "attrparams" a),
1080:
1081: (fun al -> Some [ FP al ]))
1082: }
1083: ;
1084:
1085: attr_arg:
1086: | IDENT { ((fun args -> ACons($1, [])),
1087:
1088: (fun aarg -> match aarg with
1089: ACons(id, []) when id = $1 -> Some []
1090: | _ -> None))
1091: }
1092: | IDENT LPAREN attr_args_ne RPAREN
1093: { ((fun args -> ACons($1, (fst $3) args)),
1094:
1095: (fun aarg -> match aarg with
1096: ACons(id, args) when id = $1 ->
1097: (snd $3) args
1098: | _ -> None))
1099: }
1100: | ARG_p { let currentArg = $1 in
1101: ((fun args ->
1102: match getArg currentArg args with
1103: Fp p -> p
1104: | a -> wrongArgType currentArg "attrparam" a),
1105:
1106: (fun ap -> Some [ Fp ap]))
1107: }
1108:
1109: ;
1110:
1111: /* (********** INSTRUCTIONS ***********) */
1112: instr:
1113: | ARG_i SEMICOLON
1114: { let currentArg = $1 in
1115: ((fun loc args ->
1116: match getArg currentArg args with
1117: Fi i -> i
1118: | a -> wrongArgType currentArg "instr" a),
1119:
1120: (fun i -> Some [ Fi i]))
1121: }
1122:
1123: | lval EQ expression SEMICOLON
1124: { ((fun loc args ->
1125: Set((fst $1) args, (fst $3) args, loc)),
1126:
1127: (fun i -> match i with
1128: Set (lv, e, l) -> begin
1129: match (snd $1) lv, (snd $3) e with
1130: Some m1, Some m2 -> Some (m1 @ m2)
1131: | _, _ -> None
1132: end
1133: | _ -> None))
1134: }
1135:
1136: | lval PLUS_EQ expression SEMICOLON
1137: { ((fun loc args ->
1138: let l = (fst $1) args in
1139: Set(l, buildPlus (Lval l) ((fst $3) args), loc)),
1140:
1141: matchBinopEq
1142: (fun bop -> bop = PlusPI || bop = PlusA)
1143: (snd $1) (snd $3))
1144: }
1145:
1146: | lval MINUS_EQ expression SEMICOLON
1147: { ((fun loc args ->
1148: let l = (fst $1) args in
1149: Set(l,
1150: buildMinus (Lval l) ((fst $3) args), loc)),
1151:
1152: matchBinopEq (fun bop -> bop = MinusA
1153: || bop = MinusPP
1154: || bop = MinusPI)
1155: (snd $1) (snd $3))
1156: }
1157: | lval STAR_EQ expression SEMICOLON
1158: { doBinopEq Mult $1 $3 }
1159:
1160: | lval SLASH_EQ expression SEMICOLON
1161: { doBinopEq Div $1 $3 }
1162:
1163: | lval PERCENT_EQ expression SEMICOLON
1164: { doBinopEq Mod $1 $3 }
1165:
1166: | lval AND_EQ expression SEMICOLON
1167: { doBinopEq BAnd $1 $3 }
1168:
1169: | lval PIPE_EQ expression SEMICOLON
1170: { doBinopEq BOr $1 $3 }
1171:
1172: | lval CIRC_EQ expression SEMICOLON
1173: { doBinopEq BXor $1 $3 }
1174:
1175: | lval INF_INF_EQ expression SEMICOLON
1176: { doBinopEq Shiftlt $1 $3 }
1177:
1178: | lval SUP_SUP_EQ expression SEMICOLON
1179: { doBinopEq Shiftrt $1 $3 }
1180:
1181: /* (* Would be nice to be able to condense the next three rules but we get
1182: * into conflicts *)*/
1183: | lval EQ lval LPAREN arguments RPAREN SEMICOLON
1184: { ((fun loc args ->
1185: Call(Some ((fst $1) args), Lval ((fst $3) args),
1186: (fst $5) args, loc)),
1187:
1188: (fun i -> match i with
1189: Call(Some l, Lval f, args, loc) -> begin
1190: match (snd $1) l, (snd $3) f, (snd $5) args with
1191: Some m1, Some m2, Some m3 ->
1192: Some (m1 @ m2 @ m3)
1193: | _, _, _ -> None
1194: end
1195: | _ -> None))
1196: }
1197:
1198: | lval LPAREN arguments RPAREN SEMICOLON
1199: { ((fun loc args ->
1200: Call(None, Lval ((fst $1) args),
1201: (fst $3) args, loc)),
1202:
1203: (fun i -> match i with
1204: Call(None, Lval f, args, loc) -> begin
1205: match (snd $1) f, (snd $3) args with
1206: Some m1, Some m2 -> Some (m1 @ m2)
1207: | _, _ -> None
1208: end
1209: | _ -> None))
1210: }
1211:
1212: | arglo lval LPAREN arguments RPAREN SEMICOLON
1213: { ((fun loc args ->
1214: Call((fst $1) args, Lval ((fst $2) args),
1215: (fst $4) args, loc)),
1216:
1217: (fun i -> match i with
1218: Call(lo, Lval f, args, loc) -> begin
1219: match (snd $1) lo, (snd $2) f, (snd $4) args with
1220: Some m1, Some m2, Some m3 ->
1221: Some (m1 @ m2 @ m3)
1222: | _, _, _ -> None
1223: end
1224: | _ -> None))
1225: }
1226: ;
1227:
1228: /* (* Separate this out to ensure that the counting or arguments is right *)*/
1229: arglo:
1230: ARG_lo { let currentArg = $1 in
1231: ((fun args ->
1232: let res =
1233: match getArg currentArg args with
1234: Flo x -> x
1235: | a -> wrongArgType currentArg "lval option" a
1236: in
1237: res),
1238:
1239: (fun lo -> Some [ Flo lo ]))
1240: }
1241: ;
1242: arguments:
1243: /* empty */ { ((fun args -> []),
1244:
1245: (fun actuals -> match actuals with
1246: [] -> Some []
1247: | _ -> None))
1248: }
1249:
1250: | arguments_ne { $1 }
1251: ;
1252:
1253: arguments_ne:
1254: expression { ((fun args -> [ (fst $1) args ]),
1255:
1256: (fun actuals -> match actuals with
1257: [ h ] -> (snd $1) h
1258: | _ -> None))
1259: }
1260:
1261: | ARG_E { let currentArg = $1 in
1262: ((fun args ->
1263: match getArg currentArg args with
1264: FE el -> el
1265: | a -> wrongArgType currentArg "arguments" a),
1266:
1267: (fun actuals -> Some [ FE actuals ]))
1268: }
1269:
1270: | expression COMMA arguments_ne
1271: { ((fun args -> ((fst $1) args) :: ((fst $3) args)),
1272:
1273: (fun actuals -> match actuals with
1274: h :: rest -> begin
1275: match (snd $1) h, (snd $3) rest with
1276: Some m1, Some m2 -> Some (m1 @ m2)
1277: | _, _ -> None
1278: end
1279: | _ -> None))
1280: }
1281: ;
1282:
1283:
1284: /*(******** STATEMENTS *********)*/
1285: stmt:
1286: IF LPAREN expression RPAREN stmt %prec IF
1287: { (fun mkTemp loc args ->
1288: mkStmt (If((fst $3) args,
1289: mkBlock [ $5 mkTemp loc args ],
1290: mkBlock [], loc)))
1291: }
1292: | IF LPAREN expression RPAREN stmt ELSE stmt
1293: { (fun mkTemp loc args ->
1294: mkStmt (If((fst $3) args,
1295: mkBlock [ $5 mkTemp loc args ],
1296: mkBlock [ $7 mkTemp loc args], loc)))
1297: }
1298: | RETURN exp_opt SEMICOLON
1299: { (fun mkTemp loc args ->
1300: mkStmt (Return((fst $2) args, loc)))
1301: }
1302: | BREAK SEMICOLON
1303: { (fun mkTemp loc args ->
1304: mkStmt (Break loc))
1305: }
1306: | CONTINUE SEMICOLON
1307: { (fun mkTemp loc args ->
1308: mkStmt (Continue loc))
1309: }
1310: | LBRACE stmt_list RBRACE
1311: { (fun mkTemp loc args ->
1312: let stmts = $2 mkTemp loc args in
1313: mkStmt (Block (mkBlock (stmts))))
1314: }
1315: | WHILE LPAREN expression RPAREN stmt
1316: { (fun mkTemp loc args ->
1317: let e = (fst $3) args in
1318: let e =
1319: if isPointerType(typeOf e) then
1320: mkCast e !upointType
1321: else e
1322: in
1323: mkStmt
1324: (Loop (mkBlock [ mkStmt
1325: (If(e,
1326: mkBlock [],
1327: mkBlock [ mkStmt
1328: (Break loc) ],
1329: loc));
1330: $5 mkTemp loc args ],
1331: loc, None, None)))
1332: }
1333: | instr_list { (fun mkTemp loc args ->
1334: mkStmt (Instr ($1 loc args)))
1335: }
1336: | ARG_s { let currentArg = $1 in
1337: (fun mkTemp loc args ->
1338: match getArg currentArg args with
1339: Fs s -> s
1340: | a -> wrongArgType currentArg "stmt" a) }
1341: ;
1342:
1343: stmt_list:
1344: /* empty */ { (fun mkTemp loc args -> []) }
1345:
1346: | ARG_S { let currentArg = $1 in
1347: (fun mkTemp loc args ->
1348: match getArg currentArg args with
1349: | FS sl -> sl
1350: | a -> wrongArgType currentArg "stmts" a)
1351: }
1352: | stmt stmt_list
1353: { (fun mkTemp loc args ->
1354: let this = $1 mkTemp loc args in
1355: this :: ($2 mkTemp loc args))
1356: }
1357: /* (* We can also have a declaration *) */
1358: | type_spec attributes decl maybe_init SEMICOLON stmt_list
1359: { (fun mkTemp loc args ->
1360: let tal = (fst $2) args in
1361: let ts = (fst $1) tal args in
1362: let (n, t, _) = (fst $3) ts args in
1363: let init = $4 args in
1364: (* Before we proceed we must create the variable *)
1365: let v = mkTemp n t in
1366: (* Now we parse the rest *)
1367: let rest = $6 mkTemp loc ((n, Fv v) :: args) in
1368: (* Now we add the initialization instruction to the
1369: * front *)
1370: match init with
1371: NoInit -> rest
1372: | InitExp e ->
1373: mkStmtOneInstr (Set((Var v, NoOffset), e, loc))
1374: :: rest
1375: | InitCall (f, args) ->
1376: mkStmtOneInstr (Call(Some (Var v, NoOffset),
1377: Lval f, args, loc))
1378: :: rest
1379:
1380: )
1381: }
1382: ;
1383:
1384: instr_list:
1385: /*(* Set this rule to very low precedence to ensure that we shift as
1386: many instructions as possible *)*/
1387: instr %prec COMMA
1388: { (fun loc args -> [ ((fst $1) loc args) ]) }
1389: | ARG_I { let currentArg = $1 in
1390: (fun loc args ->
1391: match getArg currentArg args with
1392: | FI il -> il
1393: | a -> wrongArgType currentArg "instrs" a)
1394: }
1395: | instr instr_list
1396: { (fun loc args ->
1397: let this = (fst $1) loc args in
1398: this :: ($2 loc args))
1399: }
1400: ;
1401:
1402:
1403: maybe_init:
1404: | { (fun args -> NoInit) }
1405: | EQ expression { (fun args -> InitExp ((fst $2) args)) }
1406: | EQ lval LPAREN arguments RPAREN
1407: { (fun args ->
1408: InitCall((fst $2) args, (fst $4) args)) }
1409: ;
1410: %%
1411:
Start ocaml section to src/flx_cil_mergecil.ml[1
/1
]
1: # 11709 "./lpsrc/flx_cil.ipk"
2: (* mergecil.ml *)
3: (* This module is responsible for merging multiple CIL source trees into
4: * a single, coherent CIL tree which contains the union of all the
5: * definitions in the source files. It effectively acts like a linker,
6: * but at the source code level instead of the object code level. *)
7:
8:
9: module P = Flx_cil_pretty
10: open Flx_cil_cil
11: module E = Flx_cil_errormsg
12: module H = Hashtbl
13: open Flx_cil_trace
14:
15: let debugMerge = false
16: let debugInlines = false
17:
18: let ignore_merge_conflicts = ref false
19:
20: (* Try to merge structure with the same name. However, do not complain if
21: * they are not the same *)
22: let mergeSynonyms = true
23:
24:
25: (** Whether to use path compression *)
26: let usePathCompression = false
27:
28: (* Try to merge definitions of inline functions. They can appear in multiple
29: * files and we would like them all to be the same. This can slow down the
30: * merger an order of magnitude !!! *)
31: let mergeInlines = true
32:
33: let mergeInlinesRepeat = mergeInlines && true
34:
35: let mergeInlinesWithAlphaConvert = mergeInlines && true
36:
37: (* when true, merge duplicate definitions of externally-visible functions;
38: * this uses a mechanism which is faster than the one for inline functions,
39: * but only probabilistically accurate *)
40: let mergeGlobals = true
41:
42:
43: (* Return true if 's' starts with the prefix 'p' *)
44: let prefix p s =
45: let lp = String.length p in
46: let ls = String.length s in
47: lp <= ls && String.sub s 0 lp = p
48:
49:
50:
51: (* A name is identified by the index of the file in which it occurs (starting
52: * at 0 with the first file) and by the actual name. We'll keep name spaces
53: * separate *)
54:
55: (* We define a data structure for the equivalence classes *)
56: type 'a node =
57: { nname: string; (* The actual name *)
58: nfidx: int; (* The file index *)
59: ndata: 'a; (* Data associated with the node *)
60: mutable nloc: (location * int) option;
61: (* location where defined and index within the file of the definition.
62: * If None then it means that this node actually DOES NOT appear in the
63: * given file. In rare occasions we need to talk in a given file about
64: * types that are not defined in that file. This happens with undefined
65: * structures but also due to cross-contamination of types in a few of
66: * the cases of combineType (see the definition of combineTypes). We
67: * try never to choose as representatives nodes without a definition.
68: * We also choose as representative the one that appears earliest *)
69: mutable nrep: 'a node; (* A pointer to another node in its class (one
70: * closer to the representative). The nrep node
71: * is always in an earlier file, except for the
72: * case where a name is undefined in one file
73: * and defined in a later file. If this pointer
74: * points to the node itself then this is the
75: * representative. *)
76: mutable nmergedSyns: bool (* Whether we have merged the synonyms for
77: * the node of this name *)
78: }
79:
80: let d_nloc () (lo: (location * int) option) : P.doc =
81: match lo with
82: None -> P.text "None"
83: | Some (l, idx) -> P.dprintf "Some(%d at %a)" idx d_loc l
84:
85: (* Make a node with a self loop. This is quite tricky. *)
86: let mkSelfNode (eq: (int * string, 'a node) H.t) (* The equivalence table *)
87: (syn: (string, 'a node) H.t) (* The synonyms table *)
88: (fidx: int) (name: string) (data: 'a)
89: (l: (location * int) option) =
90: let res = { nname = name; nfidx = fidx; ndata = data; nloc = l;
91: nrep = Obj.magic 1; nmergedSyns = false; } in
92: res.nrep <- res; (* Make the self cycle *)
93: H.add eq (fidx, name) res; (* Add it to the proper table *)
94: if mergeSynonyms && not (prefix "__anon" name) then
95: H.add syn name res;
96: res
97:
98: let debugFind = false
99:
100: (* Find the representative with or without path compression *)
101: let rec find (pathcomp: bool) (nd: 'a node) =
102: if debugFind then
103: ignore (E.log " find %s(%d)\n" nd.nname nd.nfidx);
104: if nd.nrep == nd then begin
105: if debugFind then
106: ignore (E.log " = %s(%d)\n" nd.nname nd.nfidx);
107: nd
108: end else begin
109: let res = find pathcomp nd.nrep in
110: if usePathCompression && pathcomp && nd.nrep != res then
111: nd.nrep <- res; (* Compress the paths *)
112: res
113: end
114:
115:
116: (* Union two nodes and return the new representative. We prefer as the
117: * representative a node defined earlier. We try not to use as
118: * representatives nodes that are not defined in their files. We return a
119: * function for undoing the union. Make sure that between the union and the
120: * undo you do not do path compression *)
121: let union (nd1: 'a node) (nd2: 'a node) : 'a node * (unit -> unit) =
122: (* Move to the representatives *)
123: let nd1 = find true nd1 in
124: let nd2 = find true nd2 in
125: if nd1 == nd2 then begin
126: (* It can happen that we are trying to union two nodes that are already
127: * equivalent. This is because between the time we check that two nodes
128: * are not already equivalent and the time we invoke the union operation
129: * we check type isomorphism which might change the equivalence classes *)
130: (*
131: ignore (warn "unioning already equivalent nodes for %s(%d)"
132: nd1.nname nd1.nfidx);
133: *)
134: nd1, fun x -> x
135: end else begin
136: let rep, norep = (* Choose the representative *)
137: if (nd1.nloc != None) = (nd2.nloc != None) then
138: (* They have the same defined status. Choose the earliest *)
139: if nd1.nfidx < nd2.nfidx then nd1, nd2
140: else if nd1.nfidx > nd2.nfidx then nd2, nd1
141: else (* In the same file. Choose the one with the earliest index *) begin
142: match nd1.nloc, nd2.nloc with
143: Some (_, didx1), Some (_, didx2) ->
144: if didx1 < didx2 then nd1, nd2 else
145: if didx1 > didx2 then nd2, nd1
146: else begin
147: ignore (warn
148: "Merging two elements (%s and %s) in the same file (%d) with the same idx (%d) within the file"
149: nd1.nname nd2.nname nd1.nfidx didx1);
150: nd1, nd2
151: end
152: | _, _ -> (* both none. Does not matter which one we choose. Should
153: * not happen though. *)
154: (* sm: it does happen quite a bit when, e.g. merging STLport with
155: * some client source; I'm disabling the warning since it supposedly
156: * is harmless anyway, so is useless noise *)
157: (* sm: re-enabling on claim it now will probably not happen *)
158: ignore (warn "Merging two undefined elements in the same file: %s and %s\n" nd1.nname nd2.nname);
159: nd1, nd2
160: end
161: else (* One is defined, the other is not. Choose the defined one *)
162: if nd1.nloc != None then nd1, nd2 else nd2, nd1
163: in
164: let oldrep = norep.nrep in
165: norep.nrep <- rep;
166: rep, (fun () -> norep.nrep <- oldrep)
167: end
168: (*
169: let union (nd1: 'a node) (nd2: 'a node) : 'a node * (unit -> unit) =
170: if nd1 == nd2 && nd1.nname = "!!!intEnumInfo!!!" then begin
171: ignore (warn "unioning two identical nodes for %s(%d)"
172: nd1.nname nd1.nfidx);
173: nd1, fun x -> x
174: end else
175: union nd1 nd2
176: *)
177: (* Find the representative for a node and compress the paths in the process *)
178: let findReplacement
179: (pathcomp: bool)
180: (eq: (int * string, 'a node) H.t)
181: (fidx: int)
182: (name: string) : ('a * int) option =
183: if debugFind then
184: ignore (E.log "findReplacement for %s(%d)\n" name fidx);
185: try
186: let nd = H.find eq (fidx, name) in
187: if nd.nrep == nd then begin
188: if debugFind then
189: ignore (E.log " is a representative\n");
190: None (* No replacement if this is the representative of its class *)
191: end else
192: let rep = find pathcomp nd in
193: if rep != rep.nrep then
194: E.s (bug "find does not return the representative\n");
195: if debugFind then
196: ignore (E.log " RES = %s(%d)\n" rep.nname rep.nfidx);
197: Some (rep.ndata, rep.nfidx)
198: with Not_found -> begin
199: if debugFind then
200: ignore (E.log " not found in the map\n");
201: None
202: end
203:
204: (* Make a node if one does not already exist. Otherwise return the
205: * representative *)
206: let getNode (eq: (int * string, 'a node) H.t)
207: (syn: (string, 'a node) H.t)
208: (fidx: int) (name: string) (data: 'a)
209: (l: (location * int) option) =
210: let debugGetNode = false in
211: if debugGetNode then
212: ignore (E.log "getNode(%s(%d), %a)\n"
213: name fidx d_nloc l);
214: try
215: let res = H.find eq (fidx, name) in
216:
217: (match res.nloc, l with
218: (* Maybe we have a better location now *)
219: None, Some _ -> res.nloc <- l
220: | Some (old_l, old_idx), Some (l, idx) ->
221: if old_idx != idx then
222: ignore (warn "Duplicate definition of node %s(%d) at indices %d(%a) and %d(%a)"
223: name fidx old_idx d_loc old_l idx d_loc l)
224: else
225: ()
226:
227: | _, _ -> ());
228: if debugGetNode then
229: ignore (E.log " node already found\n");
230: find false res (* No path compression *)
231: with Not_found -> begin
232: let res = mkSelfNode eq syn fidx name data l in
233: if debugGetNode then
234: ignore (E.log " made a new one\n");
235: res
236: end
237:
238:
239:
240: (* Dump a graph *)
241: let dumpGraph (what: string) (eq: (int * string, 'a node) H.t) : unit =
242: ignore (E.log "Equivalence graph for %s is:\n" what);
243: H.iter (fun (fidx, name) nd ->
244: ignore (E.log " %s(%d) %s-> "
245: name fidx (if nd.nloc = None then "(undef)" else ""));
246: if nd.nrep == nd then
247: ignore (E.log "*\n")
248: else
249: ignore (E.log " %s(%d)\n" nd.nrep.nname nd.nrep.nfidx ))
250: eq
251:
252:
253:
254:
255: (* For each name space we define a set of equivalence classes *)
256: let vEq: (int * string, varinfo node) H.t = H.create 111 (* Vars *)
257: let sEq: (int * string, compinfo node) H.t = H.create 111 (* Struct + union *)
258: let eEq: (int * string, enuminfo node) H.t = H.create 111 (* Enums *)
259: let tEq: (int * string, typeinfo node) H.t = H.create 111 (* Type names*)
260: let iEq: (int * string, varinfo node) H.t = H.create 111 (* Inlines *)
261:
262: (* Sometimes we want to merge synonyms. We keep some tables indexed by names.
263: * Each name is mapped to multiple exntries *)
264: let vSyn: (string, varinfo node) H.t = H.create 111 (* Not actually used *)
265: let iSyn: (string, varinfo node) H.t = H.create 111 (* Inlines *)
266: let sSyn: (string, compinfo node) H.t = H.create 111
267: let eSyn: (string, enuminfo node) H.t = H.create 111
268: let tSyn: (string, typeinfo node) H.t = H.create 111
269:
270: (** A global environment for variables. Put in here only the non-static
271: * variables, indexed by their name. *)
272: let vEnv : (string, varinfo node) H.t = H.create 111
273:
274:
275: (* A set of inline functions indexed by their printout ! *)
276: let inlineBodies : (P.doc, varinfo node) H.t = H.create 111
277:
278: (** A number of alpha conversion tables. We ought to keep one table for each
279: * name space. Unfortunately, because of the way the C lexer works, type
280: * names must be different from variable names!! We one alpha table both for
281: * variables and types. *)
282: let vtAlpha : (string, alphaTableData ref) H.t = H.create 57 (* Variables and
283: * types *)
284: let sAlpha : (string, alphaTableData ref) H.t = H.create 57 (* Structures and
285: * unions have
286: * the same name
287: * space *)
288: let eAlpha : (string, alphaTableData ref) H.t = H.create 57 (* Enumerations *)
289:
290:
291: (** Keep track, for all global function definitions, of the names of the formal
292: * arguments. They might change during merging of function types if the
293: * prototype occurs after the function definition and uses different names.
294: * We'll restore the names at the end *)
295: let formalNames: (int * string, string list) H.t = H.create 111
296:
297:
298: (* Accumulate here the globals in the merged file *)
299: let theFileTypes = ref []
300: let theFile = ref []
301:
302: (* add 'g' to the merged file *)
303: let mergePushGlobal (g: global) : unit =
304: pushGlobal g ~types:theFileTypes ~variables:theFile
305:
306: let mergePushGlobals gl = List.iter mergePushGlobal gl
307:
308:
309: (* The index of the current file being scanned *)
310: let currentFidx = ref 0
311:
312: let currentDeclIdx = ref 0 (* The index of the definition in a file. This is
313: * maintained both in pass 1 and in pass 2. Make
314: * sure you count the same things in both passes. *)
315: (* Keep here the file names *)
316: let fileNames : (int, string) H.t = H.create 113
317:
318:
319:
320: (* Remember the composite types that we have already declared *)
321: let emittedCompDecls: (string, bool) H.t = H.create 113
322: (* Remember the variables also *)
323: let emittedVarDecls: (string, bool) H.t = H.create 113
324:
325: (* also keep track of externally-visible function definitions;
326: * name maps to declaration, location, and semantic checksum *)
327: let emittedFunDefn: (string, fundec * location * int) H.t = H.create 113
328: (* and same for variable definitions; name maps to GVar fields *)
329: let emittedVarDefn: (string, varinfo * init option * location) H.t = H.create 113
330:
331: (** A mapping from the new names to the original names. Used in PASS2 when we
332: * rename variables. *)
333: let originalVarNames: (string, string) H.t = H.create 113
334:
335: (* Initialize the module *)
336: let init () =
337: H.clear sAlpha;
338: H.clear eAlpha;
339: H.clear vtAlpha;
340:
341: H.clear vEnv;
342:
343: H.clear vEq;
344: H.clear sEq;
345: H.clear eEq;
346: H.clear tEq;
347: H.clear iEq;
348:
349: H.clear vSyn;
350: H.clear sSyn;
351: H.clear eSyn;
352: H.clear tSyn;
353: H.clear iSyn;
354:
355: theFile := [];
356: theFileTypes := [];
357:
358: H.clear formalNames;
359: H.clear inlineBodies;
360:
361: currentFidx := 0;
362: currentDeclIdx := 0;
363: H.clear fileNames;
364:
365: H.clear emittedVarDecls;
366: H.clear emittedCompDecls;
367:
368: H.clear emittedFunDefn;
369: H.clear emittedVarDefn;
370:
371: H.clear originalVarNames
372:
373:
374: (* Some enumerations have to be turned into an integer. We implement this by
375: * introducing a special enumeration type which we'll recognize later to be
376: * an integer *)
377: let intEnumInfo =
378: { ename = "!!!intEnumInfo!!!"; (* This is otherwise invalid *)
379: eitems = [];
380: eattr = [];
381: ereferenced = false;
382: }
383: (* And add it to the equivalence graph *)
384: let intEnumInfoNode =
385: getNode eEq eSyn 0 intEnumInfo.ename intEnumInfo
386: (Some (locUnknown, 0))
387:
388: (* Combine the types. Raises the Failure exception with an error message.
389: * isdef says whether the new type is for a definition *)
390: type combineWhat =
391: CombineFundef (* The new definition is for a function definition. The old
392: * is for a prototype *)
393: | CombineFunarg (* Comparing a function argument type with an old prototype
394: * arg *)
395: | CombineFunret (* Comparing the return of a function with that from an old
396: * prototype *)
397: | CombineOther
398:
399:
400: let rec combineTypes (what: combineWhat)
401: (oldfidx: int) (oldt: typ)
402: (fidx: int) (t: typ) : typ =
403: match oldt, t with
404: | TVoid olda, TVoid a -> TVoid (addAttributes olda a)
405: | TInt (oldik, olda), TInt (ik, a) ->
406: let combineIK oldk k =
407: if oldk == k then oldk else
408: (* GCC allows a function definition to have a more precise integer
409: * type than a prototype that says "int" *)
410: if not !msvcMode && oldk = IInt && bitsSizeOf t <= 32
411: && (what = CombineFunarg || what = CombineFunret)
412: then
413: k
414: else (
415: let msg =
416: P.sprint ~width:80
417: (P.dprintf
418: "(different integer types %a and %a)"
419: d_type oldt d_type t) in
420: raise (Failure msg)
421: )
422: in
423: TInt (combineIK oldik ik, addAttributes olda a)
424:
425: | TFloat (oldfk, olda), TFloat (fk, a) ->
426: let combineFK oldk k =
427: if oldk == k then oldk else
428: (* GCC allows a function definition to have a more precise integer
429: * type than a prototype that says "double" *)
430: if not !msvcMode && oldk = FDouble && k = FFloat
431: && (what = CombineFunarg || what = CombineFunret)
432: then
433: k
434: else
435: raise (Failure "(different floating point types)")
436: in
437: TFloat (combineFK oldfk fk, addAttributes olda a)
438:
439: | TEnum (oldei, olda), TEnum (ei, a) ->
440: (* Matching enumerations always succeeds. But sometimes it maps both
441: * enumerations to integers *)
442: matchEnumInfo oldfidx oldei fidx ei;
443: TEnum (oldei, addAttributes olda a)
444:
445:
446: (* Strange one. But seems to be handled by GCC *)
447: | TEnum (oldei, olda) , TInt(IInt, a) -> TEnum(oldei,
448: addAttributes olda a)
449:
450: (* Strange one. But seems to be handled by GCC. Warning. Here we are
451: * leaking types from new to old *)
452: | TInt(IInt, olda), TEnum (ei, a) -> TEnum(ei, addAttributes olda a)
453:
454: | TComp (oldci, olda) , TComp (ci, a) ->
455: matchCompInfo oldfidx oldci fidx ci;
456: (* If we get here we were successful *)
457: TComp (oldci, addAttributes olda a)
458:
459: | TArray (oldbt, oldsz, olda), TArray (bt, sz, a) ->
460: let combbt = combineTypes CombineOther oldfidx oldbt fidx bt in
461: let combinesz =
462: match oldsz, sz with
463: None, Some _ -> sz
464: | Some _, None -> oldsz
465: | None, None -> oldsz
466: | Some oldsz', Some sz' ->
467: let samesz =
468: match constFold true oldsz', constFold true sz' with
469: Const(CInt64(oldi, _, _)), Const(CInt64(i, _, _)) -> oldi = i
470: | _, _ -> false
471: in
472: if samesz then oldsz else
473: raise (Failure "(different array sizes)")
474: in
475: TArray (combbt, combinesz, addAttributes olda a)
476:
477: | TPtr (oldbt, olda), TPtr (bt, a) ->
478: TPtr (combineTypes CombineOther oldfidx oldbt fidx bt,
479: addAttributes olda a)
480:
481: (* WARNING: In this case we are leaking types from new to old !! *)
482: | TFun (_, _, _, [Attr("missingproto",_)]), TFun _ -> t
483:
484:
485: | TFun _, TFun (_, _, _, [Attr("missingproto",_)]) -> oldt
486:
487: | TFun (oldrt, oldargs, oldva, olda), TFun (rt, args, va, a) ->
488: let newrt =
489: combineTypes
490: (if what = CombineFundef then CombineFunret else CombineOther)
491: oldfidx oldrt fidx rt
492: in
493: if oldva != va then
494: raise (Failure "(diferent vararg specifiers)");
495: (* If one does not have arguments, believe the one with the
496: * arguments *)
497: let newargs =
498: if oldargs = None then args else
499: if args = None then oldargs else
500: let oldargslist = argsToList oldargs in
501: let argslist = argsToList args in
502: if List.length oldargslist <> List.length argslist then
503: raise (Failure "(different number of arguments)")
504: else begin
505: (* Go over the arguments and update the old ones with the
506: * adjusted types *)
507: Some
508: (List.map2
509: (fun (on, ot, oa) (an, at, aa) ->
510: let n = if an <> "" then an else on in
511: let t =
512: combineTypes
513: (if what = CombineFundef then
514: CombineFunarg else CombineOther)
515: oldfidx ot fidx at
516: in
517: let a = addAttributes oa aa in
518: (n, t, a))
519: oldargslist argslist)
520: end
521: in
522: TFun (newrt, newargs, oldva, addAttributes olda a)
523:
524: | TBuiltin_va_list olda, TBuiltin_va_list a ->
525: TBuiltin_va_list (addAttributes olda a)
526:
527: | TNamed (oldt, olda), TNamed (t, a) ->
528: matchTypeInfo oldfidx oldt fidx t;
529: (* If we get here we were able to match *)
530: TNamed(oldt, addAttributes olda a)
531:
532: (* Unroll first the new type *)
533: | _, TNamed (t, a) ->
534: let res = combineTypes what oldfidx oldt fidx t.ttype in
535: typeAddAttributes a res
536:
537: (* And unroll the old type as well if necessary *)
538: | TNamed (oldt, a), _ ->
539: let res = combineTypes what oldfidx oldt.ttype fidx t in
540: typeAddAttributes a res
541:
542: | _ -> (
543: (* raise (Failure "(different type constructors)") *)
544: let msg:string = (P.sprint 1000 (P.dprintf "(different type constructors: %a vs. %a)"
545: d_type oldt d_type t)) in
546: raise (Failure msg)
547: )
548:
549:
550: (* Match two compinfos and throw a Failure if they do not match *)
551: and matchCompInfo (oldfidx: int) (oldci: compinfo)
552: (fidx: int) (ci: compinfo) : unit =
553: if oldci.cstruct <> ci.cstruct then
554: raise (Failure "(different struct/union types)");
555: (* See if we have a mapping already *)
556: (* Make the nodes if not already made. Actually return the
557: * representatives *)
558: let oldcinode = getNode sEq sSyn oldfidx oldci.cname oldci None in
559: let cinode = getNode sEq sSyn fidx ci.cname ci None in
560: if oldcinode == cinode then (* We already know they are the same *)
561: ()
562: else begin
563: (* Replace with the representative data *)
564: let oldci = oldcinode.ndata in
565: let oldfidx = oldcinode.nfidx in
566: let ci = cinode.ndata in
567: let fidx = cinode.nfidx in
568:
569: let old_len = List.length oldci.cfields in
570: let len = List.length ci.cfields in
571: (* It is easy to catch here the case when the new structure is undefined
572: * and the old one was defined. We just reuse the old *)
573: (* More complicated is the case when the old one is not defined but the
574: * new one is. We still reuse the old one and we'll take care of defining
575: * it later with the new fields. *)
576: if len <> 0 && old_len <> 0 && old_len <> len then (
577: let curLoc = !currentLoc in (* d_global blows this away.. *)
578: (trace "merge" (P.dprintf "different # of fields\n%d: %a\n%d: %a\n"
579: old_len d_global (GCompTag(oldci,locUnknown))
580: len d_global (GCompTag(ci,locUnknown))
581: ));
582: currentLoc := curLoc;
583: let msg = Printf.sprintf
584: "(different number of fields in %s and %s: %d != %d.)"
585: oldci.cname ci.cname old_len len in
586: raise (Failure msg)
587: );
588: (* We check that they are defined in the same way. While doing this there
589: * might be recursion and we have to watch for going into an infinite
590: * loop. So we add the assumption that they are equal *)
591: let newrep, undo = union oldcinode cinode in
592: (* We check the fields but watch for Failure. We only do the check when
593: * the lengths are the same. Due to the code above this the other
594: * possibility is that one of the length is 0, in which case we reuse the
595: * old compinfo. *)
596: if old_len = len then
597: (try
598: List.iter2
599: (fun oldf f ->
600: if oldf.fbitfield <> f.fbitfield then
601: raise (Failure "(different bitfield info)");
602: if oldf.fattr <> f.fattr then
603: raise (Failure "(different field attributes)");
604: (* Make sure the types are compatible *)
605: let newtype =
606: combineTypes CombineOther oldfidx oldf.ftype fidx f.ftype
607: in
608: (* Change the type in the representative *)
609: oldf.ftype <- newtype;
610: )
611: oldci.cfields ci.cfields
612: with Failure reason -> begin
613: (* Our assumption was wrong. Forget the isomorphism *)
614: undo ();
615: let msg =
616: P.sprint ~width:80
617: (P.dprintf
618: "\n\tFailed assumption that %s and %s are isomorphic %s@!%a@!%a"
619: (compFullName oldci) (compFullName ci) reason
620: dn_global (GCompTag(oldci,locUnknown))
621: dn_global (GCompTag(ci,locUnknown)))
622: in
623: raise (Failure msg)
624: end);
625: (* We get here when we succeeded checking that they are equal *)
626: newrep.ndata.cattr <- addAttributes oldci.cattr ci.cattr;
627: ()
628: end
629:
630: (* Match two enuminfos and throw a Failure if they do not match *)
631: and matchEnumInfo (oldfidx: int) (oldei: enuminfo)
632: (fidx: int) (ei: enuminfo) : unit =
633: (* Find the node for this enum, no path compression. *)
634: let oldeinode = getNode eEq eSyn oldfidx oldei.ename oldei None in
635: let einode = getNode eEq eSyn fidx ei.ename ei None in
636: if oldeinode == einode then (* We already know they are the same *)
637: ()
638: else begin
639: (* Replace with the representative data *)
640: let oldei = oldeinode.ndata in
641: let oldfidx = oldeinode.nfidx in
642: let ei = einode.ndata in
643: let fidx = einode.nfidx in
644: (* Try to match them. But if you cannot just make them both integers *)
645: try
646: (* We do not have a mapping. They better be defined in the same way *)
647: if List.length oldei.eitems <> List.length ei.eitems then
648: raise (Failure "(different number of enumeration elements)");
649: (* We check that they are defined in the same way. This is a fairly
650: * conservative check. *)
651: List.iter2
652: (fun (old_iname, old_iv, _) (iname, iv, _) ->
653: if old_iname <> iname then
654: raise (Failure "(different names for enumeration items)");
655: let samev =
656: match constFold true old_iv, constFold true iv with
657: Const(CInt64(oldi, _, _)), Const(CInt64(i, _, _)) -> oldi = i
658: | _ -> false
659: in
660: if not samev then
661: raise (Failure "(different values for enumeration items)"))
662: oldei.eitems ei.eitems;
663: (* Set the representative *)
664: let newrep, _ = union oldeinode einode in
665: (* We get here if the enumerations match *)
666: newrep.ndata.eattr <- addAttributes oldei.eattr ei.eattr;
667: ()
668: with Failure msg -> begin
669: (* Get here if you cannot merge two enumeration nodes *)
670: if oldeinode != intEnumInfoNode then begin
671: let _ = union oldeinode intEnumInfoNode in ()
672: end;
673: if einode != intEnumInfoNode then begin
674: let _ = union einode intEnumInfoNode in ()
675: end;
676: end
677: end
678:
679:
680: (* Match two typeinfos and throw a Failure if they do not match *)
681: and matchTypeInfo (oldfidx: int) (oldti: typeinfo)
682: (fidx: int) (ti: typeinfo) : unit =
683: if oldti.tname = "" || ti.tname = "" then
684: E.s (bug "matchTypeInfo for anonymous type\n");
685: (* Find the node for this enum, no path compression. *)
686: let oldtnode = getNode tEq tSyn oldfidx oldti.tname oldti None in
687: let tnode = getNode tEq tSyn fidx ti.tname ti None in
688: if oldtnode == tnode then (* We already know they are the same *)
689: ()
690: else begin
691: (* Replace with the representative data *)
692: let oldti = oldtnode.ndata in
693: let oldfidx = oldtnode.nfidx in
694: let ti = tnode.ndata in
695: let fidx = tnode.nfidx in
696: (* Flx_cil_check that they are the same *)
697: (try
698: ignore (combineTypes CombineOther oldfidx oldti.ttype fidx ti.ttype);
699: with Failure reason -> begin
700: let msg =
701: P.sprint ~width:80
702: (P.dprintf
703: "\n\tFailed assumption that %s and %s are isomorphic %s"
704: oldti.tname ti.tname reason) in
705: raise (Failure msg)
706: end);
707: let _ = union oldtnode tnode in
708: ()
709: end
710:
711: (* Scan all files and do two things *)
712: (* 1. Initialize the alpha renaming tables with the names of the globals so
713: * that when we come in the second pass to generate new names, we do not run
714: * into conflicts. *)
715: (* 2. For all declarations of globals unify their types. In the process
716: * construct a set of equivalence classes on type names, structure and
717: * enumeration tags *)
718: (* 3. We clean the referenced flags *)
719:
720: let rec oneFilePass1 (f:file) : unit =
721: H.add fileNames !currentFidx f.fileName;
722: if debugMerge || !E.verboseFlag then
723: ignore (E.log "Pre-merging (%d) %s\n" !currentFidx f.fileName);
724: currentDeclIdx := 0;
725: if f.globinitcalled || f.globinit <> None then
726: E.s (E.warn "Merging file %s has global initializer" f.fileName);
727:
728: (* We scan each file and we look at all global varinfo. We see if globals
729: * with the same name have been encountered before and we merge those types
730: * *)
731: let matchVarinfo (vi: varinfo) (l: location * int) =
732: ignore (registerAlphaName vtAlpha None vi.vname);
733: (* Make a node for it and put it in vEq *)
734: let vinode = mkSelfNode vEq vSyn !currentFidx vi.vname vi (Some l) in
735: try
736: let oldvinode = find true (H.find vEnv vi.vname) in
737: let oldloc, _ =
738: match oldvinode.nloc with
739: None -> E.s (bug "old variable is undefined")
740: | Some l -> l
741: in
742: let oldvi = oldvinode.ndata in
743: (* There is an old definition. We must combine the types. Do this first
744: * because it might fail *)
745: let newtype =
746: try
747: combineTypes CombineOther
748: oldvinode.nfidx oldvi.vtype
749: !currentFidx vi.vtype;
750: with (Failure reason) -> begin
751: (* Go ahead *)
752: let f = if !ignore_merge_conflicts then warn else error in
753: ignore (f "Incompatible declaration for %s (from %s(%d)).@! Previous was at %a (from %s (%d)) %s "
754: vi.vname (H.find fileNames !currentFidx) !currentFidx
755: d_loc oldloc
756: (H.find fileNames oldvinode.nfidx) oldvinode.nfidx
757: reason);
758: raise Not_found
759: end
760: in
761: let newrep, _ = union oldvinode vinode in
762: (* We do not want to turn non-"const" globals into "const" one. That
763: * can happen if one file declares the variable a non-const while
764: * others declare it as "const". *)
765: if hasAttribute "const" (typeAttrs vi.vtype) !=
766: hasAttribute "const" (typeAttrs oldvi.vtype) then begin
767: newrep.ndata.vtype <- typeRemoveAttributes ["const"] newtype;
768: end else begin
769: newrep.ndata.vtype <- newtype;
770: end;
771: (* clean up the storage. *)
772: let newstorage =
773: if vi.vstorage = oldvi.vstorage || vi.vstorage = Extern then
774: oldvi.vstorage
775: else if oldvi.vstorage = Extern then vi.vstorage
776: (* Sometimes we turn the NoStorage specifier into Static for inline
777: * functions *)
778: else if oldvi.vstorage = Static &&
779: vi.vstorage = NoStorage then Static
780: else begin
781: ignore (warn "Inconsistent storage specification for %s. Now is %a and previous was %a at %a"
782: vi.vname d_storage vi.vstorage d_storage oldvi.vstorage
783: d_loc oldloc);
784: vi.vstorage
785: end
786: in
787: newrep.ndata.vstorage <- newstorage;
788: newrep.ndata.vattr <- addAttributes oldvi.vattr vi.vattr;
789: ()
790: with Not_found -> (* Not present in the previous files. Remember it for
791: * later *)
792: H.add vEnv vi.vname vinode
793:
794: in
795: List.iter
796: (function
797: | GVarDecl (vi, l) | GVar (vi, _, l) ->
798: currentLoc := l;
799: incr currentDeclIdx;
800: vi.vreferenced <- false;
801: if vi.vstorage <> Static then begin
802: matchVarinfo vi (l, !currentDeclIdx);
803: end
804:
805: | GFun (fdec, l) ->
806: currentLoc := l;
807: incr currentDeclIdx;
808: (* Save the names of the formal arguments *)
809: let _, args, _, _ = splitFunctionTypeVI fdec.svar in
810: H.add formalNames (!currentFidx, fdec.svar.vname)
811: (List.map (fun (fn, _, _) -> fn) (argsToList args));
812: fdec.svar.vreferenced <- false;
813: (* Force inline functions to be static. *)
814: (* GN: This turns out to be wrong. inline functions are external,
815: * unless specified to be static. *)
816: (*
817: if fdec.svar.vinline && fdec.svar.vstorage = NoStorage then
818: fdec.svar.vstorage <- Static;
819: *)
820: if fdec.svar.vstorage <> Static then begin
821: matchVarinfo fdec.svar (l, !currentDeclIdx)
822: end else begin
823: if fdec.svar.vinline && mergeInlines then
824: (* Just create the nodes for inline functions *)
825: ignore (getNode iEq iSyn !currentFidx
826: fdec.svar.vname fdec.svar (Some (l, !currentDeclIdx)))
827: end
828: (* Make nodes for the defined type and structure tags *)
829: | GType (t, l) ->
830: incr currentDeclIdx;
831: t.treferenced <- false;
832: if t.tname <> "" then (* The empty names are just for introducing
833: * undefined comp tags *)
834: ignore (getNode tEq tSyn !currentFidx t.tname t
835: (Some (l, !currentDeclIdx)))
836: else begin (* Go inside and clean the referenced flag for the
837: * declared tags *)
838: match t.ttype with
839: TComp (ci, _) ->
840: ci.creferenced <- false;
841: (* Create a node for it *)
842: ignore (getNode sEq sSyn !currentFidx ci.cname ci None)
843:
844: | TEnum (ei, _) ->
845: ei.ereferenced <- false;
846: ignore (getNode eEq eSyn !currentFidx ei.ename ei None);
847:
848: | _ -> E.s (bug "Anonymous Gtype is not TComp")
849: end
850:
851: | GCompTag (ci, l) ->
852: incr currentDeclIdx;
853: ci.creferenced <- false;
854: ignore (getNode sEq sSyn !currentFidx ci.cname ci
855: (Some (l, !currentDeclIdx)))
856: | GEnumTag (ei, l) ->
857: incr currentDeclIdx;
858: ei.ereferenced <- false;
859: ignore (getNode eEq eSyn !currentFidx ei.ename ei
860: (Some (l, !currentDeclIdx)))
861:
862: | _ -> ())
863: f.globals
864:
865:
866: (* Try to merge synonyms. Do not give an error if they fail to merge *)
867: let doMergeSynonyms
868: (syn : (string, 'a node) H.t)
869: (eq : (int * string, 'a node) H.t)
870: (compare : int -> 'a -> int -> 'a -> unit) (* A comparison function that
871: * throws Failure if no match *)
872: : unit =
873: H.iter (fun n node ->
874: if not node.nmergedSyns then begin
875: (* find all the nodes for the same name *)
876: let all = H.find_all syn n in
877: let rec tryone (classes: 'a node list) (* A number of representatives
878: * for this name *)
879: (nd: 'a node) : 'a node list (* Returns an expanded set
880: * of classes *) =
881: nd.nmergedSyns <- true;
882: (* Compare in turn with all the classes we have so far *)
883: let rec compareWithClasses = function
884: [] -> [nd](* No more classes. Add this as a new class *)
885: | c :: restc ->
886: try
887: compare c.nfidx c.ndata nd.nfidx nd.ndata;
888: (* Success. Stop here the comparison *)
889: c :: restc
890: with Failure _ -> (* Failed. Try next class *)
891: c :: (compareWithClasses restc)
892: in
893: compareWithClasses classes
894: in
895: (* Start with an empty set of classes for this name *)
896: let _ = List.fold_left tryone [] all in
897: ()
898: end)
899: syn
900:
901:
902: let matchInlines (oldfidx: int) (oldi: varinfo)
903: (fidx: int) (i: varinfo) =
904: let oldinode = getNode iEq iSyn oldfidx oldi.vname oldi None in
905: let inode = getNode iEq iSyn fidx i.vname i None in
906: if oldinode == inode then
907: ()
908: else begin
909: (* Replace with the representative data *)
910: let oldi = oldinode.ndata in
911: let oldfidx = oldinode.nfidx in
912: let i = inode.ndata in
913: let fidx = inode.nfidx in
914: (* There is an old definition. We must combine the types. Do this first
915: * because it might fail *)
916: oldi.vtype <-
917: combineTypes CombineOther
918: oldfidx oldi.vtype fidx i.vtype;
919: (* We get here if we have success *)
920: (* Combine the attributes as well *)
921: oldi.vattr <- addAttributes oldi.vattr i.vattr;
922: (* Do not union them yet because we do not know that they are the same.
923: * We have checked only the types so far *)
924: ()
925: end
926:
927: (************************************************************
928: *
929: * PASS 2
930: *
931: *
932: ************************************************************)
933:
934: (** Keep track of the functions we have used already in the file. We need
935: * this to avoid removing an inline function that has been used already.
936: * This can only occur if the inline function is defined after it is used
937: * already; a bad style anyway *)
938: let varUsedAlready: (string, unit) H.t = H.create 111
939:
940: (** A visitor that renames uses of variables and types *)
941: class renameVisitorClass = object (self)
942: inherit nopCilVisitor
943:
944: (* This is either a global variable which we took care of, or a local
945: * variable. Must do its type and attributes. *)
946: method vvdec (vi: varinfo) = DoChildren
947:
948: (* This is a variable use. See if we must change it *)
949: method vvrbl (vi: varinfo) : varinfo visitAction =
950: if not vi.vglob then DoChildren else
951: if vi.vreferenced then begin
952: H.add varUsedAlready vi.vname ();
953: DoChildren
954: end else begin
955: match findReplacement true vEq !currentFidx vi.vname with
956: None -> DoChildren
957: | Some (vi', oldfidx) ->
958: if debugMerge then
959: ignore (E.log "Renaming use of var %s(%d) to %s(%d)\n"
960: vi.vname !currentFidx vi'.vname oldfidx);
961: vi'.vreferenced <- true;
962: H.add varUsedAlready vi'.vname ();
963: ChangeTo vi'
964: end
965:
966:
967: (* The use of a type. Change only those types whose underlying info
968: * is not a root. *)
969: method vtype (t: typ) =
970: match t with
971: TComp (ci, a) when not ci.creferenced -> begin
972: match findReplacement true sEq !currentFidx ci.cname with
973: None -> DoChildren
974: | Some (ci', oldfidx) ->
975: if debugMerge then
976: ignore (E.log "Renaming use of %s(%d) to %s(%d)\n"
977: ci.cname !currentFidx ci'.cname oldfidx);
978: ChangeTo (TComp (ci', visitCilAttributes (self :> cilVisitor) a))
979: end
980: | TEnum (ei, a) when not ei.ereferenced -> begin
981: match findReplacement true eEq !currentFidx ei.ename with
982: None -> DoChildren
983: | Some (ei', _) ->
984: if ei' == intEnumInfo then
985: (* This is actually our friend intEnumInfo *)
986: ChangeTo (TInt(IInt, visitCilAttributes (self :> cilVisitor) a))
987: else
988: ChangeTo (TEnum (ei', visitCilAttributes (self :> cilVisitor) a))
989: end
990:
991: | TNamed (ti, a) when not ti.treferenced -> begin
992: match findReplacement true tEq !currentFidx ti.tname with
993: None -> DoChildren
994: | Some (ti', _) ->
995: ChangeTo (TNamed (ti', visitCilAttributes (self :> cilVisitor) a))
996: end
997:
998: | _ -> DoChildren
999:
1000: (* The Field offset might need to be changed to use new compinfo *)
1001: method voffs = function
1002: Field (f, o) -> begin
1003: (* See if the compinfo was changed *)
1004: if f.fcomp.creferenced then
1005: DoChildren
1006: else begin
1007: match findReplacement true sEq !currentFidx f.fcomp.cname with
1008: None -> DoChildren (* We did not replace it *)
1009: | Some (ci', oldfidx) -> begin
1010: (* First, find out the index of the original field *)
1011: let rec indexOf (i: int) = function
1012: [] ->
1013: E.s (bug "Cannot find field %s in %s(%d)\n"
1014: f.fname (compFullName f.fcomp) !currentFidx)
1015: | f' :: rest when f' == f -> i
1016: | _ :: rest -> indexOf (i + 1) rest
1017: in
1018: let index = indexOf 0 f.fcomp.cfields in
1019: if List.length ci'.cfields <= index then
1020: E.s (bug "Too few fields in replacement %s(%d) for %s(%d)\n"
1021: (compFullName ci') oldfidx
1022: (compFullName f.fcomp) !currentFidx);
1023: let f' = List.nth ci'.cfields index in
1024: ChangeDoChildrenPost (Field (f', o), fun x -> x)
1025: end
1026: end
1027: end
1028: | _ -> DoChildren
1029:
1030: method vinitoffs o =
1031: (self#voffs o) (* treat initializer offsets same as lvalue offsets *)
1032:
1033: end
1034:
1035: let renameVisitor = new renameVisitorClass
1036:
1037:
1038: (** A visitor that renames uses of inline functions that were discovered in
1039: * pass 2 to be used before they are defined. This is like the renameVisitor
1040: * except it only looks at the variables (thus it is a bit more efficient)
1041: * and it also renames forward declarations of the inlines to be removed. *)
1042:
1043: class renameInlineVisitorClass = object (self)
1044: inherit nopCilVisitor
1045:
1046: (* This is a variable use. See if we must change it *)
1047: method vvrbl (vi: varinfo) : varinfo visitAction =
1048: if not vi.vglob then DoChildren else
1049: if vi.vreferenced then begin (* Already renamed *)
1050: DoChildren
1051: end else begin
1052: match findReplacement true vEq !currentFidx vi.vname with
1053: None -> DoChildren
1054: | Some (vi', oldfidx) ->
1055: if debugMerge then
1056: ignore (E.log "Renaming var %s(%d) to %s(%d)\n"
1057: vi.vname !currentFidx vi'.vname oldfidx);
1058: vi'.vreferenced <- true;
1059: ChangeTo vi'
1060: end
1061:
1062: (* And rename some declarations of inlines to remove. We cannot drop this
1063: * declaration (see small1/combineinline6) *)
1064: method vglob = function
1065: GVarDecl(vi, l) when vi.vinline -> begin
1066: (* Get the original name *)
1067: let origname =
1068: try H.find originalVarNames vi.vname
1069: with Not_found -> vi.vname
1070: in
1071: (* Now see if this must be replaced *)
1072: match findReplacement true vEq !currentFidx origname with
1073: None -> DoChildren
1074: | Some (vi', _) -> ChangeTo [GVarDecl (vi', l)]
1075: end
1076: | _ -> DoChildren
1077:
1078: end
1079: let renameInlinesVisitor = new renameInlineVisitorClass
1080:
1081:
1082: (* sm: First attempt at a semantic checksum for function bodies.
1083: * Ideally, two function's checksums would be equal only when their
1084: * bodies were provably equivalent; but I'm using a much simpler and
1085: * less accurate heuristic here. It should be good enough for the
1086: * purpose I have in mind, which is doing duplicate removal of
1087: * multiply-instantiated template functions. *)
1088: let functionFlx_cil_checksum (dec: fundec) : int =
1089: begin
1090: (* checksum the structure of the statements (only) *)
1091: let rec stmtListSum (lst : stmt list) : int =
1092: (List.fold_left (fun acc s -> acc + (stmtSum s)) 0 lst)
1093: and stmtSum (s: stmt) : int =
1094: (* strategy is to just throw a lot of prime numbers into the
1095: * computation in hopes of avoiding accidental collision.. *)
1096: match s.skind with
1097: | Instr(l) -> 13 + 67*(List.length l)
1098: | Return(_) -> 17
1099: | Goto(_) -> 19
1100: | Break(_) -> 23
1101: | Continue(_) -> 29
1102: | If(_,b1,b2,_) -> 31 + 37*(stmtListSum b1.bstmts)
1103: + 41*(stmtListSum b2.bstmts)
1104: | Switch(_,b,_,_) -> 43 + 47*(stmtListSum b.bstmts)
1105: (* don't look at stmt list b/c is not part of tree *)
1106: | Loop(b,_,_,_) -> 49 + 53*(stmtListSum b.bstmts)
1107: | Block(b) -> 59 + 61*(stmtListSum b.bstmts)
1108: | TryExcept (b, (il, e), h, _) ->
1109: 67 + 83*(stmtListSum b.bstmts) + 97*(stmtListSum h.bstmts)
1110: | TryFinally (b, h, _) ->
1111: 103 + 113*(stmtListSum b.bstmts) + 119*(stmtListSum h.bstmts)
1112: in
1113:
1114: (* disabled 2nd and 3rd measure because they appear to get different
1115: * values, for the same code, depending on whether the code was just
1116: * parsed into CIL or had previously been parsed into CIL, printed
1117: * out, then re-parsed into CIL *)
1118: let a,b,c,d,e =
1119: (List.length dec.sformals), (* # formals *)
1120: 0 (*(List.length dec.slocals)*), (* # locals *)
1121: 0 (*dec.smaxid*), (* estimate of internal statement count *)
1122: (List.length dec.sbody.bstmts), (* number of statements at outer level *)
1123: (stmtListSum dec.sbody.bstmts) in (* checksum of statement structure *)
1124: (*(trace "sm" (P.dprintf "sum: %s is %d %d %d %d %d\n"*)
1125: (* dec.svar.vname a b c d e));*)
1126: 2*a + 3*b + 5*c + 7*d + 11*e
1127: end
1128:
1129:
1130: (* sm: equality for initializers, etc.; this is like '=', except
1131: * when we reach shared pieces (like references into the type
1132: * structure), we use '==', to prevent circularity *)
1133: (* update: that's no good; I'm using this to find things which
1134: * are equal but from different CIL trees, so nothing will ever
1135: * be '=='.. as a hack I'll just change those places to 'true',
1136: * so these functions are not now checking proper equality..
1137: * places where equality is not complete are marked "INC" *)
1138: let rec equalInits (x: init) (y: init) : bool =
1139: begin
1140: match x,y with
1141: | SingleInit(xe), SingleInit(ye) -> (equalExps xe ye)
1142: | CompoundInit(xt, xoil), CompoundInit(yt, yoil) ->
1143: (*(xt == yt) &&*) (* INC *) (* types need to be identically equal *)
1144: let rec equalLists xoil yoil : bool =
1145: match xoil,yoil with
1146: | ((xo,xi) :: xrest), ((yo,yi) :: yrest) ->
1147: (equalOffsets xo yo) &&
1148: (equalInits xi yi) &&
1149: (equalLists xrest yrest)
1150: | [], [] -> true
1151: | _, _ -> false
1152: in
1153: (equalLists xoil yoil)
1154: | _, _ -> false
1155: end
1156:
1157: and equalOffsets (x: offset) (y: offset) : bool =
1158: begin
1159: match x,y with
1160: | NoOffset, NoOffset -> true
1161: | Field(xfi,xo), Field(yfi,yo) ->
1162: (xfi.fname = yfi.fname) && (* INC: same fieldinfo name.. *)
1163: (equalOffsets xo yo)
1164: | Index(xe,xo), Index(ye,yo) ->
1165: (equalExps xe ye) &&
1166: (equalOffsets xo yo)
1167: | _,_ -> false
1168: end
1169:
1170: and equalExps (x: exp) (y: exp) : bool =
1171: begin
1172: match x,y with
1173: | Const(xc), Const(yc) -> xc = yc || (* safe to use '=' on literals *)
1174: (
1175: (* CIL changes (unsigned)0 into 0U during printing.. *)
1176: match xc,yc with
1177: | CInt64(xv,_,_),CInt64(yv,_,_) ->
1178: (Int64.to_int xv) = 0 && (* ok if they're both 0 *)
1179: (Int64.to_int yv) = 0
1180: | _,_ -> false
1181: )
1182: | Lval(xl), Lval(yl) -> (equalLvals xl yl)
1183: | SizeOf(xt), SizeOf(yt) -> true (*INC: xt == yt*) (* identical types *)
1184: | SizeOfE(xe), SizeOfE(ye) -> (equalExps xe ye)
1185: | AlignOf(xt), AlignOf(yt) -> true (*INC: xt == yt*)
1186: | AlignOfE(xe), AlignOfE(ye) -> (equalExps xe ye)
1187: | UnOp(xop,xe,xt), UnOp(yop,ye,yt) ->
1188: xop = yop &&
1189: (equalExps xe ye) &&
1190: true (*INC: xt == yt*)
1191: | BinOp(xop,xe1,xe2,xt), BinOp(yop,ye1,ye2,yt) ->
1192: xop = yop &&
1193: (equalExps xe1 ye1) &&
1194: (equalExps xe2 ye2) &&
1195: true (*INC: xt == yt*)
1196: | CastE(xt,xe), CastE(yt,ye) ->
1197: (*INC: xt == yt &&*)
1198: (equalExps xe ye)
1199: | AddrOf(xl), AddrOf(yl) -> (equalLvals xl yl)
1200: | StartOf(xl), StartOf(yl) -> (equalLvals xl yl)
1201:
1202: (* initializers that go through CIL multiple times sometimes lose casts they
1203: * had the first time; so allow a different of a cast *)
1204: | CastE(xt,xe), ye ->
1205: (equalExps xe ye)
1206: | xe, CastE(yt,ye) ->
1207: (equalExps xe ye)
1208:
1209: | _,_ -> false
1210: end
1211:
1212: and equalLvals (x: lval) (y: lval) : bool =
1213: begin
1214: match x,y with
1215: | (Var(xv),xo), (Var(yv),yo) ->
1216: (* I tried, I really did.. the problem is I see these names
1217: * before merging collapses them, so __T123 != __T456,
1218: * so whatever *)
1219: (*(xv.vname = vy.vname) && (* INC: same varinfo names.. *)*)
1220: (equalOffsets xo yo)
1221:
1222: | (Mem(xe),xo), (Mem(ye),yo) ->
1223: (equalExps xe ye) &&
1224: (equalOffsets xo yo)
1225: | _,_ -> false
1226: end
1227:
1228: let equalInitOpts (x: init option) (y: init option) : bool =
1229: begin
1230: match x,y with
1231: | None,None -> true
1232: | Some(xi), Some(yi) -> (equalInits xi yi)
1233: | _,_ -> false
1234: end
1235:
1236:
1237: (* Now we go once more through the file and we rename the globals that we
1238: * keep. We also scan the entire body and we replace references to the
1239: * representative types or variables. We set the referenced flags once we
1240: * have replaced the names. *)
1241: let oneFilePass2 (f: file) =
1242: if debugMerge || !E.verboseFlag then
1243: ignore (E.log "Final merging phase (%d): %s\n"
1244: !currentFidx f.fileName);
1245: currentDeclIdx := 0; (* Even though we don't need it anymore *)
1246: H.clear varUsedAlready;
1247: H.clear originalVarNames;
1248: (* If we find inline functions that are used before being defined, and thus
1249: * before knowing that we can throw them away, then we mark this flag so
1250: * that we can make another pass over the file *)
1251: let repeatPass2 = ref false in
1252: (* Keep a pointer to the contents of the file so far *)
1253: let savedTheFile = !theFile in
1254:
1255: let processOneGlobal (g: global) : unit =
1256: (* Process a varinfo. Reuse an old one, or rename it if necessary *)
1257: let processVarinfo (vi: varinfo) (vloc: location) : varinfo =
1258: if vi.vreferenced then
1259: vi (* Already done *)
1260: else begin
1261: (* Maybe it is static. Rename it then *)
1262: if vi.vstorage = Static then begin
1263: let newName, _ = newAlphaName vtAlpha None vi.vname in
1264: (* Remember the original name *)
1265: H.add originalVarNames newName vi.vname;
1266: if debugMerge then ignore (E.log "renaming %s at %a to %s\n"
1267: vi.vname d_loc vloc newName);
1268: vi.vname <- newName;
1269: vi.vid <- H.hash vi.vname;
1270: vi.vreferenced <- true;
1271: vi
1272: end else begin
1273: (* Find the representative *)
1274: match findReplacement true vEq !currentFidx vi.vname with
1275: None -> vi (* This is the representative *)
1276: | Some (vi', _) -> (* Reuse some previous one *)
1277: vi'.vreferenced <- true; (* Mark it as done already *)
1278: vi'.vaddrof <- vi.vaddrof || vi'.vaddrof;
1279: vi'
1280: end
1281: end
1282: in
1283: try
1284: match g with
1285: | GVarDecl (vi, l) as g ->
1286: currentLoc := l;
1287: incr currentDeclIdx;
1288: let vi' = processVarinfo vi l in
1289: if vi != vi' then (* Drop this declaration *) ()
1290: else if H.mem emittedVarDecls vi'.vname then (* No need to keep it *)
1291: ()
1292: else begin
1293: H.add emittedVarDecls vi'.vname true; (* Remember that we emitted
1294: * it *)
1295: mergePushGlobals (visitCilGlobal renameVisitor g)
1296: end
1297:
1298: | GVar (vi, init, l) as g ->
1299: currentLoc := l;
1300: incr currentDeclIdx;
1301: let vi' = processVarinfo vi l in
1302: (* We must keep this definition even if we reuse this varinfo,
1303: * because maybe the previous one was a declaration *)
1304: H.add emittedVarDecls vi.vname true; (* Remember that we emitted it*)
1305:
1306: let emitIt:bool = (not mergeGlobals) ||
1307: try
1308: let prevVar, prevInitOpt, prevLoc =
1309: (H.find emittedVarDefn vi'.vname) in
1310: (* previously defined; same initializer? *)
1311: if (equalInitOpts prevInitOpt init.init) then (
1312: (trace "mergeGlob"
1313: (P.dprintf "dropping global var %s at %a in favor of the one at %a\n"
1314: vi'.vname d_loc l d_loc prevLoc));
1315: false (* do not emit *)
1316: )
1317: else (
1318: (ignore (warn "global var %s at %a has different initializer than %a\n"
1319: vi'.vname d_loc l d_loc prevLoc));
1320: (* emit it so we get a compiler error.. I think it would be
1321: * better to give an error message and *not* emit, since doing
1322: * this explicitly violates the CIL invariant of only one GVar
1323: * per name, but the rest of this file is very permissive so
1324: * I'll be similarly permissive.. *)
1325: true
1326: )
1327: with Not_found -> (
1328: (* no previous definition *)
1329: (H.add emittedVarDefn vi'.vname (vi', init.init, l));
1330: true (* emit it *)
1331: )
1332: in
1333:
1334: if emitIt then
1335: mergePushGlobals (visitCilGlobal renameVisitor (GVar(vi', init, l)))
1336:
1337: | GFun (fdec, l) as g ->
1338: currentLoc := l;
1339: incr currentDeclIdx;
1340: (* We apply the renaming *)
1341: fdec.svar <- processVarinfo fdec.svar l;
1342: (* Get the original name. *)
1343: let origname =
1344: try H.find originalVarNames fdec.svar.vname
1345: with Not_found -> fdec.svar.vname
1346: in
1347: (* Go in there and rename everything as needed *)
1348: let fdec' =
1349: match visitCilGlobal renameVisitor g with
1350: [GFun(fdec', _)] -> fdec'
1351: | _ -> E.s (unimp "renameVisitor for GFun returned something else")
1352: in
1353: let g' = GFun(fdec', l) in
1354: (* Now restore the parameter names *)
1355: let _, args, _, _ = splitFunctionTypeVI fdec'.svar in
1356: let oldnames, foundthem =
1357: try H.find formalNames (!currentFidx, origname), true
1358: with Not_found -> begin
1359: ignore (warnOpt "Cannot find %s in formalNames" origname);
1360: [], false
1361: end
1362: in
1363: if foundthem then begin
1364: let argl = argsToList args in
1365: if List.length oldnames <> List.length argl then
1366: E.s (unimp "After merging the function has more arguments");
1367: List.iter2
1368: (fun oldn a -> if oldn <> "" then a.vname <- oldn)
1369: oldnames fdec.sformals;
1370: (* Reflect them in the type *)
1371: setFormals fdec fdec.sformals
1372: end;
1373: (** See if we can remove this inline function *)
1374: if fdec'.svar.vinline && mergeInlines then begin
1375: let printout =
1376: (* Temporarily turn of printing of lines *)
1377: let oldprintln = !lineDirectiveStyle in
1378: lineDirectiveStyle := None;
1379: (* Temporarily set the name to all functions in the same way *)
1380: let newname = fdec'.svar.vname in
1381: fdec'.svar.vname <- "@@alphaname@@";
1382: (* If we must do alpha conversion then temporarily set the
1383: * names of the local variables and formals in a standard way *)
1384: let nameId = ref 0 in
1385: let newName () = incr nameId; in
1386: let oldNames : string list ref = ref [] in
1387: let renameOne (v: varinfo) =
1388: oldNames := v.vname :: !oldNames;
1389: incr nameId;
1390: v.vname <- "___alpha" ^ string_of_int !nameId
1391: in
1392: let undoRenameOne (v: varinfo) =
1393: match !oldNames with
1394: n :: rest ->
1395: oldNames := rest;
1396: v.vname <- n
1397: | _ -> E.s (bug "undoRenameOne")
1398: in
1399: (* Remember the original type *)
1400: let origType = fdec'.svar.vtype in
1401: if mergeInlinesWithAlphaConvert then begin
1402: (* Rename the formals *)
1403: List.iter renameOne fdec'.sformals;
1404: (* Reflect in the type *)
1405: setFormals fdec' fdec'.sformals;
1406: (* Now do the locals *)
1407: List.iter renameOne fdec'.slocals
1408: end;
1409: (* Now print it *)
1410: let res = d_global () g' in
1411: lineDirectiveStyle := oldprintln;
1412: fdec'.svar.vname <- newname;
1413: if mergeInlinesWithAlphaConvert then begin
1414: (* Do the locals in reverse order *)
1415: List.iter undoRenameOne (List.rev fdec'.slocals);
1416: (* Do the formals in reverse order *)
1417: List.iter undoRenameOne (List.rev fdec'.sformals);
1418: (* Restore the type *)
1419: fdec'.svar.vtype <- origType;
1420: end;
1421: res
1422: in
1423: (* Make a node for this inline function using the original name. *)
1424: let inode =
1425: getNode vEq vSyn !currentFidx origname fdec'.svar
1426: (Some (l, !currentDeclIdx))
1427: in
1428: if debugInlines then begin
1429: ignore (E.log "getNode %s(%d) with loc=%a. declidx=%d\n"
1430: inode.nname inode.nfidx
1431: d_nloc inode.nloc
1432: !currentDeclIdx);
1433: ignore (E.log
1434: "Looking for previous definition of inline %s(%d)\n"
1435: origname !currentFidx);
1436: end;
1437: try
1438: let oldinode = H.find inlineBodies printout in
1439: if debugInlines then
1440: ignore (E.log " Matches %s(%d)\n"
1441: oldinode.nname oldinode.nfidx);
1442: (* There is some other inline function with the same printout.
1443: * We should reuse this, but watch for the case when the inline
1444: * was already used. *)
1445: if H.mem varUsedAlready fdec'.svar.vname then begin
1446: if mergeInlinesRepeat then begin
1447: repeatPass2 := true
1448: end else begin
1449: ignore (warn "Inline function %s because it is used before it is defined" fdec'.svar.vname);
1450: raise Not_found
1451: end
1452: end;
1453: let _ = union oldinode inode in
1454: (* Clean up the vreferenced bit in the new inline, so that we
1455: * can rename it. Reset the name to the original one so that
1456: * we can find the replacement name. *)
1457: fdec'.svar.vreferenced <- false;
1458: fdec'.svar.vname <- origname;
1459: () (* Drop this definition *)
1460: with Not_found -> begin
1461: if debugInlines then ignore (E.log " Not found\n");
1462: H.add inlineBodies printout inode;
1463: mergePushGlobal g'
1464: end
1465: end else begin
1466: (* either the function is not inline, or we're not attempting to
1467: * merge inlines *)
1468: if (mergeGlobals &&
1469: not fdec'.svar.vinline &&
1470: fdec'.svar.vstorage <> Static) then
1471: begin
1472: (* sm: this is a non-inline, non-static function. I want to
1473: * consider dropping it if a same-named function has already
1474: * been put into the merged file *)
1475: let curSum = (functionFlx_cil_checksum fdec') in
1476: (*(trace "mergeGlob" (P.dprintf "I see extern function %s, sum is %d\n"*)
1477: (* fdec'.svar.vname curSum));*)
1478: try
1479: let prevFun, prevLoc, prevSum =
1480: (H.find emittedFunDefn fdec'.svar.vname) in
1481: (* previous was found *)
1482: if (curSum = prevSum) then
1483: (trace "mergeGlob"
1484: (P.dprintf "dropping duplicate def'n of func %s at %a in favor of that at %a\n"
1485: fdec'.svar.vname d_loc l d_loc prevLoc))
1486: else begin
1487: (* the checksums differ, so print a warning but keep the
1488: * older one to avoid a link error later. I think this is
1489: * a reasonable approximation of what ld does. *)
1490: (ignore (warn "def'n of func %s at %a (sum %d) conflicts with the one at %a (sum %d); keeping the one at %a.\n"
1491: fdec'.svar.vname d_loc l curSum d_loc prevLoc
1492: prevSum d_loc prevLoc))
1493: end
1494: with Not_found -> begin
1495: (* there was no previous definition *)
1496: (mergePushGlobal g');
1497: (H.add emittedFunDefn fdec'.svar.vname (fdec', l, curSum))
1498: end
1499: end else begin
1500: (* not attempting to merge global functions, or it was static
1501: * or inline *)
1502: mergePushGlobal g'
1503: end
1504: end
1505:
1506: | GCompTag (ci, l) as g -> begin
1507: currentLoc := l;
1508: incr currentDeclIdx;
1509: if ci.creferenced then
1510: ()
1511: else begin
1512: match findReplacement true sEq !currentFidx ci.cname with
1513: None ->
1514: (* A new one, we must rename it and keep the definition *)
1515: (* Make sure this is root *)
1516: (try
1517: let nd = H.find sEq (!currentFidx, ci.cname) in
1518: if nd.nrep != nd then
1519: E.s (bug "Setting creferenced for struct %s(%d) which is not root!\n"
1520: ci.cname !currentFidx);
1521: with Not_found -> begin
1522: E.s (bug "Setting creferenced for struct %s(%d) which is not in the sEq!\n"
1523: ci.cname !currentFidx);
1524: end);
1525: let newname, _ = newAlphaName sAlpha None ci.cname in
1526: ci.cname <- newname;
1527: ci.creferenced <- true;
1528: ci.ckey <- H.hash (compFullName ci);
1529: (* Now we should visit the fields as well *)
1530: H.add emittedCompDecls ci.cname true; (* Remember that we
1531: * emitted it *)
1532: mergePushGlobals (visitCilGlobal renameVisitor g)
1533: | Some (oldci, oldfidx) -> begin
1534: (* We are not the representative. Drop this declaration
1535: * because we'll not be using it. *)
1536: ()
1537: end
1538: end
1539: end
1540: | GEnumTag (ei, l) as g -> begin
1541: currentLoc := l;
1542: incr currentDeclIdx;
1543: if ei.ereferenced then
1544: ()
1545: else begin
1546: match findReplacement true eEq !currentFidx ei.ename with
1547: None -> (* We must rename it *)
1548: let newname, _ = newAlphaName eAlpha None ei.ename in
1549: ei.ename <- newname;
1550: ei.ereferenced <- true;
1551: (* And we must rename the items to using the same name space
1552: * as the variables *)
1553: ei.eitems <-
1554: List.map
1555: (fun (n, i, loc) ->
1556: let newname, _ = newAlphaName vtAlpha None n in
1557: newname, i, loc)
1558: ei.eitems;
1559: mergePushGlobals (visitCilGlobal renameVisitor g);
1560: | Some (ei', _) -> (* Drop this since we are reusing it from
1561: * before *)
1562: ()
1563: end
1564: end
1565: | GCompTagDecl (ci, l) -> begin
1566: currentLoc := l; (* This is here just to introduce an undefined
1567: * structure. But maybe the structure was defined
1568: * already. *)
1569: (* Do not increment currentDeclIdx because it is not incremented in
1570: * pass 1*)
1571: if H.mem emittedCompDecls ci.cname then
1572: () (* It was already declared *)
1573: else begin
1574: H.add emittedCompDecls ci.cname true;
1575: (* Keep it as a declaration *)
1576: mergePushGlobal g;
1577: end
1578: end
1579:
1580: | GEnumTagDecl (ei, l) ->
1581: currentLoc := l;
1582: (* Do not increment currentDeclIdx because it is not incremented in
1583: * pass 1*)
1584: (* Keep it as a declaration *)
1585: mergePushGlobal g
1586:
1587:
1588: | GType (ti, l) as g -> begin
1589: currentLoc := l;
1590: incr currentDeclIdx;
1591: if ti.treferenced then
1592: ()
1593: else begin
1594: match findReplacement true tEq !currentFidx ti.tname with
1595: None -> (* We must rename it and keep it *)
1596: let newname, _ = newAlphaName vtAlpha None ti.tname in
1597: ti.tname <- newname;
1598: ti.treferenced <- true;
1599: mergePushGlobals (visitCilGlobal renameVisitor g);
1600: | Some (ti', _) ->(* Drop this since we are reusing it from
1601: * before *)
1602: ()
1603: end
1604: end
1605: | g -> mergePushGlobals (visitCilGlobal renameVisitor g)
1606: with e -> begin
1607: let globStr:string = (P.sprint 1000 (P.dprintf
1608: "error when merging global %a: %s"
1609: d_global g (Printexc.to_string e))) in
1610: ignore (E.log "%s\n" globStr);
1611: (*"error when merging global: %s\n" (Printexc.to_string e);*)
1612: mergePushGlobal (GText (P.sprint 80
1613: (P.dprintf "/* error at %t:" d_thisloc)));
1614: mergePushGlobal g;
1615: mergePushGlobal (GText ("*************** end of error*/"));
1616: raise e
1617: end
1618: in
1619: (* Now do the real PASS 2 *)
1620: List.iter processOneGlobal f.globals;
1621: (* See if we must re-visit the globals in this file because an inline that
1622: * is being removed was used before we saw the definition and we decided to
1623: * remove it *)
1624: if mergeInlinesRepeat && !repeatPass2 then begin
1625: if debugMerge || !E.verboseFlag then
1626: ignore (E.log "Repeat final merging phase (%d): %s\n"
1627: !currentFidx f.fileName);
1628: (* We are going to rescan the globals we have added while processing this
1629: * file. *)
1630: let theseGlobals : global list ref = ref [] in
1631: (* Scan a list of globals until we hit a given tail *)
1632: let rec scanUntil (tail: 'a list) (l: 'a list) =
1633: if tail == l then ()
1634: else
1635: match l with
1636: | [] -> E.s (bug "mergecil: scanUntil could not find the marker\n")
1637: | g :: rest ->
1638: theseGlobals := g :: !theseGlobals;
1639: scanUntil tail rest
1640: in
1641: (* Collect in theseGlobals all the globals from this file *)
1642: theseGlobals := [];
1643: scanUntil savedTheFile !theFile;
1644: (* Now reprocess them *)
1645: theFile := savedTheFile;
1646: List.iter (fun g ->
1647: theFile := (visitCilGlobal renameInlinesVisitor g) @ !theFile)
1648: !theseGlobals;
1649: (* Now check if we have inlines that we could not remove
1650: H.iter (fun name _ ->
1651: if not (H.mem inlinesRemoved name) then
1652: ignore (warn "Could not remove inline %s. I have no idea why!\n"
1653: name))
1654: inlinesToRemove *)
1655: end
1656:
1657:
1658: let merge (files: file list) (newname: string) : file =
1659: init ();
1660:
1661: (* Make the first pass over the files *)
1662: currentFidx := 0;
1663: List.iter (fun f -> oneFilePass1 f; incr currentFidx) files;
1664:
1665: (* Now maybe try to force synonyms to be equal *)
1666: if mergeSynonyms then begin
1667: doMergeSynonyms sSyn sEq matchCompInfo;
1668: doMergeSynonyms eSyn eEq matchEnumInfo;
1669: doMergeSynonyms tSyn tEq matchTypeInfo;
1670: if mergeInlines then begin
1671: (* Copy all the nodes from the iEq to vEq as well. This is needed
1672: * because vEq will be used for variable renaming *)
1673: H.iter (fun k n -> H.add vEq k n) iEq;
1674: doMergeSynonyms iSyn iEq matchInlines;
1675: end
1676: end;
1677:
1678: (* Now maybe dump the graph *)
1679: if debugMerge then begin
1680: dumpGraph "type" tEq;
1681: dumpGraph "struct and union" sEq;
1682: dumpGraph "enum" eEq;
1683: dumpGraph "variable" vEq;
1684: if mergeInlines then dumpGraph "inline" iEq;
1685: end;
1686: (* Make the second pass over the files. This is when we start rewriting the
1687: * file *)
1688: currentFidx := 0;
1689: List.iter (fun f -> oneFilePass2 f; incr currentFidx) files;
1690:
1691: (* Now reverse the result and return the resulting file *)
1692: let rec revonto acc = function
1693: [] -> acc
1694: | x :: t -> revonto (x :: acc) t
1695: in
1696: let res =
1697: { fileName = newname;
1698: globals = revonto (revonto [] !theFile) !theFileTypes;
1699: globinit = None;
1700: globinitcalled = false } in
1701: init (); (* Make the GC happy *)
1702: (* We have made many renaming changes and sometimes we have just guessed a
1703: * name wrong. Make sure now that the local names are unique. *)
1704: uniqueVarNames res;
1705: res
1706:
1707:
1708:
1709:
1710:
Start ocaml section to src/flx_cil_mergecil.mli[1
/1
]
1: # 13420 "./lpsrc/flx_cil.ipk"
2: (** Set this to true to ignore the merge conflicts *)
3: val ignore_merge_conflicts: bool ref
4:
5: (** Merge a number of CIL files *)
6: val merge: Flx_cil_cil.file list -> string -> Flx_cil_cil.file
7:
Start ocaml section to src/flx_cil_rmtmps.ml[1
/1
]
1: # 13428 "./lpsrc/flx_cil.ipk"
2: (* rmtmps.ml *)
3: (* implementation for rmtmps.mli *)
4:
5: open Flx_cil_pretty
6: open Flx_cil_cil
7: module H = Hashtbl
8: module E = Flx_cil_errormsg
9: module U = Flx_cil_util
10:
11:
12:
13: let trace = Flx_cil_trace.trace "rmtmps"
14:
15:
16:
17: (***********************************************************************
18: *
19: * Clearing of "referenced" bits
20: *
21: *)
22:
23:
24: let clearReferencedBits file =
25: let considerGlobal global =
26: match global with
27: | GType (info, _) ->
28: trace (dprintf "clearing mark: %a\n" d_shortglobal global);
29: info.treferenced <- false
30:
31: | GEnumTag (info, _)
32: | GEnumTagDecl (info, _) ->
33: trace (dprintf "clearing mark: %a\n" d_shortglobal global);
34: info.ereferenced <- false
35:
36: | GCompTag (info, _)
37: | GCompTagDecl (info, _) ->
38: trace (dprintf "clearing mark: %a\n" d_shortglobal global);
39: info.creferenced <- false
40:
41: | GVar ({vname = name} as info, _, _)
42: | GVarDecl ({vname = name} as info, _) ->
43: trace (dprintf "clearing mark: %a\n" d_shortglobal global);
44: info.vreferenced <- false
45:
46: | GFun ({svar = info} as func, _) ->
47: trace (dprintf "clearing mark: %a\n" d_shortglobal global);
48: info.vreferenced <- false;
49: let clearMark local =
50: trace (dprintf "clearing mark: local %s\n" local.vname);
51: local.vreferenced <- false
52: in
53: List.iter clearMark func.slocals
54:
55: | _ ->
56: ()
57: in
58: iterGlobals file considerGlobal
59:
60:
61: (***********************************************************************
62: *
63: * Scanning and categorization of pragmas
64: *
65: *)
66:
67:
68: (* collections of names of things to keep *)
69: type collection = (string, unit) H.t
70: type keepers = {
71: typedefs : collection;
72: enums : collection;
73: structs : collection;
74: unions : collection;
75: defines : collection;
76: }
77:
78:
79: (* rapid transfer of control when we find a malformed pragma *)
80: exception Bad_pragma
81:
82: let ccureddeepcopystring = "ccureddeepcopy"
83: (* Save this length so we don't recompute it each time. *)
84: let ccureddeepcopystring_length = String.length ccureddeepcopystring
85:
86: (* CIL and CCured define several pragmas which prevent removal of
87: * various global symbols. Here we scan for those pragmas and build
88: * up collections of the corresponding symbols' names.
89: *)
90:
91: let categorizePragmas file =
92:
93: (* names of things which should be retained *)
94: let keepers = {
95: typedefs = H.create 0;
96: enums = H.create 0;
97: structs = H.create 0;
98: unions = H.create 0;
99: defines = H.create 1
100: } in
101:
102: (* populate these name collections in light of each pragma *)
103: let considerPragma =
104:
105: let badPragma location pragma =
106: ignore (warnLoc location "Invalid argument to pragma %s" pragma)
107: in
108:
109: function
110: | GPragma (Attr ("cilnoremove" as directive, args), location) ->
111: (* a very flexible pragma: can retain typedefs, enums,
112: * structs, unions, or globals (functions or variables) *)
113: begin
114: let processArg arg =
115: try
116: match arg with
117: | AStr specifier ->
118: (* isolate and categorize one symbol name *)
119: let collection, name =
120: (* Two words denotes a typedef, enum, struct, or
121: * union, as in "type foo" or "enum bar". A
122: * single word denotes a global function or
123: * variable. *)
124: let whitespace = Str.regexp "[ \t]+" in
125: let words = Str.split whitespace specifier in
126: match words with
127: | ["type"; name] ->
128: keepers.typedefs, name
129: | ["enum"; name] ->
130: keepers.enums, name
131: | ["struct"; name] ->
132: keepers.structs, name
133: | ["union"; name] ->
134: keepers.unions, name
135: | [name] ->
136: keepers.defines, name
137: | _ ->
138: raise Bad_pragma
139: in
140: H.add collection name ()
141: | _ ->
142: raise Bad_pragma
143: with Bad_pragma ->
144: badPragma location directive
145: in
146: List.iter processArg args
147: end
148:
149: (*** Begin CCured-specific checks: ***)
150: (* these pragmas indirectly require that we keep the function named in
151: -- the first arguments of boxmodelof and ccuredwrapperof, and
152: -- the third argument of ccureddeepcopy*. *)
153: | GPragma (Attr("ccuredwrapper" as directive, attribute :: _), location) ->
154: begin
155: match attribute with
156: | AStr name ->
157: H.add keepers.defines name ()
158: | _ ->
159: badPragma location directive
160: end
161: | GPragma (Attr("ccuredvararg" as directive, funcname :: (ASizeOf t) :: _), location) ->
162: begin
163: match t with
164: | TComp(c,_) when c.cstruct -> (* struct *)
165: H.add keepers.structs c.cname ()
166: | TComp(c,_) -> (* union *)
167: H.add keepers.unions c.cname ()
168: | TNamed(ti,_) ->
169: H.add keepers.typedefs ti.tname ()
170: | TEnum(ei, _) ->
171: H.add keepers.enums ei.ename ()
172: | _ ->
173: ()
174: end
175: | GPragma (Attr(directive, _ :: _ :: attribute :: _), location)
176: when String.length directive > ccureddeepcopystring_length
177: && (Str.first_chars directive ccureddeepcopystring_length)
178: = ccureddeepcopystring ->
179: begin
180: match attribute with
181: | AStr name ->
182: H.add keepers.defines name ()
183: | _ ->
184: badPragma location directive
185: end
186: (** end CCured-specific stuff **)
187: | _ ->
188: ()
189: in
190: iterGlobals file considerPragma;
191: keepers
192:
193:
194:
195: (***********************************************************************
196: *
197: * Function body elimination from pragmas
198: *
199: *)
200:
201:
202: (* When performing global slicing, any functions not explicitly marked
203: * as pragma roots are reduced to mere declarations. This leaves one
204: * with a reduced source file that still compiles to object code, but
205: * which contains the bodies of only explicitly retained functions.
206: *)
207:
208: let amputateFunctionBodies keptGlobals file =
209: let considerGlobal = function
210: | GFun ({svar = {vname = name} as info}, location)
211: when not (H.mem keptGlobals name) ->
212: trace (dprintf "slicing: reducing to prototype: function %s\n" name);
213: GVarDecl (info, location)
214: | other ->
215: other
216: in
217: mapGlobals file considerGlobal
218:
219:
220:
221: (***********************************************************************
222: *
223: * Root collection from pragmas
224: *
225: *)
226:
227:
228: let isPragmaRoot keepers = function
229: | GType ({tname = name} as info, _) ->
230: H.mem keepers.typedefs name
231: | GEnumTag ({ename = name} as info, _)
232: | GEnumTagDecl ({ename = name} as info, _) ->
233: H.mem keepers.enums name
234: | GCompTag ({cname = name; cstruct = structure} as info, _)
235: | GCompTagDecl ({cname = name; cstruct = structure} as info, _) ->
236: let collection = if structure then keepers.structs else keepers.unions in
237: H.mem collection name
238: | GVar ({vname = name} as info, _, _)
239: | GVarDecl ({vname = name} as info, _)
240: | GFun ({svar = {vname = name} as info}, _) ->
241: H.mem keepers.defines name
242: | _ ->
243: false
244:
245:
246:
247: (***********************************************************************
248: *
249: * Common root collecting utilities
250: *
251: *)
252:
253:
254: let traceRoot reason global =
255: trace (dprintf "root (%s): %a@!" reason d_shortglobal global);
256: true
257:
258:
259: let traceNonRoot reason global =
260: trace (dprintf "non-root (%s): %a@!" reason d_shortglobal global);
261: false
262:
263:
264: let hasExportingAttribute funvar =
265: let rec isExportingAttribute = function
266: | Attr ("constructor", []) -> true
267: | Attr ("destructor", []) -> true
268: | _ -> false
269: in
270: List.exists isExportingAttribute funvar.vattr
271:
272:
273:
274: (***********************************************************************
275: *
276: * Root collection from external linkage
277: *
278: *)
279:
280:
281: (* Exported roots are those global symbols which are visible to the
282: * linker and dynamic loader. For variables, this consists of
283: * anything that is not "static". For functions, this consists of:
284: *
285: * - functions declared extern inline
286: * - functions declared neither inline nor static
287: * - functions bearing a "constructor" or "destructor" attribute
288: *)
289:
290: let isExportedRoot global =
291: let result = match global with
292: | GVar ({vstorage = storage}, _, _) as global
293: when storage != Static ->
294: true
295: | GFun ({svar = v} as fundec, _) as global ->
296: if hasExportingAttribute v then
297: true
298: else if v.vstorage = Extern then (* Keep all extern functions *)
299: true
300: else if v.vstorage = Static then (* Do not keep static functions *)
301: false
302: else if v.vinline then (* Do not keep inline functions, unless they
303: * are Extern also *)
304: false
305: else
306: true
307: | global ->
308: false
309: in
310: trace (dprintf "exported root -> %b for %a@!" result d_shortglobal global);
311: result
312:
313:
314:
315: (***********************************************************************
316: *
317: * Root collection for complete programs
318: *
319: *)
320:
321:
322: (* Exported roots are "main()" and functions bearing a "constructor"
323: * or "destructor" attribute. These are the only things which must be
324: * retained in a complete program.
325: *)
326:
327: let isCompleteProgramRoot global =
328: let result = match global with
329: | GFun ({svar = {vname = "main"; vstorage = vstorage} as info}, _) ->
330: vstorage <> Static
331: | GFun (fundec, _)
332: when hasExportingAttribute fundec.svar ->
333: true
334: | _ ->
335: false
336: in
337: trace (dprintf "complete program root -> %b for %a@!" result d_shortglobal global);
338: result
339:
340:
341: (***********************************************************************
342: *
343: * Transitive reachability closure from roots
344: *
345: *)
346:
347:
348: (* This visitor recursively marks all reachable types and variables as used. *)
349: class markReachableVisitor globalMap = object (self)
350: inherit nopCilVisitor
351:
352: method vglob = function
353: | GType (typeinfo, _) ->
354: typeinfo.treferenced <- true;
355: DoChildren
356: | GCompTag (compinfo, _)
357: | GCompTagDecl (compinfo, _) ->
358: compinfo.creferenced <- true;
359: DoChildren
360: | GEnumTag (enuminfo, _)
361: | GEnumTagDecl (enuminfo, _) ->
362: enuminfo.ereferenced <- true;
363: DoChildren
364: | GVar (varinfo, _, _)
365: | GVarDecl (varinfo, _)
366: | GFun ({svar = varinfo}, _) ->
367: varinfo.vreferenced <- true;
368: DoChildren
369: | _ ->
370: SkipChildren
371:
372: method vvrbl v =
373: if not v.vreferenced then
374: begin
375: let name = v.vname in
376: if v.vglob then
377: trace (dprintf "marking transitive use: global %s\n" name)
378: else
379: trace (dprintf "marking transitive use: local %s\n" name);
380:
381: (* If this is a global, we need to keep everything used in its
382: * definition and declarations. *)
383: if v.vglob then
384: begin
385: trace (dprintf "descending: global %s\n" name);
386: let descend global =
387: ignore (visitCilGlobal (self :> cilVisitor) global)
388: in
389: let globals = Hashtbl.find_all globalMap name in
390: List.iter descend globals
391: end
392: else
393: v.vreferenced <- true;
394: end;
395: SkipChildren
396:
397: method vtype typ =
398: let old : bool =
399: let visitAttrs attrs =
400: ignore (visitCilAttributes (self :> cilVisitor) attrs)
401: in
402: let visitType typ =
403: ignore (visitCilType (self :> cilVisitor) typ)
404: in
405: match typ with
406: | TEnum(e, attrs) ->
407: let old = e.ereferenced in
408: if not old then
409: begin
410: trace (dprintf "marking transitive use: enum %s\n" e.ename);
411: e.ereferenced <- true;
412: visitAttrs attrs;
413: visitAttrs e.eattr
414: end;
415: old
416:
417: | TComp(c, attrs) ->
418: let old = c.creferenced in
419: if not old then
420: begin
421: trace (dprintf "marking transitive use: compound %s\n" c.cname);
422: c.creferenced <- true;
423:
424: (* to recurse, we must ask explicitly *)
425: let recurse f = visitType f.ftype in
426: List.iter recurse c.cfields;
427: visitAttrs attrs;
428: visitAttrs c.cattr
429: end;
430: old
431:
432: | TNamed(ti, attrs) ->
433: let old = ti.treferenced in
434: if not old then
435: begin
436: trace (dprintf "marking transitive use: typedef %s\n" ti.tname);
437: ti.treferenced <- true;
438:
439: (* recurse deeper into the type referred-to by the typedef *)
440: (* to recurse, we must ask explicitly *)
441: visitType ti.ttype;
442: visitAttrs attrs
443: end;
444: old
445:
446: | _ ->
447: (* for anything else, just look inside it *)
448: false
449: in
450: if old then
451: SkipChildren
452: else
453: DoChildren
454: end
455:
456:
457: let markReachable file isRoot =
458: (* build a mapping from global names back to their definitions & declarations *)
459: let globalMap = Hashtbl.create 137 in
460: let considerGlobal global =
461: match global with
462: | GFun ({svar = info}, _)
463: | GVar (info, _, _)
464: | GVarDecl (info, _) ->
465: Hashtbl.add globalMap info.vname global
466: | _ ->
467: ()
468: in
469: iterGlobals file considerGlobal;
470:
471: (* mark everything reachable from the global roots *)
472: let visitor = new markReachableVisitor globalMap in
473: let visitIfRoot global =
474: if isRoot global then
475: begin
476: trace (dprintf "traversing root global: %a\n" d_shortglobal global);
477: ignore (visitCilGlobal visitor global)
478: end
479: else
480: trace (dprintf "skipping non-root global: %a\n" d_shortglobal global)
481: in
482: iterGlobals file visitIfRoot
483:
484:
485: (**********************************************************************
486: *
487: * Marking and removing of unused labels
488: *
489: **********************************************************************)
490:
491: (* We keep only one label, preferably one that was not introduced by CIL.
492: * Scan a list of labels and return the data for the label that should be
493: * kept, and the remaining filtered list of labels *)
494: let labelsToKeep (ll: label list) : (string * location * bool) * label list =
495: let rec loop (sofar: string * location * bool) = function
496: [] -> sofar, []
497: | l :: rest ->
498: let newlabel, keepl =
499: match l with
500: | Case _ | Default _ -> sofar, true
501: | Label (ln, lloc, isorig) -> begin
502: match isorig, sofar with
503: | false, ("", _, _) ->
504: (* keep this one only if we have no label so far *)
505: (ln, lloc, isorig), false
506: | false, _ -> sofar, false
507: | true, (_, _, false) ->
508: (* this is an original label; prefer it to temporary or
509: * missing labels *)
510: (ln, lloc, isorig), false
511: | true, _ -> sofar, false
512: end
513: in
514: let newlabel', rest' = loop newlabel rest in
515: newlabel', (if keepl then l :: rest' else rest')
516: in
517: loop ("", locUnknown, false) ll
518:
519: class markUsedLabels (labelMap: (string, unit) H.t) = object
520: inherit nopCilVisitor
521:
522: method vstmt (s: stmt) =
523: match s.skind with
524: Goto (dest, _) ->
525: let (ln, _, _), _ = labelsToKeep !dest.labels in
526: if ln = "" then
527: E.s (E.bug "rmtmps: destination of statement does not have labels");
528: (* Mark it as used *)
529: H.replace labelMap ln ();
530: DoChildren
531:
532: | _ -> DoChildren
533:
534: (* No need to go into expressions or instructions *)
535: method vexpr _ = SkipChildren
536: method vinst _ = SkipChildren
537: method vtype _ = SkipChildren
538: end
539:
540: class removeUnusedLabels (labelMap: (string, unit) H.t) = object
541: inherit nopCilVisitor
542:
543: method vstmt (s: stmt) =
544: let (ln, lloc, lorig), lrest = labelsToKeep s.labels in
545: s.labels <-
546: (if ln <> "" && H.mem labelMap ln then (* We had labels *)
547: (Label(ln, lloc, lorig) :: lrest)
548: else
549: lrest);
550: DoChildren
551:
552: (* No need to go into expressions or instructions *)
553: method vexpr _ = SkipChildren
554: method vinst _ = SkipChildren
555: method vtype _ = SkipChildren
556: end
557:
558: (***********************************************************************
559: *
560: * Removal of unused symbols
561: *
562: *)
563:
564:
565: (* regular expression matching names of uninteresting locals *)
566: let uninteresting =
567: let names = [
568: (* Flx_cil_cil.makeTempVar *)
569: "__cil_tmp";
570:
571: (* sm: I don't know where it comes from but these show up all over. *)
572: (* this doesn't seem to do what I wanted.. *)
573: "iter";
574:
575: (* various macros in glibc's <bits/string2.h> *)
576: "__result";
577: "__s"; "__s1"; "__s2";
578: "__s1_len"; "__s2_len";
579: "__retval"; "__len";
580:
581: (* various macros in glibc's <ctype.h> *)
582: "__c"; "__res";
583:
584: (* We remove the __malloc variables *)
585: ] in
586:
587: (* optional alpha renaming *)
588: let alpha = "\\(___[0-9]+\\)?" in
589:
590: let pattern = "\\(" ^ (String.concat "\\|" names) ^ "\\)" ^ alpha ^ "$" in
591: Str.regexp pattern
592:
593:
594: let removeUnmarked file =
595: let removedLocals = ref [] in
596:
597: let filterGlobal global =
598: match global with
599: (* unused global types, variables, and functions are simply removed *)
600: | GType ({treferenced = false}, _)
601: | GCompTag ({creferenced = false}, _)
602: | GCompTagDecl ({creferenced = false}, _)
603: | GEnumTag ({ereferenced = false}, _)
604: | GEnumTagDecl ({ereferenced = false}, _)
605: | GVar ({vreferenced = false}, _, _)
606: | GVarDecl ({vreferenced = false}, _)
607: | GFun ({svar = {vreferenced = false}}, _) ->
608: trace (dprintf "removing global: %a\n" d_shortglobal global);
609: false
610:
611: (* retained functions may wish to discard some unused locals *)
612: | GFun (func, _) ->
613: let rec filterLocal local =
614: if not local.vreferenced then
615: begin
616: (* along the way, record the interesting locals that were removed *)
617: let name = local.vname in
618: trace (dprintf "removing local: %s\n" name);
619: if not (Str.string_match uninteresting name 0) then
620: removedLocals := (func.svar.vname ^ "::" ^ name) :: !removedLocals;
621: end;
622: local.vreferenced
623: in
624: func.slocals <- List.filter filterLocal func.slocals;
625: (* We also want to remove unused labels. We do it all here, including
626: * marking the used labels *)
627: let usedLabels:(string, unit) H.t = H.create 13 in
628: ignore (visitCilBlock (new markUsedLabels usedLabels) func.sbody);
629: (* And now we scan again and we remove them *)
630: ignore (visitCilBlock (new removeUnusedLabels usedLabels) func.sbody);
631: true
632:
633: (* all other globals are retained *)
634: | _ ->
635: trace (dprintf "keeping global: %a\n" d_shortglobal global);
636: true
637: in
638: file.globals <- List.filter filterGlobal file.globals;
639: !removedLocals
640:
641:
642: (***********************************************************************
643: *
644: * Exported interface
645: *
646: *)
647:
648:
649: type rootsFilter = global -> bool
650:
651: let isDefaultRoot = isExportedRoot
652:
653:
654: let keepUnused = ref false
655:
656: let rec removeUnusedTemps ?(isRoot : rootsFilter = isDefaultRoot) file =
657: if !keepUnused || Flx_cil_trace.traceActive "disableTmpRemoval" then
658: Flx_cil_trace.trace "disableTmpRemoval" (dprintf "temp removal disabled\n")
659: else
660: begin
661: if !E.verboseFlag then
662: ignore (E.log "Removing unused temporaries\n" );
663:
664: if Flx_cil_trace.traceActive "printCilTree" then
665: dumpFile defaultCilPrinter stdout file;
666:
667: (* digest any pragmas that would create additional roots *)
668: let keepers = categorizePragmas file in
669:
670: (* if slicing, remove the bodies of non-kept functions *)
671: if !Flx_cil_cilutil.sliceGlobal then
672: amputateFunctionBodies keepers.defines file;
673:
674: (* build up the root set *)
675: let isRoot global =
676: isPragmaRoot keepers global ||
677: isRoot global
678: in
679:
680: (* mark everything reachable from the global roots *)
681: clearReferencedBits file;
682: markReachable file isRoot;
683:
684: (* take out the trash *)
685: let removedLocals = removeUnmarked file in
686:
687: (* print which original source variables were removed *)
688: if false && removedLocals != [] then
689: let count = List.length removedLocals in
690: if count > 2000 then
691: ignore (E.warn "%d unused local variables removed" count)
692: else
693: ignore (E.warn "%d unused local variables removed:@!%a"
694: count (docList (chr ',' ++ break) text) removedLocals)
695: end
Start ocaml section to src/flx_cil_rmtmps.mli[1
/1
]
1: # 14124 "./lpsrc/flx_cil.ipk"
2:
3: (* rmtmps.mli *)
4: (* remove unused things from cil files: *)
5: (* - local temporaries introduced but not used *)
6: (* - global declarations that are not used *)
7: (* - types that are not used *)
8: (* - labels that are not used (gn) *)
9:
10:
11: (* Some clients may wish to augment or replace the standard strategy
12: * for finding the initially reachable roots. The optional
13: * "isRoot" argument to Flx_cil_rmtmps.removeUnusedTemps grants this
14: * flexibility. If given, it should name a function which will return
15: * true if a given global should be treated as a retained root.
16: *
17: * Function Flx_cil_rmtmps.isDefaultRoot encapsulates the default root
18: * collection, which consists of those global variables and functions
19: * which are visible to the linker and runtime loader. A client's
20: * root filter can use this if the goal is to augment rather than
21: * replace the standard logic. Function Flx_cil_rmtmps.isExportedRoot is an
22: * alternate name for this same function.
23: *
24: * Function Flx_cil_rmtmps.isCompleteProgramRoot is an example of an alternate
25: * root collection. This function assumes that it is operating on a
26: * complete program rather than just one object file. It treats
27: * "main()" as a root, as well as any function carrying the
28: * "constructor" or "destructor" attribute. All other globals are
29: * candidates for removal, regardless of their linkage.
30: *
31: * Note that certain CIL- and CCured-specific pragmas induce
32: * additional global roots. This functionality is always present, and
33: * is not subject to replacement by "filterRoots".
34: *)
35:
36: type rootsFilter = Flx_cil_cil.global -> bool
37: val isDefaultRoot : rootsFilter
38: val isExportedRoot : rootsFilter
39: val isCompleteProgramRoot : rootsFilter
40:
41: (* process a complete Flx_cil_cil file *)
42: val removeUnusedTemps: ?isRoot:rootsFilter -> Flx_cil_cil.file -> unit
43:
44:
45: val keepUnused: bool ref (* Set this to true to turn off this module *)
46:
Start ocaml section to src/flx_cil_cabs2cil.ml[1
/1
]
1: # 14171 "./lpsrc/flx_cil.ipk"
2: (* Type check and elaborate ABS to CIL *)
3:
4: (* The references to ISO means ANSI/ISO 9899-1999 *)
5: module A = Flx_cil_cabs
6: module E = Flx_cil_errormsg
7: module H = Hashtbl
8:
9: open Flx_cil_cabs
10: open Flx_cil_cabs_helper
11: open Flx_cil_pretty
12: open Flx_cil_cil
13: open Flx_cil_trace
14:
15:
16: let debugGlobal = false
17:
18: (* Leave a certain global alone. Use a negative number to disable. *)
19: let nocil: int ref = ref (-1)
20:
21: (* Indicates whether we're allowed to duplicate small chunks. *)
22: let allowDuplication: bool ref = ref true
23:
24: (* ---------- source error message handling ------------- *)
25: let lu = locUnknown
26: let cabslu = {lineno = -10; filename = "cabs lu"; byteno = -10;}
27:
28:
29: (** Interface to the Flx_cil_cprint printer *)
30: let withFlx_cil_cprint (f: 'a -> unit) (x: 'a) : unit =
31: Flx_cil_cprint.commit (); Flx_cil_cprint.flush ();
32: let old = !Flx_cil_cprint.out in
33: Flx_cil_cprint.out := !E.logChannel;
34: f x;
35: Flx_cil_cprint.commit (); Flx_cil_cprint.flush ();
36: flush !Flx_cil_cprint.out;
37: Flx_cil_cprint.out := old
38:
39:
40: (* Keep a list of functions that were called without a prototype. *)
41: let noProtoFunctions : (int, bool) H.t = H.create 13
42:
43: (* Flx_cil_check that s starts with the prefix p *)
44: let prefix p s =
45: let lp = String.length p in
46: let ls = String.length s in
47: lp <= ls && String.sub s 0 lp = p
48:
49: (***** COMPUTED GOTO ************)
50:
51: (* The address of labels are small integers (starting from 0). A computed
52: * goto is replaced with a switch on the address of the label. We generate
53: * only one such switch and we'll jump to it from all computed gotos. To
54: * accomplish this we'll add a local variable to store the target of the
55: * goto. *)
56:
57: (* The local variable in which to put the detination of the goto and the
58: * statement where to jump *)
59: let gotoTargetData: (varinfo * stmt) option ref = ref None
60:
61: (* The "addresses" of labels *)
62: let gotoTargetHash: (string, int) H.t = H.create 13
63: let gotoTargetNextAddr: int ref = ref 0
64:
65:
66: (********** TRANSPARENT UNION ******)
67: (* Flx_cil_check if a type is a transparent union, and return the first field if it
68: * is *)
69: let isTransparentUnion (t: typ) : fieldinfo option =
70: match unrollType t with
71: TComp (comp, _) when not comp.cstruct ->
72: (* Turn transparent unions into the type of their first field *)
73: if hasAttribute "transparent_union" (typeAttrs t) then begin
74: match comp.cfields with
75: f :: _ -> Some f
76: | _ -> E.s (unimp "Empty transparent union: %s" (compFullName comp))
77: end else
78: None
79: | _ -> None
80:
81: (* When we process an argument list, remember the argument index which has a
82: * transparent union type, along with the original type. We need this to
83: * process function definitions *)
84: let transparentUnionArgs : (int * typ) list ref = ref []
85:
86: let debugLoc = false
87: let convLoc (l : cabsloc) =
88: if debugLoc then
89: ignore (E.log "convLoc at %s: line %d, btye %d\n" l.filename l.lineno l.byteno);
90: {line = l.lineno; file = l.filename; byte = l.byteno}
91:
92:
93: let isOldStyleVarArgName n =
94: if !msvcMode then n = "va_alist"
95: else n = "__builtin_va_alist"
96:
97: let isOldStyleVarArgTypeName n =
98: if !msvcMode then n = "va_list" || n = "__ccured_va_list"
99: else n = "__builtin_va_alist_t"
100:
101: (* Weimer
102: * multi-character character constants
103: * In MSCV, this code works:
104: *
105: * long l1 = 'abcd'; // note single quotes
106: * char * s = "dcba";
107: * long * lptr = ( long * )s;
108: * long l2 = *lptr;
109: * assert(l1 == l2);
110: *
111: * We need to change a multi-character character literal into the
112: * appropriate integer constant. However, the plot sickens: we
113: * must also be able to handle things like 'ab\nd' (value = * "d\nba")
114: * and 'abc' (vale = *"cba").
115: *
116: * First we convert 'AB\nD' into the list [ 65 ; 66 ; 10 ; 68 ], then we
117: * multiply and add to get the desired value.
118: *)
119:
120: (* Given a character constant (like 'a' or 'abc') as a list of 64-bit
121: * values, turn it into a CIL constant. Multi-character constants are
122: * treated as multi-digit numbers with radix given by the bit width of
123: * the specified type (either char or wchar_t). *)
124: let reduce_multichar typ =
125: let radix = bitsSizeOf typ in
126: List.fold_left
127: (fun acc -> Int64.add (Int64.shift_left acc 8))
128: Int64.zero
129:
130: let interpret_character_constant char_list =
131: let value = reduce_multichar charType char_list in
132: if value < (Int64.of_int 256) then
133: (CChr(Char.chr (Int64.to_int value))),(TInt(IChar,[]))
134: else begin
135: let orig_rep = None (* Some("'" ^ (String.escaped str) ^ "'") *) in
136: if value < (Int64.of_int 65536) then
137: (CInt64(value,IUShort,orig_rep)),(TInt(IUShort,[]))
138: else if value <= (Int64.of_int32 Int32.max_int) then
139: (CInt64(value,IULong,orig_rep)),(TInt(IULong,[]))
140: else
141: (CInt64(value,IULongLong,orig_rep)),(TInt(IULongLong,[]))
142: end
143:
144: (*** EXPRESSIONS *************)
145:
146: (* We collect here the program *)
147: let theFile : global list ref = ref []
148: let theFileTypes : global list ref = ref []
149:
150: let initGlobals () = theFile := []; theFileTypes := []
151:
152:
153: let cabsPushGlobal (g: global) =
154: pushGlobal g ~types:theFileTypes ~variables:theFile
155:
156: (* Keep track of some variable ids that must be turned into definitions. We
157: * do this when we encounter what appears a definition of a global but
158: * without initializer. We leave it a declaration because maybe down the road
159: * we see another definition with an initializer. But if we don't see any
160: * then we turn the last such declaration into a definition without
161: * initializer *)
162: let mustTurnIntoDef: (int, bool) H.t = H.create 117
163:
164: (* Globals that have already been defined. Indexed by the variable name. *)
165: let alreadyDefined: (string, location) H.t = H.create 117
166:
167: (* Globals that were created due to static local variables. We chose their
168: * names to be distinct from any global encountered at the time. But we might
169: * see a global with conflicting name later in the file. *)
170: let staticLocals: (string, varinfo) H.t = H.create 13
171:
172:
173: (* Typedefs. We chose their names to be distinct from any global encounterd
174: * at the time. But we might see a global with conflicting name later in the
175: * file *)
176: let typedefs: (string, typeinfo) H.t = H.create 13
177:
178: let popGlobals () =
179: let rec revonto (tail: global list) = function
180: [] -> tail
181:
182: | GVarDecl (vi, l) :: rest
183: when vi.vstorage != Extern && H.mem mustTurnIntoDef vi.vid ->
184: H.remove mustTurnIntoDef vi.vid;
185: revonto (GVar (vi, {init = None}, l) :: tail) rest
186:
187: | x :: rest -> revonto (x :: tail) rest
188: in
189: revonto (revonto [] !theFile) !theFileTypes
190:
191:
192: (********* ENVIRONMENTS ***************)
193:
194: (* The environment is kept in two distinct data structures. A hash table maps
195: * each original variable name into a varinfo (for variables, or an
196: * enumeration tag, or a type). (Note that the varinfo might contain an
197: * alpha-converted name different from that of the lookup name.) The Ocaml
198: * hash tables can keep multiple mappings for a single key. Each time the
199: * last mapping is returned and upon deletion the old mapping is restored. To
200: * keep track of local scopes we also maintain a list of scopes (represented
201: * as lists). *)
202: type envdata =
203: EnvVar of varinfo (* The name refers to a variable
204: * (which could also be a function) *)
205: | EnvEnum of exp * typ (* The name refers to an enumeration
206: * tag for which we know the value
207: * and the host type *)
208: | EnvTyp of typ (* The name is of the form "struct
209: * foo", or "union foo" or "enum foo"
210: * and refers to a type. Note that
211: * the name of the actual type might
212: * be different from foo due to alpha
213: * conversion *)
214: | EnvLabel of string (* The name refers to a label. This
215: * is useful for GCC's locally
216: * declared labels. The lookup name
217: * for this category is "label foo" *)
218:
219: let env : (string, envdata * location) H.t = H.create 307
220: (* We also keep a global environment. This is always a subset of the env *)
221: let genv : (string, envdata * location) H.t = H.create 307
222:
223: (* In the scope we keep the original name, so we can remove them from the
224: * hash table easily *)
225: type undoScope =
226: UndoRemoveFromEnv of string
227: | UndoResetAlphaCounter of alphaTableData ref * alphaTableData
228: | UndoRemoveFromAlphaTable of string
229:
230: let scopes : undoScope list ref list ref = ref []
231:
232: let isAtTopLevel () =
233: !scopes = []
234:
235:
236: (* When you add to env, you also add it to the current scope *)
237: let addLocalToEnv (n: string) (d: envdata) =
238: (* ignore (E.log "%a: adding local %s to env\n" d_loc !currentLoc n); *)
239: H.add env n (d, !currentLoc);
240: (* If we are in a scope, then it means we are not at top level. Add the
241: * name to the scope *)
242: (match !scopes with
243: [] -> begin
244: match d with
245: EnvVar _ ->
246: E.s (E.bug "addLocalToEnv: not in a scope when adding %s!" n)
247: | _ -> () (* We might add types *)
248: end
249: | s :: _ ->
250: s := (UndoRemoveFromEnv n) :: !s)
251:
252:
253: let addGlobalToEnv (k: string) (d: envdata) : unit =
254: (* ignore (E.log "%a: adding global %s to env\n" d_loc !currentLoc k); *)
255: H.add env k (d, !currentLoc);
256: (* Also add it to the global environment *)
257: H.add genv k (d, !currentLoc)
258:
259:
260:
261: (* Create a new name based on a given name. The new name is formed from a
262: * prefix (obtained from the given name as the longest prefix that ends with
263: * a non-digit), followed by a '_' and then by a positive integer suffix. The
264: * first argument is a table mapping name prefixes with the largest suffix
265: * used so far for that prefix. The largest suffix is one when only the
266: * version without suffix has been used. *)
267: let alphaTable : (string, alphaTableData ref) H.t = H.create 307
268: (* vars and enum tags. For composite types we have names like "struct
269: * foo" or "union bar" *)
270:
271: (* To keep different name scopes different, we add prefixes to names
272: * specifying the kind of name: the kind can be one of "" for variables or
273: * enum tags, "struct" for structures and unions (they share the name space),
274: * "enum" for enumerations, or "type" for types *)
275: let kindPlusName (kind: string)
276: (origname: string) : string =
277: if kind = "" then origname else
278: kind ^ " " ^ origname
279:
280:
281: let stripKind (kind: string) (kindplusname: string) : string =
282: let l = 1 + String.length kind in
283: if l > 1 then
284: String.sub kindplusname l (String.length kindplusname - l)
285: else
286: kindplusname
287:
288: let newAlphaName (globalscope: bool) (* The name should have global scope *)
289: (kind: string)
290: (origname: string) : string * location =
291: let lookupname = kindPlusName kind origname in
292: (* If we are in a scope then it means that we are alpha-converting a local
293: * name. Go and add stuff to reset the state of the alpha table but only to
294: * the top-most scope (that of the enclosing function) *)
295: let rec findEnclosingFun = function
296: [] -> (* At global scope *)()
297: | [s] -> begin
298: let prefix = getAlphaPrefix lookupname in
299: try
300: let countref = H.find alphaTable prefix in
301: s := (UndoResetAlphaCounter (countref, !countref)) :: !s
302: with Not_found ->
303: s := (UndoRemoveFromAlphaTable prefix) :: !s
304: end
305: | _ :: rest -> findEnclosingFun rest
306: in
307: if not globalscope then
308: findEnclosingFun !scopes;
309: let newname, oldloc = Flx_cil_cil.newAlphaName alphaTable None lookupname in
310: stripKind kind newname, oldloc
311:
312:
313:
314:
315: let explodeString (nullterm: bool) (s: string) : char list =
316: let rec allChars i acc =
317: if i < 0 then acc
318: else allChars (i - 1) ((String.get s i) :: acc)
319: in
320: allChars (-1 + String.length s)
321: (if nullterm then [Char.chr 0] else [])
322:
323: (*** In order to process GNU_BODY expressions we must record that a given
324: *** COMPUTATION is interesting *)
325: let gnu_body_result : (A.statement * ((exp * typ) option ref)) ref
326: = ref (A.NOP cabslu, ref None)
327:
328: (*** When we do statements we need to know the current return type *)
329: let currentReturnType : typ ref = ref (TVoid([]))
330: let currentFunctionFDEC: fundec ref = ref dummyFunDec
331:
332:
333: let lastStructId = ref 0
334: let anonStructName (k: string) (suggested: string) =
335: incr lastStructId;
336: "__anon" ^ k ^ (if suggested <> "" then "_" ^ suggested else "")
337: ^ "_" ^ (string_of_int (!lastStructId))
338:
339:
340: let constrExprId = ref 0
341:
342:
343: let startFile () =
344: H.clear env;
345: H.clear genv;
346: H.clear alphaTable;
347: lastStructId := 0
348:
349:
350:
351: let enterScope () =
352: scopes := (ref []) :: !scopes
353:
354: (* Exit a scope and clean the environment. We do not yet delete from
355: * the name table *)
356: let exitScope () =
357: let this, rest =
358: match !scopes with
359: car :: cdr -> car, cdr
360: | [] -> E.s (error "Not in a scope")
361: in
362: scopes := rest;
363: let rec loop = function
364: [] -> ()
365: | UndoRemoveFromEnv n :: t ->
366: H.remove env n; loop t
367: | UndoRemoveFromAlphaTable n :: t -> H.remove alphaTable n; loop t
368: | UndoResetAlphaCounter (vref, oldv) :: t ->
369: vref := oldv;
370: loop t
371: in
372: loop !this
373:
374: (* Lookup a variable name. Return also the location of the definition. Might
375: * raise Not_found *)
376: let lookupVar (n: string) : varinfo * location =
377: match H.find env n with
378: (EnvVar vi), loc -> vi, loc
379: | _ -> raise Not_found
380:
381: let lookupGlobalVar (n: string) : varinfo * location =
382: match H.find genv n with
383: (EnvVar vi), loc -> vi, loc
384: | _ -> raise Not_found
385:
386: let docEnv () =
387: let acc : (string * (envdata * location)) list ref = ref [] in
388: let doone () = function
389: EnvVar vi, l ->
390: dprintf "Var(%s,global=%b) (at %a)" vi.vname vi.vglob d_loc l
391: | EnvEnum (tag, typ), l -> dprintf "Enum (at %a)" d_loc l
392: | EnvTyp t, l -> text "typ"
393: | EnvLabel l, _ -> text ("label " ^ l)
394: in
395: H.iter (fun k d -> acc := (k, d) :: !acc) env;
396: docList line (fun (k, d) -> dprintf " %s -> %a" k doone d) () !acc
397:
398:
399:
400: (* Add a new variable. Do alpha-conversion if necessary *)
401: let alphaConvertVarAndAddToEnv (addtoenv: bool) (vi: varinfo) : varinfo =
402: (*
403: ignore (E.log "%t: alphaConvert(addtoenv=%b) %s" d_thisloc addtoenv vi.vname);
404: *)
405: (* Announce the name to the alpha conversion table *)
406: let newname, oldloc = newAlphaName (addtoenv && vi.vglob) "" vi.vname in
407: (* Make a copy of the vi if the name has changed. Never change the name for
408: * global variables *)
409: let newvi =
410: if vi.vname = newname then
411: vi
412: else begin
413: if vi.vglob then begin
414: (* Perhaps this is because we have seen a static local which happened
415: * to get the name that we later want to use for a global. *)
416: try
417: let static_local_vi = H.find staticLocals vi.vname in
418: H.remove staticLocals vi.vname;
419: (* Use the new name for the static local *)
420: static_local_vi.vname <- newname;
421: (* And continue using the last one *)
422: vi
423: with Not_found -> begin
424: (* Or perhaps we have seen a typedef which stole our name. This is
425: possible because typedefs use the same name space *)
426: try
427: let typedef_ti = H.find typedefs vi.vname in
428: H.remove typedefs vi.vname;
429: (* Use the new name for the typedef instead *)
430: typedef_ti.tname <- newname;
431: (* And continue using the last name *)
432: vi
433: with Not_found ->
434: E.s (E.error "It seems that we would need to rename global %s (to %s) because of previous occurrence at %a"
435: vi.vname newname d_loc oldloc);
436: end
437: end else
438: copyVarinfo vi newname
439: end
440: in
441: (* Store all locals in the slocals (in reversed order). We'll reverse them
442: * and take out the formals at the end of the function *)
443: if not vi.vglob then
444: !currentFunctionFDEC.slocals <- newvi :: !currentFunctionFDEC.slocals;
445:
446: (if addtoenv then
447: if vi.vglob then
448: addGlobalToEnv vi.vname (EnvVar newvi)
449: else
450: addLocalToEnv vi.vname (EnvVar newvi));
451: (*
452: ignore (E.log " new=%s\n" newvi.vname);
453: *)
454: (* ignore (E.log "After adding %s alpha table is: %a\n"
455: newvi.vname docAlphaTable alphaTable); *)
456: newvi
457:
458:
459: (* Strip the "const" from the type. It is unfortunate that const variables
460: * can only be set in initialization. Once we decided to move all
461: * declarations to the top of the functions, we have no way of setting a
462: * "const" variable. Furthermore, if the type of the variable is an array or
463: * a struct we must recursively strip the "const" from fields and array
464: * elements. *)
465: let rec stripConstLocalType (t: typ) : typ =
466: let dc a =
467: if hasAttribute "const" a then
468: dropAttribute "const" a
469: else a
470: in
471: match t with
472: | TPtr (bt, a) ->
473: (* We want to be able to detect by pointer equality if the type has
474: * changed. So, don't realloc the type unless necessary. *)
475: let a' = dc a in if a != a' then TPtr(bt, a') else t
476: | TInt (ik, a) ->
477: let a' = dc a in if a != a' then TInt(ik, a') else t
478: | TFloat(fk, a) ->
479: let a' = dc a in if a != a' then TFloat(fk, a') else t
480: | TNamed (ti, a) ->
481: (* We must go and drop the consts from the typeinfo as well ! *)
482: let t' = stripConstLocalType ti.ttype in
483: if t != t' then begin
484: (* ignore (warn "Stripping \"const\" from typedef %s\n" ti.tname); *)
485: ti.ttype <- t'
486: end;
487: let a' = dc a in if a != a' then TNamed(ti, a') else t
488:
489: | TEnum (ei, a) ->
490: let a' = dc a in if a != a' then TEnum(ei, a') else t
491:
492: | TArray(bt, leno, a) ->
493: (* We never assign to the array. So, no need to change the const. But
494: * we must change it on the base type *)
495: let bt' = stripConstLocalType bt in
496: if bt' != bt then TArray(bt', leno, a) else t
497:
498: | TComp(ci, a) -> (* Again, no need to change the a. But we must change the
499: * fields. *)
500: List.iter
501: (fun f ->
502: let t' = stripConstLocalType f.ftype in
503: if t' != f.ftype then begin
504: ignore (warnOpt "Stripping \"const\" from field %s of %s\n"
505: f.fname (compFullName ci));
506: f.ftype <- t'
507: end)
508: ci.cfields;
509: t
510:
511: (* We never assign functions either *)
512: | TFun(rt, args, va, a) -> t
513: | TVoid _ -> E.s (bug "cabs2cil: stripConstLocalType: void")
514: | TBuiltin_va_list a ->
515: let a' = dc a in if a != a' then TBuiltin_va_list a' else t
516:
517:
518:
519:
520: (* Create a new temporary variable *)
521: let newTempVar typ =
522: let stripConst t =
523: let a = typeAttrs t in
524: let a1 = dropAttribute "const" a in
525: setTypeAttrs t a1
526: in
527: if !currentFunctionFDEC == dummyFunDec then
528: E.s (bug "newTempVar called outside a function");
529: (* ignore (E.log "stripConstLocalType(%a) for temporary\n" d_type typ); *)
530: let t' = stripConstLocalType typ in
531: (* Start with the name "tmp". The alpha converter will fix it *)
532: let vi = makeVarinfo false "tmp" t' in
533: alphaConvertVarAndAddToEnv false vi (* Do not add to the environment *)
534: (*
535: { vname = "tmp"; (* addNewVar will make the name fresh *)
536: vid = newVarId "tmp" false;
537: vglob = false;
538: vtype = t';
539: vdecl = locUnknown;
540: vinline = false;
541: vattr = [];
542: vaddrof = false;
543: vreferenced = false; (* sm *)
544: vstorage = NoStorage;
545: }
546: *)
547:
548: let mkAddrOfAndMark ((b, off) as lval) : exp =
549: (* Mark the vaddrof flag if b is a variable *)
550: (match b with
551: Var vi -> vi.vaddrof <- true
552: | _ -> ());
553: mkAddrOf lval
554:
555: (* Call only on arrays *)
556: let mkStartOfAndMark ((b, off) as lval) : exp =
557: (* Mark the vaddrof flag if b is a variable *)
558: (match b with
559: Var vi -> vi.vaddrof <- true
560: | _ -> ());
561: let res = StartOf lval in
562: res
563:
564:
565:
566: (* Keep a set of self compinfo for composite types *)
567: let compInfoNameEnv : (string, compinfo) H.t = H.create 113
568: let enumInfoNameEnv : (string, enuminfo) H.t = H.create 113
569:
570:
571: let lookupTypeNoError (kind: string)
572: (n: string) : typ * location =
573: let kn = kindPlusName kind n in
574: match H.find env kn with
575: EnvTyp t, l -> t, l
576: | _ -> raise Not_found
577:
578: let lookupType (kind: string)
579: (n: string) : typ * location =
580: try
581: lookupTypeNoError kind n
582: with Not_found ->
583: E.s (error "Cannot find type %s (kind:%s)\n" n kind)
584:
585: (* Create the self ref cell and add it to the map. Return also an indication
586: * if this is a new one. *)
587: let createCompInfo (iss: bool) (n: string) : compinfo * bool =
588: (* Add to the self cell set *)
589: let key = (if iss then "struct " else "union ") ^ n in
590: try
591: H.find compInfoNameEnv key, false (* Only if not already in *)
592: with Not_found -> begin
593: (* Create a compinfo. This will have "cdefined" false. *)
594: let res = mkCompInfo iss n (fun _ -> []) [] in
595: H.add compInfoNameEnv key res;
596: res, true
597: end
598:
599: (* Create the self ref cell and add it to the map. Return an indication
600: * whether this is a new one. *)
601: let createEnumInfo (n: string) : enuminfo * bool =
602: (* Add to the self cell set *)
603: try
604: H.find enumInfoNameEnv n, false (* Only if not already in *)
605: with Not_found -> begin
606: (* Create a enuminfo *)
607: let enum = { ename = n; eitems = [];
608: eattr = []; ereferenced = false; } in
609: H.add enumInfoNameEnv n enum;
610: enum, true
611: end
612:
613:
614: (* kind is either "struct" or "union" or "enum" and n is a name *)
615: let findCompType kind n a =
616: let key = kind ^ " " ^ n in
617: let makeForward () =
618: (* This is a forward reference, either because we have not seen this
619: * struct already or because we want to create a version with different
620: * attributes *)
621: if kind = "enum" then
622: let enum, isnew = createEnumInfo n in
623: if isnew then
624: cabsPushGlobal (GEnumTagDecl (enum, !currentLoc));
625: TEnum (enum, a)
626: else
627: let iss = if kind = "struct" then true else false in
628: let self, isnew = createCompInfo iss n in
629: if isnew then
630: cabsPushGlobal (GCompTagDecl (self, !currentLoc));
631: TComp (self, a)
632: in
633: try
634: let old, _ = lookupTypeNoError kind n in (* already defined *)
635: let olda = typeAttrs old in
636: if olda = a then old else makeForward ()
637: with Not_found -> makeForward ()
638:
639:
640: (* A simple visitor that searchs a statement for labels *)
641: class canDropStmtClass pRes = object
642: inherit nopCilVisitor
643:
644: method vstmt s =
645: if s.labels != [] then
646: (pRes := false; SkipChildren)
647: else
648: if !pRes then DoChildren else SkipChildren
649:
650: method vinst _ = SkipChildren
651: method vexpr _ = SkipChildren
652:
653: end
654: let canDropStatement (s: stmt) : bool =
655: let pRes = ref true in
656: let vis = new canDropStmtClass pRes in
657: ignore (visitCilStmt vis s);
658: !pRes
659:
660: (**** Occasionally we see structs with no name and no fields *)
661:
662:
663: module BlockChunk =
664: struct
665: type chunk = {
666: stmts: stmt list;
667: postins: instr list; (* Some instructions to append at
668: * the ends of statements (in
669: * reverse order) *)
670: (* A list of case statements visible at the
671: * outer level *)
672: cases: (label * stmt) list
673: }
674:
675: let empty =
676: { stmts = []; postins = []; cases = []; }
677:
678: let isEmpty (c: chunk) =
679: c.postins == [] && c.stmts == []
680:
681: let isNotEmpty (c: chunk) = not (isEmpty c)
682:
683: let i2c (i: instr) =
684: { empty with postins = [i] }
685:
686: (* Occasionally, we'll have to push postins into the statements *)
687: let pushPostIns (c: chunk) : stmt list =
688: if c.postins = [] then c.stmts
689: else
690: let rec toLast = function
691: [{skind=Instr il} as s] as stmts ->
692: s.skind <- Instr (il @ (List.rev c.postins));
693: stmts
694:
695: | [] -> [mkStmt (Instr (List.rev c.postins))]
696:
697: | a :: rest -> a :: toLast rest
698: in
699: compactStmts (toLast c.stmts)
700:
701:
702: let c2block (c: chunk) : block =
703: { battrs = [];
704: bstmts = pushPostIns c;
705: }
706:
707: (* Add an instruction at the end. Never refer to this instruction again
708: * after you call this *)
709: let (+++) (c: chunk) (i : instr) =
710: {c with postins = i :: c.postins}
711:
712: (* Append two chunks. Never refer to the original chunks after you call
713: * this. And especially never share c2 with somebody else *)
714: let (@@) (c1: chunk) (c2: chunk) =
715: { stmts = compactStmts (pushPostIns c1 @ c2.stmts);
716: postins = c2.postins;
717: cases = c1.cases @ c2.cases;
718: }
719:
720: let skipChunk = empty
721:
722: let returnChunk (e: exp option) (l: location) : chunk =
723: { stmts = [ mkStmt (Return(e, l)) ];
724: postins = [];
725: cases = []
726: }
727:
728: let ifChunk (be: exp) (l: location) (t: chunk) (e: chunk) : chunk =
729:
730: { stmts = [ mkStmt(If(be, c2block t, c2block e, l))];
731: postins = [];
732: cases = t.cases @ e.cases;
733: }
734:
735: (* We can duplicate a chunk if it has a few simple statements, and if
736: * it does not have cases *)
737: let duplicateChunk (c: chunk) = (* raises Failure if you should not
738: * duplicate this chunk *)
739: if not !allowDuplication then
740: raise (Failure "cannot duplicate: disallowed by user");
741: if c.cases != [] then raise (Failure "cannot duplicate: has cases") else
742: let pCount = ref (List.length c.postins) in
743: { stmts =
744: List.map
745: (fun s ->
746: if s.labels != [] then
747: raise (Failure "cannot duplicate: has labels");
748: (match s.skind with
749: If _ | Switch _ | Loop _ | Block _ ->
750: raise (Failure "cannot duplicate: complex stmt")
751: | Instr il ->
752: pCount := !pCount + List.length il
753: | _ -> incr pCount);
754: if !pCount > 5 then raise (Failure ("cannot duplicate: too many instr"));
755: (* We can just copy it because there is nothing to share here.
756: * Except maybe for the ref cell in Goto but it is Ok to share
757: * that, I think *)
758: { s with sid = s.sid}) c.stmts;
759: postins = c.postins; (* There is no shared stuff in instructions *)
760: cases = []
761: }
762: (*
763: let duplicateChunk (c: chunk) =
764: if isEmpty c then c else raise (Failure ("cannot duplicate: isNotEmpty"))
765: *)
766: (* We can drop a chunk if it does not have labels inside *)
767: let canDrop (c: chunk) =
768: List.for_all canDropStatement c.stmts
769:
770: let loopChunk (body: chunk) : chunk =
771: (* Make the statement *)
772: let loop = mkStmt (Loop (c2block body, !currentLoc, None, None)) in
773: { stmts = [ loop (* ; n *) ];
774: postins = [];
775: cases = body.cases;
776: }
777:
778: let breakChunk (l: location) : chunk =
779: { stmts = [ mkStmt (Break l) ];
780: postins = [];
781: cases = [];
782: }
783:
784: let continueChunk (l: location) : chunk =
785: { stmts = [ mkStmt (Continue l) ];
786: postins = [];
787: cases = []
788: }
789:
790: (* Keep track of the gotos *)
791: let backFlx_cil_patchGotos : (string, stmt ref list ref) H.t = H.create 17
792: let addGoto (lname: string) (bref: stmt ref) : unit =
793: let gotos =
794: try
795: H.find backFlx_cil_patchGotos lname
796: with Not_found -> begin
797: let gotos = ref [] in
798: H.add backFlx_cil_patchGotos lname gotos;
799: gotos
800: end
801: in
802: gotos := bref :: !gotos
803:
804: (* Keep track of the labels *)
805: let labelStmt : (string, stmt) H.t = H.create 17
806: let initLabels () =
807: H.clear backFlx_cil_patchGotos;
808: H.clear labelStmt
809:
810: let resolveGotos () =
811: H.iter
812: (fun lname gotos ->
813: try
814: let dest = H.find labelStmt lname in
815: List.iter (fun gref -> gref := dest) !gotos
816: with Not_found -> begin
817: E.s (error "Label %s not found\n" lname)
818: end)
819: backFlx_cil_patchGotos
820:
821: (* Get the first statement in a chunk. Might need to change the
822: * statements in the chunk *)
823: let getFirstInChunk (c: chunk) : stmt * stmt list =
824: (* Get the first statement and add the label to it *)
825: match c.stmts with
826: s :: _ -> s, c.stmts
827: | [] -> (* Add a statement *)
828: let n = mkEmptyStmt () in
829: n, n :: c.stmts
830:
831: let consLabel (l: string) (c: chunk) (loc: location)
832: (in_original_program_text : bool) : chunk =
833: (* Get the first statement and add the label to it *)
834: let labstmt, stmts' = getFirstInChunk c in
835: (* Add the label *)
836: labstmt.labels <- Label (l, loc, in_original_program_text) ::
837: labstmt.labels;
838: H.add labelStmt l labstmt;
839: if c.stmts == stmts' then c else {c with stmts = stmts'}
840:
841: let s2c (s:stmt) : chunk =
842: { stmts = [ s ];
843: postins = [];
844: cases = [];
845: }
846:
847: let gotoChunk (ln: string) (l: location) : chunk =
848: let gref = ref dummyStmt in
849: addGoto ln gref;
850: { stmts = [ mkStmt (Goto (gref, l)) ];
851: postins = [];
852: cases = [];
853: }
854:
855: let caseRangeChunk (el: exp list) (l: location) (next: chunk) =
856: let fst, stmts' = getFirstInChunk next in
857: let labels = List.map (fun e -> Case (e, l)) el in
858: let cases = List.map (fun l -> (l, fst)) labels in
859: fst.labels <- labels @ fst.labels;
860: { next with stmts = stmts'; cases = cases @ next.cases}
861:
862: let defaultChunk (l: location) (next: chunk) =
863: let fst, stmts' = getFirstInChunk next in
864: let lb = Default l in
865: fst.labels <- lb :: fst.labels;
866: { next with stmts = stmts'; cases = (lb, fst) :: next.cases}
867:
868:
869: let switchChunk (e: exp) (body: chunk) (l: location) =
870: (* Make the statement *)
871: let switch = mkStmt (Switch (e, c2block body,
872: List.map (fun (_, s) -> s) body.cases,
873: l)) in
874: { stmts = [ switch (* ; n *) ];
875: postins = [];
876: cases = [];
877: }
878:
879: let mkFunctionBody (c: chunk) : block =
880: resolveGotos (); initLabels ();
881: if c.cases <> [] then
882: E.s (error "Switch cases not inside a switch statement\n");
883: c2block c
884:
885: end
886:
887: open BlockChunk
888:
889:
890: (************ Labels ***********)
891: (* Since we turn dowhile and for loops into while we need to take care in
892: * processing the continue statement. For each loop that we enter we place a
893: * marker in a list saying what kinds of loop it is. When we see a continue
894: * for a Non-while loop we must generate a label for the continue *)
895: type loopstate =
896: While
897: | NotWhile of string ref
898:
899: let continues : loopstate list ref = ref []
900:
901: let startLoop iswhile =
902: continues := (if iswhile then While else NotWhile (ref "")) :: !continues
903:
904: (* Sometimes we need to create new label names *)
905: let newLabelName (base: string) = fst (newAlphaName false "label" base)
906:
907: let continueOrLabelChunk (l: location) : chunk =
908: match !continues with
909: [] -> E.s (error "continue not in a loop")
910: | While :: _ -> continueChunk l
911: | NotWhile lr :: _ ->
912: if !lr = "" then begin
913: lr := newLabelName "__Cont"
914: end;
915: gotoChunk !lr l
916:
917: let consLabContinue (c: chunk) =
918: match !continues with
919: [] -> E.s (error "labContinue not in a loop")
920: | While :: rest -> c
921: | NotWhile lr :: rest -> if !lr = "" then c else consLabel !lr c !currentLoc false
922:
923: let exitLoop () =
924: match !continues with
925: [] -> E.s (error "exit Loop not in a loop")
926: | _ :: rest -> continues := rest
927:
928:
929: (* In GCC we can have locally declared labels. *)
930: let genNewLocalLabel (l: string) =
931: (* Call the newLabelName to register the label name in the alpha conversion
932: * table. *)
933: let l' = newLabelName l in
934: (* Add it to the environment *)
935: addLocalToEnv (kindPlusName "label" l) (EnvLabel l');
936: l'
937:
938: let lookupLabel (l: string) =
939: try
940: match H.find env (kindPlusName "label" l) with
941: EnvLabel l', _ -> l'
942: | _ -> raise Not_found
943: with Not_found ->
944: l
945:
946:
947: (** ALLOCA ***)
948: let allocaFun =
949: let fdec = emptyFunction "alloca" in
950: fdec.svar.vtype <-
951: TFun(voidPtrType, Some [ ("len", uintType, []) ], false, []);
952: fdec
953:
954: (* Maps local variables that are variable sized arrays to the expression that
955: * denotes their length *)
956: let varSizeArrays : (int, exp) H.t = H.create 17
957:
958: (**** EXP actions ***)
959: type expAction =
960: ADrop (* Drop the result. Only the
961: * side-effect is interesting *)
962: | ASet of lval * typ (* Put the result in a given lval,
963: * provided it matches the type. The
964: * type is the type of the lval. *)
965: | AExp of typ option (* Return the exp as usual.
966: * Optionally we can specify an
967: * expected type. This is useful for
968: * constants. The expected type is
969: * informational only, we do not
970: * guarantee that the converted
971: * expression has that type.You must
972: * use a doCast afterwards to make
973: * sure. *)
974: | AExpLeaveArrayFun (* Do it like an expression, but do
975: * not convert arrays of functions
976: * into pointers *)
977:
978:
979: (*** Result of compiling conditional expressions *)
980: type condExpRes =
981: CEExp of chunk * exp (* Do a chunk and then an expression *)
982: | CEAnd of condExpRes * condExpRes
983: | CEOr of condExpRes * condExpRes
984: | CENot of condExpRes
985:
986: (******** CASTS *********)
987: let integralPromotion (t : typ) : typ = (* c.f. ISO 6.3.1.1 *)
988: match unrollType t with
989: (* We assume that an IInt can hold even an IUShort *)
990: TInt ((IShort|IUShort|IChar|ISChar|IUChar), a) -> TInt(IInt, a)
991: | TInt _ -> t
992: | TEnum (_, a) -> TInt(IInt, a)
993: | t -> E.s (error "integralPromotion: not expecting %a" d_type t)
994:
995:
996: let arithmeticConversion (* c.f. ISO 6.3.1.8 *)
997: (t1: typ)
998: (t2: typ) : typ =
999: let checkToInt _ = () in (* dummies for now *)
1000: let checkToFloat _ = () in
1001: match unrollType t1, unrollType t2 with
1002: TFloat(FLongDouble, _), _ -> checkToFloat t2; t1
1003: | _, TFloat(FLongDouble, _) -> checkToFloat t1; t2
1004: | TFloat(FDouble, _), _ -> checkToFloat t2; t1
1005: | _, TFloat (FDouble, _) -> checkToFloat t1; t2
1006: | TFloat(FFloat, _), _ -> checkToFloat t2; t1
1007: | _, TFloat (FFloat, _) -> checkToFloat t1; t2
1008: | _, _ -> begin
1009: let t1' = integralPromotion t1 in
1010: let t2' = integralPromotion t2 in
1011: match unrollType t1', unrollType t2' with
1012: TInt(IULongLong, _), _ -> checkToInt t2'; t1'
1013: | _, TInt(IULongLong, _) -> checkToInt t1'; t2'
1014:
1015: (* We assume a long long is always larger than a long *)
1016: | TInt(ILongLong, _), _ -> checkToInt t2'; t1'
1017: | _, TInt(ILongLong, _) -> checkToInt t1'; t2'
1018:
1019: | TInt(IULong, _), _ -> checkToInt t2'; t1'
1020: | _, TInt(IULong, _) -> checkToInt t1'; t2'
1021:
1022:
1023: | TInt(ILong,_), TInt(IUInt,_)
1024: when bitsSizeOf t1' <= bitsSizeOf t2' -> TInt(IULong,[])
1025: | TInt(IUInt,_), TInt(ILong,_)
1026: when bitsSizeOf t2' <= bitsSizeOf t1' -> TInt(IULong,[])
1027:
1028: | TInt(ILong, _), _ -> checkToInt t2'; t1'
1029: | _, TInt(ILong, _) -> checkToInt t1'; t2'
1030:
1031: | TInt(IUInt, _), _ -> checkToInt t2'; t1'
1032: | _, TInt(IUInt, _) -> checkToInt t1'; t2'
1033:
1034: | TInt(IInt, _), TInt (IInt, _) -> t1'
1035:
1036: | _, _ -> E.s (error "arithmeticConversion")
1037: end
1038:
1039:
1040: (* Specify whether the cast is from the source code *)
1041: let rec castTo ?(fromsource=false)
1042: (ot : typ) (nt : typ) (e : exp) : (typ * exp ) =
1043: (*
1044: ignore (E.log "%t: castTo:%s %a->%a\n"
1045: d_thisloc
1046: (if fromsource then "(source)" else "")
1047: d_type ot d_type nt);
1048: *)
1049: if not fromsource && typeSig ot = typeSig nt then
1050: (* Do not put the cast if it is not necessary, unless it is from the
1051: * source. *)
1052: (ot, e)
1053: else begin
1054: let result = (nt, mkCastT e ot nt) in
1055: (*
1056: ignore (E.log "castTo: ot=%a nt=%a\n result is %a\n"
1057: d_type ot d_type nt
1058: d_plainexp (snd result));
1059: *)
1060: (* Now see if we can have a cast here *)
1061: match ot, nt with
1062: TNamed(r, _), _ -> castTo r.ttype nt e
1063: | _, TNamed(r, _) -> castTo ot r.ttype e
1064: | TInt(ikindo,_), TInt(ikindn,_) ->
1065: (* We used to ignore attributes on integer-integer casts. Not anymore *)
1066: (* if ikindo = ikindn then (nt, e) else *)
1067: result
1068:
1069: | TPtr (told, _), TPtr(tnew, _) -> result
1070:
1071: | TInt _, TPtr _ -> result
1072:
1073: | TPtr _, TInt _ -> result
1074:
1075: | TArray _, TPtr _ -> result
1076:
1077: | TArray(t1,_,_), TArray(t2,None,_) when typeSig t1 = typeSig t2 -> (nt, e)
1078:
1079: | TPtr _, TArray(_,_,_) -> (nt, e)
1080:
1081: | TEnum _, TInt _ -> result
1082: | TFloat _, (TInt _|TEnum _) -> result
1083: | (TInt _|TEnum _), TFloat _ -> result
1084: | TFloat _, TFloat _ -> result
1085: | TInt _, TEnum _ -> result
1086: | TEnum _, TEnum _ -> result
1087:
1088: | TEnum _, TPtr _ -> result
1089: | TBuiltin_va_list _, (TInt _ | TPtr _) ->
1090: result
1091:
1092: | (TInt _ | TPtr _), TBuiltin_va_list _ ->
1093: ignore (warnOpt "Casting %a to __builtin_va_list" d_type ot);
1094: result
1095:
1096: | TPtr _, TEnum _ ->
1097: ignore (warnOpt "Casting a pointer into an enumeration type");
1098: result
1099:
1100: (* The expression is evaluated for its side-effects *)
1101: | (TInt _ | TEnum _ | TPtr _ ), TVoid _ ->
1102: (ot, e)
1103:
1104: (* Even casts between structs are allowed when we are only
1105: * modifying some attributes *)
1106: | TComp (comp1, a1), TComp (comp2, a2) when comp1.ckey = comp2.ckey ->
1107: (nt, e)
1108:
1109: | _ -> E.s (error "cabs2cil: castTo %a -> %a@!" d_type ot d_type nt)
1110: end
1111:
1112:
1113: (* A cast that is used for conditional expressions. Pointers are Ok *)
1114: let checkBool (ot : typ) (e : exp) : bool =
1115: match unrollType ot with
1116: TInt _ -> true
1117: | TPtr _ -> true
1118: | TEnum _ -> true
1119: | TFloat _ -> true
1120: | _ -> E.s (error "castToBool %a" d_type ot)
1121:
1122:
1123: (* We have our own version of addAttributes that does not allow duplicates *)
1124: let cabsAddAttributes al0 (al: attributes) : attributes =
1125: if al0 == [] then al else
1126: List.fold_left
1127: (fun acc (Attr(an, _) as a) ->
1128: (* See if the attribute is already in there *)
1129: match filterAttributes an acc with
1130: [] -> addAttribute a acc (* Nothing with that name *)
1131: | a' :: _ ->
1132: if a = a' then
1133: acc (* Already in *)
1134: else begin
1135: ignore (warnOpt
1136: "Duplicate attribute %a along with %a"
1137: d_attr a d_attr a');
1138: (* let acc' = dropAttribute an acc in *)
1139: (** Keep both attributes *)
1140: addAttribute a acc
1141: end)
1142: al
1143: al0
1144:
1145: let cabsTypeAddAttributes a0 t =
1146: begin
1147: match a0 with
1148: | [] ->
1149: (* no attributes, keep same type *)
1150: t
1151: | _ ->
1152: (* anything else: add a0 to existing attributes *)
1153: let add (a: attributes) = cabsAddAttributes a0 a in
1154: match t with
1155: TVoid a -> TVoid (add a)
1156: | TInt (ik, a) ->
1157: (* Here we have to watch for the mode attribute *)
1158: (* sm: This stuff is to handle a GCC extension where you can request integers*)
1159: (* of specific widths using the "mode" attribute syntax; for example: *)
1160: (* typedef int int8_t __attribute__ ((__mode__ ( __QI__ ))) ; *)
1161: (* The cryptic "__QI__" defines int8_t to be 8 bits wide, instead of the *)
1162: (* 32 bits you'd guess if you didn't know about "mode". The relevant *)
1163: (* testcase is test/small2/mode_sizes.c, and it was inspired by my *)
1164: (* /usr/include/sys/types.h. *)
1165: (* *)
1166: (* A consequence of this handling is that we throw away the mode *)
1167: (* attribute, which we used to go out of our way to avoid printing anyway.*)
1168: let ik', a0' =
1169: (* Go over the list of new attributes and come back with a
1170: * filtered list and a new integer kind *)
1171: List.fold_left
1172: (fun (ik', a0') a0one ->
1173: match a0one with
1174: Attr("mode", [ACons(mode,[])]) -> begin
1175: (trace "gccwidth" (dprintf "I see mode %s applied to an int type\n"
1176: mode (* #$@!#@ ML! d_type t *) ));
1177: (* the cases below encode the 32-bit assumption.. *)
1178: match (ik', mode) with
1179: | (IInt, "__QI__") -> (IChar, a0')
1180: | (IInt, "__byte__") -> (IChar, a0')
1181: | (IInt, "__HI__") -> (IShort, a0')
1182: | (IInt, "__SI__") -> (IInt, a0') (* same as t *)
1183: | (IInt, "__word__") -> (IInt, a0')
1184: | (IInt, "__pointer__") -> (IInt, a0')
1185: | (IInt, "__DI__") -> (ILongLong, a0')
1186:
1187: | (IUInt, "__QI__") -> (IUChar, a0')
1188: | (IUInt, "__byte__") -> (IUChar, a0')
1189: | (IUInt, "__HI__") -> (IUShort, a0')
1190: | (IUInt, "__SI__") -> (IUInt, a0')
1191: | (IUInt, "__word__") -> (IUInt, a0')
1192: | (IUInt, "__pointer__")-> (IUInt, a0')
1193: | (IUInt, "__DI__") -> (IULongLong, a0')
1194:
1195: | _ ->
1196: (ignore (error "GCC width mode %s applied to unexpected type, or unexpected mode"
1197: mode));
1198: (ik', a0one :: a0')
1199:
1200: end
1201: | _ -> (ik', a0one :: a0'))
1202: (ik, [])
1203: a0
1204: in
1205: TInt (ik', cabsAddAttributes a0' a)
1206:
1207: | TFloat (fk, a) -> TFloat (fk, add a)
1208: | TEnum (enum, a) -> TEnum (enum, add a)
1209: | TPtr (t, a) -> TPtr (t, add a)
1210: | TArray (t, l, a) -> TArray (t, l, add a)
1211: | TFun (t, args, isva, a) -> TFun(t, args, isva, add a)
1212: | TComp (comp, a) -> TComp (comp, add a)
1213: | TNamed (t, a) -> TNamed (t, add a)
1214: | TBuiltin_va_list a -> TBuiltin_va_list (add a)
1215: end
1216:
1217:
1218: (* Do types *)
1219: (* Combine the types. Raises the Failure exception with an error message.
1220: * isdef says whether the new type is for a definition *)
1221: type combineWhat =
1222: CombineFundef (* The new definition is for a function definition. The old
1223: * is for a prototype *)
1224: | CombineFunarg (* Comparing a function argument type with an old prototype
1225: * arg *)
1226: | CombineFunret (* Comparing the return of a function with that from an old
1227: * prototype *)
1228: | CombineOther
1229:
1230: (* We sometimes want to succeed in combining two structure types that are
1231: * identical except for the names of the structs. We keep a list of types
1232: * that are known to be equal *)
1233: let isomorphicStructs : (string * string, bool) H.t = H.create 15
1234:
1235: let rec combineTypes (what: combineWhat) (oldt: typ) (t: typ) : typ =
1236: match oldt, t with
1237: | TVoid olda, TVoid a -> TVoid (cabsAddAttributes olda a)
1238: | TInt (oldik, olda), TInt (ik, a) ->
1239: let combineIK oldk k =
1240: if oldk = k then oldk else
1241: (* GCC allows a function definition to have a more precise integer
1242: * type than a prototype that says "int" *)
1243: if not !msvcMode && oldk = IInt && bitsSizeOf t <= 32
1244: && (what = CombineFunarg || what = CombineFunret) then
1245: k
1246: else
1247: raise (Failure "different integer types")
1248: in
1249: TInt (combineIK oldik ik, cabsAddAttributes olda a)
1250: | TFloat (oldfk, olda), TFloat (fk, a) ->
1251: let combineFK oldk k =
1252: if oldk = k then oldk else
1253: (* GCC allows a function definition to have a more precise integer
1254: * type than a prototype that says "double" *)
1255: if not !msvcMode && oldk = FDouble && k = FFloat
1256: && (what = CombineFunarg || what = CombineFunret) then
1257: k
1258: else
1259: raise (Failure "different floating point types")
1260: in
1261: TFloat (combineFK oldfk fk, cabsAddAttributes olda a)
1262: | TEnum (_, olda), TEnum (ei, a) ->
1263: TEnum (ei, cabsAddAttributes olda a)
1264:
1265: (* Strange one. But seems to be handled by GCC *)
1266: | TEnum (oldei, olda) , TInt(IInt, a) -> TEnum(oldei,
1267: cabsAddAttributes olda a)
1268: (* Strange one. But seems to be handled by GCC *)
1269: | TInt(IInt, olda), TEnum (ei, a) -> TEnum(ei, cabsAddAttributes olda a)
1270:
1271:
1272: | TComp (oldci, olda) , TComp (ci, a) ->
1273: if oldci.cstruct <> ci.cstruct then
1274: raise (Failure "different struct/union types");
1275: let comb_a = cabsAddAttributes olda a in
1276: if oldci.cname = ci.cname then
1277: TComp (oldci, comb_a)
1278: else
1279: (* Now maybe they are actually the same *)
1280: if H.mem isomorphicStructs (oldci.cname, ci.cname) then
1281: (* We know they are the same *)
1282: TComp (oldci, comb_a)
1283: else begin
1284: (* If one has 0 fields (undefined) while the other has some fields
1285: * we accept it *)
1286: let oldci_nrfields = List.length oldci.cfields in
1287: let ci_nrfields = List.length ci.cfields in
1288: if oldci_nrfields = 0 then
1289: TComp (ci, comb_a)
1290: else if ci_nrfields = 0 then
1291: TComp (oldci, comb_a)
1292: else begin
1293: (* Make sure that at least they have the same number of fields *)
1294: if oldci_nrfields <> ci_nrfields then begin
1295: (*
1296: ignore (E.log "different number of fields: %s had %d and %s had %d\n"
1297: oldci.cname oldci_nrfields
1298: ci.cname ci_nrfields);
1299: *)
1300: raise (Failure "different structs(number of fields)");
1301: end;
1302: (* Assume they are the same *)
1303: H.add isomorphicStructs (oldci.cname, ci.cname) true;
1304: H.add isomorphicStructs (ci.cname, oldci.cname) true;
1305: (* Flx_cil_check that the fields are isomorphic and watch for Failure *)
1306: (try
1307: List.iter2 (fun oldf f ->
1308: if oldf.fbitfield <> f.fbitfield then
1309: raise (Failure "different structs(bitfield info)");
1310: if oldf.fattr <> f.fattr then
1311: raise (Failure "different structs(field attributes)");
1312: (* Make sure the types are compatible *)
1313: ignore (combineTypes CombineOther oldf.ftype f.ftype);
1314: ) oldci.cfields ci.cfields
1315: with Failure _ as e -> begin
1316: (* Our assumption was wrong. Forget the isomorphism *)
1317: ignore (E.log "\tFailed in our assumption that %s and %s are isomorphic\n"
1318: oldci.cname ci.cname);
1319: H.remove isomorphicStructs (oldci.cname, ci.cname);
1320: H.remove isomorphicStructs (ci.cname, oldci.cname);
1321: raise e
1322: end);
1323: (* We get here if we succeeded *)
1324: TComp (oldci, comb_a)
1325: end
1326: end
1327:
1328: | TArray (oldbt, oldsz, olda), TArray (bt, sz, a) ->
1329: let newbt = combineTypes CombineOther oldbt bt in
1330: let newsz =
1331: if oldsz = sz then sz else
1332: match oldsz, sz with
1333: None, Some _ -> sz
1334: | Some _, None -> oldsz
1335: | _ -> raise (Failure "different array lengths")
1336: in
1337: TArray (newbt, newsz, cabsAddAttributes olda a)
1338:
1339: | TPtr (oldbt, olda), TPtr (bt, a) ->
1340: TPtr (combineTypes CombineOther oldbt bt, cabsAddAttributes olda a)
1341:
1342: | TFun (_, _, _, [Attr("missingproto",_)]), TFun _ -> t
1343:
1344: | TFun (oldrt, oldargs, oldva, olda), TFun (rt, args, va, a) ->
1345: let newrt = combineTypes
1346: (if what = CombineFundef then CombineFunret else CombineOther)
1347: oldrt rt
1348: in
1349: if oldva != va then
1350: raise (Failure "diferent vararg specifiers");
1351: (* If one does not have arguments, believe the one with the
1352: * arguments *)
1353: let newargs =
1354: if oldargs = None then args else
1355: if args = None then oldargs else
1356: let oldargslist = argsToList oldargs in
1357: let argslist = argsToList args in
1358: if List.length oldargslist <> List.length argslist then
1359: raise (Failure "different number of arguments")
1360: else begin
1361: (* Go over the arguments and update the old ones with the
1362: * adjusted types *)
1363: Some
1364: (List.map2
1365: (fun (on, ot, oa) (an, at, aa) ->
1366: (* Update the names. Always prefer the new name. This is
1367: * very important if the prototype uses different names than
1368: * the function definition. *)
1369: let n = if an <> "" then an else on in
1370: let t =
1371: combineTypes
1372: (if what = CombineFundef then
1373: CombineFunarg else CombineOther)
1374: ot at
1375: in
1376: let a = addAttributes oa aa in
1377: (n, t, a))
1378: oldargslist argslist)
1379: end
1380: in
1381: TFun (newrt, newargs, oldva, cabsAddAttributes olda a)
1382:
1383: | TNamed (oldt, olda), TNamed (t, a) when oldt.tname = t.tname ->
1384: TNamed (oldt, cabsAddAttributes olda a)
1385:
1386: (* Unroll first the new type *)
1387: | _, TNamed (t, a) ->
1388: let res = combineTypes what oldt t.ttype in
1389: cabsTypeAddAttributes a res
1390:
1391: (* And unroll the old type as well if necessary *)
1392: | TNamed (oldt, a), _ ->
1393: let res = combineTypes what oldt.ttype t in
1394: cabsTypeAddAttributes a res
1395:
1396: | _ -> raise (Failure "different type constructors")
1397:
1398:
1399: (* Create and cache varinfo's for globals. Starts with a varinfo but if the
1400: * global has been declared already it might come back with another varinfo.
1401: * Returns the varinfo to use (might be the old one), and an indication
1402: * whether the variable exists already in the environment *)
1403: let makeGlobalVarinfo (isadef: bool) (vi: varinfo) : varinfo * bool =
1404: try (* See if already defined, in the global environment. We could also
1405: * look it up in the whole environment but in that case we might see a
1406: * local. This can happen when we declare an extern variable with
1407: * global scope but we are in a local scope. *)
1408: let oldvi, oldloc = lookupGlobalVar vi.vname in
1409: begin
1410: try
1411: oldvi.vtype <-
1412: combineTypes
1413: (if isadef then CombineFundef else CombineOther)
1414: oldvi.vtype vi.vtype
1415: ;
1416: (* It was already defined. We must reuse the varinfo.
1417: * But clean up the storage. *)
1418: let newstorage =
1419: match oldvi.vstorage, vi.vstorage with
1420: | Extern, other
1421: | NoStorage, other
1422: | other, Extern
1423: | other, NoStorage ->
1424: other
1425: | _ ->
1426: if vi.vstorage != oldvi.vstorage then
1427: ignore (warn
1428: "Inconsistent storage specification for %s. Previous declaration: %a"
1429: vi.vname d_loc oldloc);
1430: vi.vstorage
1431: in
1432: oldvi.vinline <- oldvi.vinline || vi.vinline;
1433: oldvi.vstorage <- newstorage;
1434: oldvi.vattr <- cabsAddAttributes oldvi.vattr vi.vattr;
1435: oldvi, true
1436:
1437: with Failure reason ->
1438: ignore (E.log "old type = %a\n" d_plaintype oldvi.vtype);
1439: ignore (E.log "new type = %a\n" d_plaintype vi.vtype);
1440: if !Flx_cil_lexerhack.get_lang () =`C then
1441: E.s (error "Declaration of %s does not match previous declaration from %a (%s)."
1442: vi.vname d_loc oldloc reason)
1443: else begin
1444: ignore (E.log "[Overload] %s." vi.vname);
1445: vi, false
1446: end
1447: end;
1448:
1449:
1450: with Not_found -> begin (* A new one. *)
1451: (* Announce the name to the alpha conversion table. This will not
1452: * actually change the name of the vi. See the definition of
1453: * alphaConvertVarAndAddToEnv *)
1454: alphaConvertVarAndAddToEnv true vi, false
1455: end
1456:
1457: let conditionalConversion (t2: typ) (t3: typ) : typ =
1458: let is_char k = match k with
1459: IChar | ISChar | IUChar -> true
1460: | _ -> false in
1461: let tresult = (* ISO 6.5.15 *)
1462: match unrollType t2, unrollType t3 with
1463: (TInt _ | TEnum _ | TFloat _),
1464: (TInt _ | TEnum _ | TFloat _) ->
1465: arithmeticConversion t2 t3
1466: | TComp (comp2,_), TComp (comp3,_)
1467: when comp2.ckey = comp3.ckey -> t2
1468: | TPtr(_, _), TPtr(TVoid _, _) -> t2
1469: | TPtr(TVoid _, _), TPtr(_, _) -> t3
1470: | TPtr _, TPtr _ when typeSig t2 = typeSig t3 -> t2
1471: | TPtr _, TInt _ -> t2 (* most likely comparison with 0 *)
1472: | TInt _, TPtr _ -> t3 (* most likely comparison with 0 *)
1473:
1474: (* When we compare two pointers of diffent type, we combine them
1475: * using the same algorithm when combining multiple declarations of
1476: * a global *)
1477: | (TPtr _) as t2', (TPtr _ as t3') -> begin
1478: try combineTypes CombineOther t2' t3'
1479: with Failure msg -> begin
1480: ignore (warn "A.QUESTION: %a does not match %a (%s)"
1481: d_type (unrollType t2) d_type (unrollType t3) msg);
1482: t2 (* Just pick one *)
1483: end
1484: end
1485: | _, _ -> E.s (error "A.QUESTION for invalid combination of types")
1486: in
1487: tresult
1488:
1489: (* Some utilitites for doing initializers *)
1490:
1491: let debugInit = false
1492:
1493: type preInit =
1494: | NoInitPre
1495: | SinglePre of exp
1496: | CompoundPre of int ref (* the maximum used index *)
1497: * preInit array ref (* an array with initializers *)
1498:
1499: (* Instructions on how to handle designators *)
1500: type handleDesignators =
1501: | Handle (* Handle them yourself *)
1502: | DoNotHandle (* Do not handle them your self *)
1503: | HandleAsNext (* First behave as if you have a NEXT_INIT. Useful for going
1504: * into nested designators *)
1505: | HandleFirst (* Handle only the first designator *)
1506:
1507: (* Set an initializer *)
1508: let rec setOneInit (this: preInit)
1509: (o: offset) (e: exp) : preInit =
1510: match o with
1511: NoOffset -> SinglePre e
1512: | _ ->
1513: let idx, (* Index in the current comp *)
1514: restoff (* Rest offset *) =
1515: match o with
1516: | Index(Const(CInt64(i,_,_)), off) -> Int64.to_int i, off
1517: | Field (f, off) ->
1518: (* Find the index of the field *)
1519: let rec loop (idx: int) = function
1520: [] -> E.s (bug "Cannot find field %s" f.fname)
1521: | f' :: _ when f'.fname = f.fname -> idx
1522: | _ :: restf -> loop (idx + 1) restf
1523: in
1524: loop 0 f.fcomp.cfields, off
1525: | _ -> E.s (bug "setOneInit: non-constant index")
1526: in
1527: let pMaxIdx, pArray =
1528: match this with
1529: NoInitPre -> (* No initializer so far here *)
1530: ref idx, ref (Array.create (max 32 (idx + 1)) NoInitPre)
1531:
1532: | CompoundPre (pMaxIdx, pArray) ->
1533: if !pMaxIdx < idx then begin
1534: pMaxIdx := idx;
1535: (* Maybe we also need to grow the array *)
1536: let l = Array.length !pArray in
1537: if l <= idx then begin
1538: let growBy = max (max 32 (idx + 1 - l)) (l / 2) in
1539: let newarray = Array.make (growBy + idx) NoInitPre in
1540: Array.blit !pArray 0 newarray 0 l;
1541: pArray := newarray
1542: end
1543: end;
1544: pMaxIdx, pArray
1545: | SinglePre e ->
1546: E.s (unimp "Index %d is already initialized" idx)
1547: in
1548: assert (idx >= 0 && idx < Array.length !pArray);
1549: let this' = setOneInit !pArray.(idx) restoff e in
1550: !pArray.(idx) <- this';
1551: CompoundPre (pMaxIdx, pArray)
1552:
1553:
1554: (* collect a CIL initializer, given the original syntactic initializer
1555: * 'preInit'; this returns a type too, since initialization of an array
1556: * with unspecified size actually changes the array's type
1557: * (ANSI C, 6.7.8, para 22) *)
1558: let rec collectInitializer
1559: (this: preInit)
1560: (thistype: typ) : (init * typ) =
1561: if this = NoInitPre then (makeZeroInit thistype), thistype
1562: else
1563: match unrollType thistype, this with
1564: | _ , SinglePre e -> SingleInit e, thistype
1565: | TArray (bt, leno, at), CompoundPre (pMaxIdx, pArray) ->
1566: let (len, newtype) =
1567: (* normal case: use array's declared length, newtype=thistype *)
1568: try (lenOfArray leno, thistype)
1569:
1570: (* unsized array case, length comes from initializers *)
1571: with LenOfArray ->
1572: (!pMaxIdx + 1,
1573: TArray (bt, Some (integer (!pMaxIdx + 1)), at))
1574: in
1575: if !pMaxIdx >= len then
1576: E.s (E.bug "collectInitializer: too many initializers(%d >= %d)\n"
1577: !pMaxIdx len);
1578: (* len could be extremely big. So omit the last initializers, if they
1579: * are many (more than 16) *)
1580: (*
1581: ignore (E.log "collectInitializer: len = %d, pMaxIdx= %d\n"
1582: len !pMaxIdx); *)
1583: let endAt =
1584: if len - 1 > !pMaxIdx + 16 then
1585: !pMaxIdx
1586: else
1587: len - 1
1588: in
1589: (* Make one zero initializer to be used next *)
1590: let oneZeroInit = makeZeroInit bt in
1591: let rec collect (acc: (offset * init) list) (idx: int) =
1592: if idx = -1 then acc
1593: else
1594: let thisi =
1595: if idx > !pMaxIdx then oneZeroInit
1596: else (fst (collectInitializer !pArray.(idx) bt))
1597: in
1598: collect ((Index(integer idx, NoOffset), thisi) :: acc) (idx - 1)
1599: in
1600:
1601: CompoundInit (thistype, collect [] endAt), newtype
1602:
1603: | TComp (comp, _), CompoundPre (pMaxIdx, pArray) when comp.cstruct ->
1604: let rec collect (idx: int) = function
1605: [] -> []
1606: | f :: restf ->
1607: if f.fname = missingFieldName then
1608: collect (idx + 1) restf
1609: else
1610: let thisi =
1611: if idx > !pMaxIdx then
1612: makeZeroInit f.ftype
1613: else
1614: collectFieldInitializer !pArray.(idx) f
1615: in
1616: (Field(f, NoOffset), thisi) :: collect (idx + 1) restf
1617: in
1618: CompoundInit (thistype, collect 0 comp.cfields), thistype
1619:
1620: | TComp (comp, _), CompoundPre (pMaxIdx, pArray) when not comp.cstruct ->
1621: (* Find the field to initialize *)
1622: let rec findField (idx: int) = function
1623: [] -> E.s (bug "collectInitializer: union")
1624: | _ :: rest when idx < !pMaxIdx && !pArray.(idx) = NoInitPre ->
1625: findField (idx + 1) rest
1626: | f :: _ when idx = !pMaxIdx ->
1627: Field(f, NoOffset),
1628: collectFieldInitializer !pArray.(idx) f
1629: | _ -> E.s (error "Can initialize only one field for union")
1630: in
1631: if !msvcMode && !pMaxIdx != 0 then
1632: ignore (warn "On MSVC we can initialize only the first field of a union");
1633: CompoundInit (thistype, [ findField 0 comp.cfields ]), thistype
1634:
1635: | _ -> E.s (unimp "collectInitializer")
1636:
1637: and collectFieldInitializer
1638: (this: preInit)
1639: (f: fieldinfo) : init =
1640: (* collect, and rewrite type *)
1641: let init,newtype = (collectInitializer this f.ftype) in
1642: f.ftype <- newtype;
1643: init
1644:
1645:
1646: type stackElem =
1647: InArray of offset * typ * int * int ref (* offset of parent, base type,
1648: * length, current index. If the
1649: * array length is unspecified we
1650: * use Int.max_int *)
1651: | InComp of offset * compinfo * fieldinfo list (* offset of parent,
1652: base comp, current fields *)
1653:
1654:
1655: (* A subobject is given by its address. The address is read from the end of
1656: * the list (the bottom of the stack), starting with the current object *)
1657: type subobj = { mutable stack: stackElem list; (* With each stack element we
1658: * store the offset of its
1659: * PARENT *)
1660: mutable eof: bool; (* The stack is empty and we reached the
1661: * end *)
1662: mutable soTyp: typ; (* The type of the subobject. Set using
1663: * normalSubobj after setting stack. *)
1664: mutable soOff: offset; (* The offset of the subobject. Set
1665: * using normalSubobj after setting
1666: * stack. *)
1667: curTyp: typ; (* Type of current object. See ISO for
1668: * the definition of the current object *)
1669: curOff: offset; (* The offset of the current obj *)
1670: host: varinfo; (* The host that we are initializing.
1671: * For error messages *)
1672: }
1673:
1674:
1675: (* Make a subobject iterator *)
1676: let rec makeSubobj
1677: (host: varinfo)
1678: (curTyp: typ)
1679: (curOff: offset) =
1680: let so =
1681: { host = host; curTyp = curTyp; curOff = curOff;
1682: stack = []; eof = false;
1683: (* The next are fixed by normalSubobj *)
1684: soTyp = voidType; soOff = NoOffset } in
1685: normalSubobj so;
1686: so
1687:
1688: (* Normalize a stack so the we always point to a valid subobject. Do not
1689: * descend into type *)
1690: and normalSubobj (so: subobj) : unit =
1691: match so.stack with
1692: [] -> so.soOff <- so.curOff; so.soTyp <- so.curTyp
1693: (* The array is over *)
1694: | InArray (parOff, bt, leno, current) :: rest ->
1695: if leno = !current then begin (* The array is over *)
1696: if debugInit then ignore (E.log "Past the end of array\n");
1697: so.stack <- rest;
1698: advanceSubobj so
1699: end else begin
1700: so.soTyp <- bt;
1701: so.soOff <- addOffset (Index(integer !current, NoOffset)) parOff
1702: end
1703:
1704: (* The fields are over *)
1705: | InComp (parOff, comp, nextflds) :: rest ->
1706: if nextflds = [] then begin (* No more fields here *)
1707: if debugInit then ignore (E.log "Past the end of structure\n");
1708: so.stack <- rest;
1709: advanceSubobj so
1710: end else begin
1711: let fst = List.hd nextflds in
1712: so.soTyp <- fst.ftype;
1713: so.soOff <- addOffset (Field(fst, NoOffset)) parOff
1714: end
1715:
1716: (* Advance to the next subobject. Always apply to a normalized object *)
1717: and advanceSubobj (so: subobj) : unit =
1718: if so.eof then E.s (bug "advanceSubobj past end");
1719: match so.stack with
1720: | [] -> if debugInit then ignore (E.log "Setting eof to true\n");
1721: so.eof <- true
1722: | InArray (parOff, bt, leno, current) :: rest ->
1723: if debugInit then ignore (E.log " Advancing to [%d]\n" (!current + 1));
1724: (* so.stack <- InArray (parOff, bt, leno, current + 1) :: rest; *)
1725: incr current;
1726: normalSubobj so
1727:
1728: (* The fields are over *)
1729: | InComp (parOff, comp, nextflds) :: rest ->
1730: if debugInit then
1731: ignore (E.log "Advancing past .%s\n" (List.hd nextflds).fname);
1732: let flds' = try List.tl nextflds with _ -> E.s (bug "advanceSubobj") in
1733: so.stack <- InComp(parOff, comp, flds') :: rest;
1734: normalSubobj so
1735:
1736:
1737:
1738: (* Find the fields to initialize in a composite. *)
1739: let fieldsToInit
1740: (comp: compinfo)
1741: (designator: string option)
1742: : fieldinfo list =
1743: (* Never look at anonymous fields *)
1744: let flds1 =
1745: List.filter (fun f -> f.fname <> missingFieldName) comp.cfields in
1746: let flds2 =
1747: match designator with
1748: None -> flds1
1749: | Some fn ->
1750: let rec loop = function
1751: [] -> E.s (error "Cannot find designated field %s" fn)
1752: | (f :: _) as nextflds when f.fname = fn -> nextflds
1753: | _ :: rest -> loop rest
1754: in
1755: loop flds1
1756: in
1757: (* If it is a union we only initialize one field *)
1758: match flds2 with
1759: [] -> []
1760: | (f :: rest) as toinit ->
1761: if comp.cstruct then toinit else [f]
1762:
1763:
1764: let integerArrayLength (leno: exp option) : int =
1765: match leno with
1766: None -> max_int
1767: | Some len -> begin
1768: try lenOfArray leno
1769: with LenOfArray ->
1770: E.s (error "Initializing non-constant-length array\n length=%a\n"
1771: d_exp len)
1772: end
1773:
1774: (* sm: I'm sure something like this already exists, but ... *)
1775: let isNone (o : 'a option) : bool =
1776: match o with
1777: | None -> true
1778: | Some _ -> false
1779:
1780:
1781: let annonCompFieldNameId = ref 0
1782: let annonCompFieldName = "__annonCompField"
1783:
1784:
1785:
1786: (* Flx_cil_utility ***)
1787: let rec replaceLastInList
1788: (lst: A.expression list)
1789: (how: A.expression -> A.expression) : A.expression list=
1790: match lst with
1791: [] -> []
1792: | [e] -> [how e]
1793: | h :: t -> h :: replaceLastInList t how
1794:
1795:
1796:
1797:
1798:
1799: let convBinOp (bop: A.binary_operator) : binop =
1800: match bop with
1801: A.ADD -> PlusA
1802: | A.SUB -> MinusA
1803: | A.MUL -> Mult
1804: | A.DIV -> Div
1805: | A.MOD -> Mod
1806: | A.BAND -> BAnd
1807: | A.BOR -> BOr
1808: | A.XOR -> BXor
1809: | A.SHL -> Shiftlt
1810: | A.SHR -> Shiftrt
1811: | A.EQ -> Eq
1812: | A.NE -> Ne
1813: | A.LT -> Lt
1814: | A.LE -> Le
1815: | A.GT -> Gt
1816: | A.GE -> Ge
1817: | _ -> E.s (error "convBinOp")
1818:
1819: (**** PEEP-HOLE optimizations ***)
1820: let afterConversion (c: chunk) : chunk =
1821: (* Now scan the statements and find Instr blocks *)
1822: let collapseCallCast = function
1823: Call(Some(Var vi, NoOffset), f, args, l),
1824: Set(destlv, CastE (newt, Lval(Var vi', NoOffset)), _)
1825: when (not vi.vglob &&
1826: String.length vi.vname >= 3 &&
1827: String.sub vi.vname 0 3 = "tmp" &&
1828: vi' == vi)
1829: -> Some [Call(Some destlv, f, args, l)]
1830: | _ -> None
1831: in
1832: (* First add in the postins *)
1833: let sl = pushPostIns c in
1834: peepHole2 collapseCallCast sl;
1835: { c with stmts = sl; postins = [] }
1836:
1837: (***** Try to suggest a name for the anonymous structures *)
1838: let suggestAnonName (nl: A.name list) =
1839: match nl with
1840: [] -> ""
1841: | (n, _, _, _) :: _ -> n
1842:
1843: (****** TYPE SPECIFIERS *******)
1844: let rec doSpecList (suggestedAnonName: string) (* This string will be part of
1845: * the names for anonymous
1846: * structures and enums *)
1847: (specs: A.spec_elem list)
1848: (* Returns the base type, the storage, whether it is inline and the
1849: * (unprocessed) attributes *)
1850: : typ * storage * bool * A.attribute list =
1851: (* Do one element and collect the type specifiers *)
1852: let isinline = ref false in (* If inline appears *)
1853: (* The storage is placed here *)
1854: let storage : storage ref = ref NoStorage in
1855:
1856: (* Collect the attributes. Unfortunately, we cannot treat GCC
1857: * __attributes__ and ANSI C const/volatile the same way, since they
1858: * associate with structures differently. Specifically, ANSI
1859: * qualifiers never apply to structures (ISO 6.7.3), whereas GCC
1860: * attributes always do (GCC manual 4.30). Therefore, they are
1861: * collected and processed separately. *)
1862: let attrs : A.attribute list ref = ref [] in (* __attribute__, etc. *)
1863: let cvattrs : A.cvspec list ref = ref [] in (* const/volatile *)
1864:
1865: let doSpecElem (se: A.spec_elem)
1866: (acc: A.typeSpecifier list)
1867: : A.typeSpecifier list =
1868: match se with
1869: A.SpecTypedef -> acc
1870: | A.SpecInline -> isinline := true; acc
1871: | A.SpecStorage st ->
1872: if !storage <> NoStorage then
1873: E.s (error "Multiple storage specifiers");
1874: let sto' =
1875: match st with
1876: A.NO_STORAGE -> NoStorage
1877: | A.AUTO -> NoStorage
1878: | A.REGISTER -> Register
1879: | A.STATIC -> Static
1880: | A.EXTERN -> Extern
1881: in
1882: storage := sto';
1883: acc
1884:
1885: | A.SpecCV cv -> cvattrs := cv :: !cvattrs; acc
1886: | A.SpecAttr a -> attrs := a :: !attrs; acc
1887: | A.SpecType ts -> ts :: acc
1888: | A.SpecPattern _ -> E.s (E.bug "SpecPattern in cabs2cil input")
1889: in
1890: (* Now scan the list and collect the type specifiers. Preserve the order *)
1891: let tspecs = List.fold_right doSpecElem specs [] in
1892:
1893: let tspecs' =
1894: (* GCC allows a named type that appears first to be followed by things
1895: * like "short", "signed", "unsigned" or "long". *)
1896: match tspecs with
1897: A.Tnamed n :: (_ :: _ as rest) when not !msvcMode ->
1898: (* If rest contains "short" or "long" then drop the Tnamed *)
1899: if List.exists (function A.Tshort -> true
1900: | A.Tlong -> true | _ -> false) rest then
1901: rest
1902: else
1903: tspecs
1904:
1905: | _ -> tspecs
1906: in
1907: (* Sort the type specifiers *)
1908: let sortedspecs =
1909: let order = function (* Don't change this *)
1910: | A.Tvoid -> 0
1911: | A.Tbool -> 0
1912: | A.Tsigned -> 1
1913: | A.Tunsigned -> 2
1914: | A.Tchar -> 3
1915: | A.Tshort -> 4
1916: | A.Tlong -> 5
1917: | A.Tint -> 6
1918: | A.Tint64 -> 7
1919: | A.Tfloat -> 8
1920: | A.Tdouble -> 9
1921: | A.Tcomplex -> 10
1922: | A.Timaginary -> 10
1923: | _ -> 11 (* There should be at most one of the others *)
1924: in
1925: (* Hopefully this is stable sort *)
1926: List.sort (fun ts1 ts2 -> compare (order ts1) (order ts2)) tspecs'
1927: in
1928: (* And now try to make sense of it. See ISO 6.7.2 *)
1929: let bt =
1930: match sortedspecs with
1931: [A.Tvoid] -> TVoid []
1932: | [A.Tchar] -> TInt(IChar, [])
1933: | [A.Tsigned; A.Tchar] -> TInt(ISChar, [])
1934: | [A.Tunsigned; A.Tchar] -> TInt(IUChar, [])
1935:
1936: | [A.Tshort] -> TInt(IShort, [])
1937: | [A.Tsigned; A.Tshort] -> TInt(IShort, [])
1938: | [A.Tshort; A.Tint] -> TInt(IShort, [])
1939: | [A.Tsigned; A.Tshort; A.Tint] -> TInt(IShort, [])
1940:
1941: | [A.Tunsigned; A.Tshort] -> TInt(IUShort, [])
1942: | [A.Tunsigned; A.Tshort; A.Tint] -> TInt(IUShort, [])
1943:
1944: | [] -> TInt(IInt, [])
1945: | [A.Tint] -> TInt(IInt, [])
1946: | [A.Tsigned] -> TInt(IInt, [])
1947: | [A.Tsigned; A.Tint] -> TInt(IInt, [])
1948:
1949: | [A.Tunsigned] -> TInt(IUInt, [])
1950: | [A.Tunsigned; A.Tint] -> TInt(IUInt, [])
1951:
1952: | [A.Tlong] -> TInt(ILong, [])
1953: | [A.Tsigned; A.Tlong] -> TInt(ILong, [])
1954: | [A.Tlong; A.Tint] -> TInt(ILong, [])
1955: | [A.Tsigned; A.Tlong; A.Tint] -> TInt(ILong, [])
1956:
1957: | [A.Tunsigned; A.Tlong] -> TInt(IULong, [])
1958: | [A.Tunsigned; A.Tlong; A.Tint] -> TInt(IULong, [])
1959:
1960: | [A.Tlong; A.Tlong] -> TInt(ILongLong, [])
1961: | [A.Tsigned; A.Tlong; A.Tlong] -> TInt(ILongLong, [])
1962: | [A.Tlong; A.Tlong; A.Tint] -> TInt(ILongLong, [])
1963: | [A.Tsigned; A.Tlong; A.Tlong; A.Tint] -> TInt(ILongLong, [])
1964:
1965: | [A.Tunsigned; A.Tlong; A.Tlong] -> TInt(IULongLong, [])
1966: | [A.Tunsigned; A.Tlong; A.Tlong; A.Tint] -> TInt(IULongLong, [])
1967:
1968: (* int64 is to support MSVC *)
1969: | [A.Tint64] -> TInt(ILongLong, [])
1970: | [A.Tsigned; A.Tint64] -> TInt(ILongLong, [])
1971:
1972: | [A.Tunsigned; A.Tint64] -> TInt(IULongLong, [])
1973:
1974: | [A.Tfloat] -> TFloat(FFloat, [])
1975: | [A.Tdouble] -> TFloat(FDouble, [])
1976: | [A.Tlong; A.Tdouble] -> TFloat(FLongDouble, [])
1977:
1978:
1979: | [A.Tcomplex] -> TFloat(CFloat, [])
1980: | [A.Tfloat; A.Tcomplex] -> TFloat(CFloat, [])
1981: | [A.Tdouble; A.Tcomplex] -> TFloat(CDouble, [])
1982: | [A.Tlong; A.Tdouble; A.Tcomplex] -> TFloat(CLongDouble, [])
1983:
1984: | [A.Timaginary] -> TFloat(IFloat, [])
1985: | [A.Tdouble; A.Timaginary] -> TFloat(IDouble, [])
1986: | [A.Tlong; A.Tdouble; A.Timaginary] -> TFloat(ILongDouble, [])
1987:
1988: (* Now the other type specifiers *)
1989: | [A.Tnamed n] -> begin
1990: if n = "__builtin_va_list" &&
1991: Flx_cil_machdep.gccHas__builtin_va_list then begin
1992: TBuiltin_va_list []
1993: end else
1994: let t =
1995: match lookupType "type" n with
1996: (TNamed _) as x, _ -> x
1997: | typ -> E.s (error "Named type %s is not mapped correctly\n" n)
1998: in
1999: t
2000: end
2001:
2002: | [A.Tstruct (n, None, _)] -> (* A reference to a struct *)
2003: if n = "" then E.s (error "Missing struct tag on incomplete struct");
2004: findCompType "struct" n []
2005: | [A.Tstruct (n, Some nglist, extraAttrs)] -> (* A definition of a struct *)
2006: let n' =
2007: if n <> "" then n else anonStructName "struct" suggestedAnonName in
2008: (* Use the (non-cv) attributes now *)
2009: let a = extraAttrs @ !attrs in
2010: attrs := [];
2011: makeCompType true n' nglist (doAttributes a)
2012:
2013: | [A.Tunion (n, None, _)] -> (* A reference to a union *)
2014: if n = "" then E.s (error "Missing union tag on incomplete union");
2015: findCompType "union" n []
2016: | [A.Tunion (n, Some nglist, extraAttrs)] -> (* A definition of a union *)
2017: let n' =
2018: if n <> "" then n else anonStructName "union" suggestedAnonName in
2019: (* Use the attributes now *)
2020: let a = extraAttrs @ !attrs in
2021: attrs := [];
2022: makeCompType false n' nglist (doAttributes a)
2023:
2024: | [A.Tenum (n, None, _)] -> (* Just a reference to an enum *)
2025: if n = "" then E.s (error "Missing enum tag on incomplete enum");
2026: findCompType "enum" n []
2027:
2028: | [A.Tenum (n, Some eil, extraAttrs)] -> (* A definition of an enum *)
2029: let n' =
2030: if n <> "" then n else anonStructName "enum" suggestedAnonName in
2031: (* make a new name for this enumeration *)
2032: let n'', _ = newAlphaName true "enum" n' in
2033: (* Create the enuminfo, or use one that was created already for a
2034: * forward reference *)
2035: (* Use the attributes now *)
2036: let a = extraAttrs @ !attrs in
2037: attrs := [];
2038: let enum, _ = createEnumInfo n'' in
2039: enum.eattr <- doAttributes a;
2040: let res = TEnum (enum, []) in
2041:
2042: (* sm: start a scope for the enum tag values, since they *
2043: * can refer to earlier tags *)
2044: enterScope ();
2045:
2046: (* as each name,value pair is determined, this is called *)
2047: let rec processName kname i loc rest = begin
2048: (* add the name to the environment, but with a faked 'typ' field;
2049: * we don't know the full type yet (since that includes all of the
2050: * tag values), but we won't need them in here *)
2051: addLocalToEnv kname (EnvEnum (i, res));
2052:
2053: (* add this tag to the list so that it ends up in the real
2054: * environment when we're finished *)
2055: let newname, _ = newAlphaName true "" kname in
2056: (kname, (newname, i, loc)) :: loop (increm i 1) rest
2057: end
2058:
2059: and loop i = function
2060: [] -> []
2061: | (kname, A.NOTHING, cloc) :: rest ->
2062: (* use the passed-in 'i' as the value, since none specified *)
2063: processName kname i (convLoc cloc) rest
2064:
2065: | (kname, e, cloc) :: rest ->
2066: (* constant-eval 'e' to determine tag value *)
2067: let i = match isIntConstExp e with
2068: Some e' -> e'
2069: | _ -> E.s (error "enum without const integer initializer")
2070: in
2071: processName kname i (convLoc cloc) rest
2072: in
2073:
2074: (* sm: now throw away the environment we built for eval'ing the enum
2075: * tags, so we can add to the new one properly *)
2076: exitScope ();
2077:
2078: let fields = loop zero eil in
2079: (* Now set the right set of items *)
2080: enum.eitems <- List.map (fun (_, x) -> x) fields;
2081: (* Record the enum name in the environment *)
2082: addLocalToEnv (kindPlusName "enum" n'') (EnvTyp res);
2083: (* And define the tag *)
2084: cabsPushGlobal (GEnumTag (enum, !currentLoc));
2085: res
2086:
2087:
2088: | [A.TtypeofE e] ->
2089: (* We process e as AExpLeaveArrayfun to avoid conversion of arrays
2090: * and functions into pointers *)
2091: let (c, e', t) = doExp false e AExpLeaveArrayFun in
2092: let t' =
2093: match e' with
2094: StartOf(lv) -> typeOfLval lv
2095: (* If this is a string literal, then we treat it as in sizeof*)
2096: | Const (CStr s) -> begin
2097: match typeOf e' with
2098: TPtr(bt, _) -> (* This is the type of arary elements *)
2099: TArray(bt, Some (SizeOfStr s), [])
2100: | _ -> E.s (bug "The typeOf a string is not a pointer type")
2101: end
2102: | _ -> t
2103: in
2104: (*
2105: ignore (E.log "typeof(%a) = %a\n" d_exp e' d_plaintype t');
2106: *)
2107: t'
2108:
2109: | [A.TtypeofT (specs, dt)] ->
2110: let typ = doOnlyType specs dt in
2111: typ
2112:
2113: | _ ->
2114: E.s (error "Invalid combination of type specifiers")
2115: in
2116: bt,!storage,!isinline,List.rev (!attrs @ (convertCVtoAttr !cvattrs))
2117:
2118: (* given some cv attributes, convert them into named attributes for
2119: * uniform processing *)
2120: and convertCVtoAttr (src: A.cvspec list) : A.attribute list =
2121: match src with
2122: | [] -> []
2123: | CV_CONST :: tl -> ("const",[]) :: (convertCVtoAttr tl)
2124: | CV_VOLATILE :: tl -> ("volatile",[]) :: (convertCVtoAttr tl)
2125: | CV_RESTRICT :: tl -> ("restrict",[]) :: (convertCVtoAttr tl)
2126:
2127:
2128: and makeVarInfoFlx_cil_cabs
2129: ~(isformal: bool)
2130: ~(isglobal: bool)
2131: (ldecl : location)
2132: (bt, sto, inline, attrs)
2133: (n,ndt,a)
2134: : varinfo =
2135: let vtype, nattr =
2136: doType (AttrName false) bt (A.PARENTYPE(attrs, ndt, a)) in
2137: if inline && not (isFunctionType vtype) then
2138: ignore (error "inline for a non-function: %s" n);
2139: let t =
2140: if not isglobal && not isformal then begin
2141: (* Sometimes we call this on the formal argument of a function with no
2142: * arguments. Don't call stripConstLocalType in that case *)
2143: (* ignore (E.log "stripConstLocalType(%a) for %s\n" d_type vtype n); *)
2144: stripConstLocalType vtype
2145: end else
2146: vtype
2147: in
2148: let vi = makeVarinfo isglobal n t in
2149: vi.vstorage <- sto;
2150: vi.vattr <- nattr;
2151: vi.vdecl <- ldecl;
2152: (* ignore (E.log "Created local %s : %a\n" vi.vname d_type vi.vtype); *)
2153: vi
2154:
2155: (* Process a local variable declaration and allow variable-sized arrays *)
2156: and makeVarSizeVarInfo (ldecl : location)
2157: spec_res
2158: (n,ndt,a)
2159: : varinfo * chunk * exp * bool =
2160: if not !msvcMode then
2161: match isVariableSizedArray ndt with
2162: None ->
2163: makeVarInfoFlx_cil_cabs ~isformal:false
2164: ~isglobal:false
2165: ldecl spec_res (n,ndt,a), empty, zero, false
2166: | Some (ndt', se, len) ->
2167: makeVarInfoFlx_cil_cabs ~isformal:false
2168: ~isglobal:false
2169: ldecl spec_res (n,ndt',a), se, len, true
2170: else
2171: makeVarInfoFlx_cil_cabs ~isformal:false
2172: ~isglobal:false
2173: ldecl spec_res (n,ndt,a), empty, zero, false
2174:
2175: and doAttr (a: A.attribute) : attribute list =
2176: (* Strip the leading and trailing underscore *)
2177: let stripUnderscore (n: string) : string =
2178: let l = String.length n in
2179: let rec start i =
2180: if i >= l then
2181: E.s (error "Invalid attribute name %s" n);
2182: if String.get n i = '_' then start (i + 1) else i
2183: in
2184: let st = start 0 in
2185: let rec finish i =
2186: (* We know that we will stop at >= st >= 0 *)
2187: if String.get n i = '_' then finish (i - 1) else i
2188: in
2189: let fin = finish (l - 1) in
2190: String.sub n st (fin - st + 1)
2191: in
2192: match a with
2193: (* ("restrict", []) -> [] *)
2194: | (s, []) -> [Attr (stripUnderscore s, [])]
2195: | (s, el) ->
2196: let rec attrOfExp (strip: bool) (a: A.expression) : attrparam =
2197: match a with
2198: A.VARIABLE n -> begin
2199: let n' = if strip then stripUnderscore n else n in
2200: (** See if this is an enumeration *)
2201: try
2202: match H.find env n' with
2203: EnvEnum (tag, _), _ -> begin
2204: match isInteger (constFold true tag) with
2205: Some i64 -> AInt (Int64.to_int i64)
2206: | _ -> ACons(n', [])
2207: end
2208: | _ -> ACons (n', [])
2209: with Not_found -> ACons(n', [])
2210: end
2211: | A.CONSTANT (A.CONST_STRING s) -> AStr s
2212: | A.CONSTANT (A.CONST_INT str) -> AInt (int_of_string str)
2213: | A.CALL(A.VARIABLE n, args) -> begin
2214: let n' = if strip then stripUnderscore n else n in
2215: let ae' = List.map ae args in
2216: ACons(n', ae')
2217: end
2218: | A.EXPR_SIZEOF e -> ASizeOfE (ae e)
2219: | A.TYPE_SIZEOF (bt, dt) -> ASizeOf (doOnlyType bt dt)
2220: | A.EXPR_ALIGNOF e -> AAlignOfE (ae e)
2221: | A.TYPE_ALIGNOF (bt, dt) -> AAlignOf (doOnlyType bt dt)
2222: | A.BINARY(A.AND, aa1, aa2) ->
2223: ABinOp(LAnd, ae aa1, ae aa2)
2224: | A.BINARY(A.OR, aa1, aa2) ->
2225: ABinOp(LOr, ae aa1, ae aa2)
2226: | A.BINARY(abop, aa1, aa2) ->
2227: ABinOp (convBinOp abop, ae aa1, ae aa2)
2228: | A.UNARY(A.PLUS, aa) -> ae aa
2229: | A.UNARY(A.MINUS, aa) -> AUnOp (Neg, ae aa)
2230: | A.UNARY(A.BNOT, aa) -> AUnOp(BNot, ae aa)
2231: | A.UNARY(A.NOT, aa) -> AUnOp(LNot, ae aa)
2232: | A.MEMBEROF (e, s) -> ADot (ae e, s)
2233: | _ ->
2234: ignore (E.log "Invalid expression in attribute: ");
2235: withFlx_cil_cprint Flx_cil_cprint.print_expression a;
2236: E.s (error "cabs2cil: invalid expression")
2237:
2238: and ae (e: A.expression) = attrOfExp false e
2239: in
2240: (* Sometimes we need to convert attrarg into attr *)
2241: let arg2attr = function
2242: | ACons (s, args) -> Attr (s, args)
2243: | a ->
2244: E.s (error "Invalid form of attribute: %a"
2245: d_attrparam a);
2246: in
2247: if s = "__attribute__" then (* Just a wrapper for many attributes*)
2248: List.map (fun e -> arg2attr (attrOfExp true e)) el
2249: else if s = "__blockattribute__" then (* Another wrapper *)
2250: List.map (fun e -> arg2attr (attrOfExp true e)) el
2251: else if s = "__declspec" then
2252: List.map (fun e -> arg2attr (attrOfExp false e)) el
2253: else
2254: [Attr(stripUnderscore s, List.map (attrOfExp false) el)]
2255:
2256: and doAttributes (al: A.attribute list) : attribute list =
2257: List.fold_left (fun acc a -> cabsAddAttributes (doAttr a) acc) [] al
2258:
2259:
2260:
2261: and doType (nameortype: attributeClass) (* This is AttrName if we are doing
2262: * the type for a name, or AttrType
2263: * if we are doing this type in a
2264: * typedef *)
2265: (bt: typ) (* The base type *)
2266: (dt: A.decl_type)
2267: (* Returns the new type and the accumulated name (or type attribute
2268: if nameoftype = AttrType) attributes *)
2269: : typ * attribute list =
2270:
2271: (* Now do the declarator type. But remember that the structure of the
2272: * declarator type is as printed, meaning that it is the reverse of the
2273: * right one *)
2274: let rec doDeclType (bt: typ) (acc: attribute list) = function
2275: A.JUSTBASE -> bt, acc
2276: | A.PARENTYPE (a1, d, a2) ->
2277: let a1' = doAttributes a1 in
2278: let a1n, a1f, a1t = partitionAttributes AttrType a1' in
2279: let a2' = doAttributes a2 in
2280: let a2n, a2f, a2t = partitionAttributes nameortype a2' in
2281: let bt' = cabsTypeAddAttributes a1t bt in
2282: let bt'', a1fadded =
2283: match unrollType bt with
2284: TFun _ -> cabsTypeAddAttributes a1f bt', true
2285: | _ -> bt', false
2286: in
2287: (* Now recurse *)
2288: let restyp, nattr = doDeclType bt'' acc d in
2289: (* Add some more type attributes *)
2290: let restyp = cabsTypeAddAttributes a2t restyp in
2291: (* See if we can add some more type attributes *)
2292: let restyp' =
2293: match unrollType restyp with
2294: TFun _ ->
2295: if a1fadded then
2296: cabsTypeAddAttributes a2f restyp
2297: else
2298: cabsTypeAddAttributes a2f
2299: (cabsTypeAddAttributes a1f restyp)
2300: | TPtr ((TFun _ as tf), ap) when not !msvcMode ->
2301: if a1fadded then
2302: TPtr(cabsTypeAddAttributes a2f tf, ap)
2303: else
2304: TPtr(cabsTypeAddAttributes a2f
2305: (cabsTypeAddAttributes a1f tf), ap)
2306: | _ ->
2307: if a1f <> [] && not a1fadded then
2308: E.s (error "Invalid position for (prefix) function type attributes:%a"
2309: d_attrlist a1f);
2310: if a2f <> [] then
2311: E.s (error "Invalid position for (post) function type attributes:%a"
2312: d_attrlist a2f);
2313: restyp
2314: in
2315: (* Now add the name attributes and return *)
2316: restyp', cabsAddAttributes a1n (cabsAddAttributes a2n nattr)
2317:
2318: | A.PTR (al, d) ->
2319: let al' = doAttributes al in
2320: let an, af, at = partitionAttributes AttrType al' in
2321: (* Now recurse *)
2322: let restyp, nattr = doDeclType (TPtr(bt, at)) acc d in
2323: (* See if we can do anything with function type attributes *)
2324: let restyp' =
2325: match unrollType restyp with
2326: TFun _ -> cabsTypeAddAttributes af restyp
2327: | TPtr((TFun _ as tf), ap) ->
2328: TPtr(cabsTypeAddAttributes af tf, ap)
2329: | _ ->
2330: if af <> [] then
2331: E.s (error "Invalid position for function type attributes:%a"
2332: d_attrlist af);
2333: restyp
2334: in
2335: (* Now add the name attributes and return *)
2336: restyp', cabsAddAttributes an nattr
2337:
2338:
2339: | A.ARRAY (d, al, len) ->
2340: let lo =
2341: (* JMS:
2342: Cil fails on sizeof() in constants .. we don't
2343: actually care so just make all arrays unknown length
2344: None
2345: *)
2346: match len with
2347: A.NOTHING -> None
2348: | _ ->
2349: let len' = doPureExp len in
2350: let _, len'' = castTo (typeOf len') intType len' in
2351: Some len''
2352: in
2353: let al' = doAttributes al in
2354: doDeclType (TArray(bt, lo, al')) acc d
2355:
2356: | A.PROTO (d, args, isva) ->
2357: (* Start a scope for the parameter names *)
2358: enterScope ();
2359: (* Intercept the old-style use of varargs.h. On GCC this means that
2360: * we have ellipsis and a last argument "builtin_va_alist:
2361: * builtin_va_alist_t". On MSVC we do not have the ellipsis and we
2362: * have a last argument "va_alist: va_list" *)
2363: let args', isva' =
2364: if args != [] && !msvcMode = not isva then begin
2365: let newisva = ref isva in
2366: let rec doLast = function
2367: [([A.SpecType (A.Tnamed atn)], (an, A.JUSTBASE, [], _))]
2368: when isOldStyleVarArgTypeName atn &&
2369: isOldStyleVarArgName an -> begin
2370: (* Turn it into a vararg *)
2371: newisva := true;
2372: (* And forget about this argument *)
2373: []
2374: end
2375:
2376: | a :: rest -> a :: doLast rest
2377: | [] -> []
2378: in
2379: let args' = doLast args in
2380: (args', !newisva)
2381: end else (args, isva)
2382: in
2383: (* Make the argument as for a formal *)
2384: let doOneArg (s, (n, ndt, a, cloc)) : varinfo =
2385: let s' = doSpecList n s in
2386: makeVarInfoFlx_cil_cabs ~isformal:true ~isglobal:false (convLoc cloc) s' (n,ndt,a)
2387: in
2388: let targs : varinfo list option =
2389: match List.map doOneArg args' with
2390: | [] -> None (* No argument list *)
2391: | [t] when (match t.vtype with TVoid _ -> true | _ -> false) ->
2392: Some []
2393: | l -> Some l
2394: in
2395: exitScope ();
2396: (* Turn [] types into pointers in the arguments and the result type.
2397: * Turn function types into pointers to respective. This simplifies
2398: * our life a lot, and is what the standard requires. *)
2399: let rec fixupArgumentTypes (argidx: int) (args: varinfo list) : unit =
2400: match args with
2401: [] -> ()
2402: | a :: args' ->
2403: (match unrollType a.vtype with
2404: TArray(t,_,attr) -> a.vtype <- TPtr(t, attr)
2405: | TFun _ -> a.vtype <- TPtr(a.vtype, [])
2406: | TComp (comp, _) as t -> begin
2407: match isTransparentUnion a.vtype with
2408: None -> ()
2409: | Some fstfield ->
2410: transparentUnionArgs :=
2411: (argidx, a.vtype) :: !transparentUnionArgs;
2412: a.vtype <- fstfield.ftype;
2413: end
2414: | _ -> ());
2415: fixupArgumentTypes (argidx + 1) args'
2416: in
2417: let args =
2418: match targs with
2419: None -> None
2420: | Some argl ->
2421: fixupArgumentTypes 0 argl;
2422: Some (List.map (fun a -> (a.vname, a.vtype, a.vattr)) argl)
2423: in
2424: let tres =
2425: match unrollType bt with
2426: TArray(t,_,attr) -> TPtr(t, attr)
2427: | _ -> bt
2428: in
2429: doDeclType (TFun (tres, args, isva', [])) acc d
2430:
2431: in
2432: doDeclType bt [] dt
2433:
2434: (* If this is a declarator for a variable size array then turn it into a
2435: pointer type and a length *)
2436: and isVariableSizedArray (dt: A.decl_type)
2437: : (A.decl_type * chunk * exp) option =
2438: let res = ref None in
2439: let rec findArray = function
2440: ARRAY (JUSTBASE, al, lo) when lo != A.NOTHING ->
2441: (* Allow non-constant expressions *)
2442: let (se, e', _) = doExp false lo (AExp (Some intType)) in
2443: if isNotEmpty se || not (isConstant e') then begin
2444: res := Some (se, e');
2445: PTR (al, JUSTBASE)
2446: end else
2447: ARRAY (JUSTBASE, al, lo)
2448: | ARRAY (dt, al, lo) -> ARRAY (findArray dt, al, lo)
2449: | PTR (al, dt) -> PTR (al, findArray dt)
2450: | JUSTBASE -> JUSTBASE
2451: | PARENTYPE (prea, dt, posta) -> PARENTYPE (prea, findArray dt, posta)
2452: | PROTO (dt, f, a) -> PROTO (findArray dt, f, a)
2453: in
2454: let dt' = findArray dt in
2455: match !res with
2456: None -> None
2457: | Some (se, e) -> Some (dt', se, e)
2458:
2459: and doOnlyType (specs: A.spec_elem list) (dt: A.decl_type) : typ =
2460: let bt',sto,inl,attrs = doSpecList "" specs in
2461: if sto <> NoStorage || inl then
2462: E.s (error "Storage or inline specifier in type only");
2463: let tres, nattr = doType AttrType bt' (A.PARENTYPE(attrs, dt, [])) in
2464: if nattr <> [] then
2465: E.s (error "Name attributes in only_type: %a"
2466: d_attrlist nattr);
2467: tres
2468:
2469:
2470: and makeCompType (isstruct: bool)
2471: (n: string)
2472: (nglist: A.field_group list)
2473: (a: attribute list) =
2474: (* Make a new name for the structure *)
2475: let kind = if isstruct then "struct" else "union" in
2476: let n', _ = newAlphaName true kind n in
2477: (* Create the self cell for use in fields and forward references. Or maybe
2478: * one exists already from a forward reference *)
2479: let comp, _ = createCompInfo isstruct n' in
2480: let doFieldGroup ((s: A.spec_elem list),
2481: (nl: (A.name * A.expression option) list)) : 'a list =
2482: (* Do the specifiers exactly once *)
2483: let sugg = match nl with
2484: [] -> ""
2485: | ((n, _, _, _), _) :: _ -> n
2486: in
2487: let bt, sto, inl, attrs = doSpecList sugg s in
2488: (* Do the fields *)
2489: let makeFieldInfo
2490: (((n,ndt,a,cloc) : A.name), (widtho : A.expression option))
2491: : fieldinfo =
2492: if sto <> NoStorage && sto <> Static || inl then
2493: E.s (error "Non-static Storage or inline not allowed for fields");
2494: let ftype, nattr =
2495: doType (AttrName false) bt (A.PARENTYPE(attrs, ndt, a)) in
2496: let width =
2497: match widtho with
2498: None -> None
2499: | Some w -> begin
2500: (match unrollType ftype with
2501: TInt (ikind, a) -> ()
2502: | TEnum _ -> ()
2503: | _ -> E.s (error "Base type for bitfield is not an integer type"));
2504: match isIntegerConstant w with
2505: Some n -> Some n
2506: | None -> E.s (error "bitfield width is not an integer constant")
2507: end
2508: in
2509: (* If the field is unnamed and its type is a structure of union type
2510: * then give it a distinguished name *)
2511: let n' =
2512: if n = missingFieldName then begin
2513: match unrollType ftype with
2514: TComp _ -> begin
2515: incr annonCompFieldNameId;
2516: annonCompFieldName ^ (string_of_int !annonCompFieldNameId)
2517: end
2518: | _ -> n
2519: end else
2520: n
2521: in
2522: { fcomp = comp;
2523: fname = n';
2524: ftype = ftype;
2525: fbitfield = width;
2526: fattr = nattr;
2527: floc = convLoc cloc;
2528: fstorage = sto
2529: }
2530: in
2531: List.map makeFieldInfo nl
2532: in
2533:
2534:
2535: let flds = List.concat (List.map doFieldGroup nglist) in
2536: if comp.cfields <> [] then begin
2537: (* This appears to be a multiply defined structure. This can happen from
2538: * a construct like "typedef struct foo { ... } A, B;". This is dangerous
2539: * because at the time B is processed some forward references in { ... }
2540: * appear as backward references, which coild lead to circularity in
2541: * the type structure. We do a thourough check and then we reuse the type
2542: * for A *)
2543: let fieldsSig fs = List.map (fun f -> typeSig f.ftype) fs in
2544: if fieldsSig comp.cfields <> fieldsSig flds then
2545: ignore (error "%s seems to be multiply defined" (compFullName comp))
2546: end else
2547: comp.cfields <- flds;
2548:
2549: (* ignore (E.log "makeComp: %s: %a\n" comp.cname d_attrlist a); *)
2550: comp.cattr <- a;
2551: let toplevel_typedef = false in
2552: let res = TComp (comp, []) in
2553: (* This compinfo is defined, even if there are no fields *)
2554: comp.cdefined <- true;
2555: (* Create a typedef for this one *)
2556: cabsPushGlobal (GCompTag (comp, !currentLoc));
2557:
2558: (* There must be a self cell created for this already *)
2559: addLocalToEnv (kindPlusName kind n) (EnvTyp res);
2560: (* Now create a typedef with just this type *)
2561: res
2562:
2563: and preprocessCast (specs: A.specifier)
2564: (dt: A.decl_type)
2565: (ie: A.init_expression)
2566: : A.specifier * A.decl_type * A.init_expression =
2567: let typ = doOnlyType specs dt in
2568: (* If we are casting to a union type then we have to treat this as a
2569: * constructor expression. This is to handle the gcc extension that allows
2570: * cast from a type of a field to the type of the union *)
2571: let ie' =
2572: match unrollType typ, ie with
2573: TComp (c, _), A.SINGLE_INIT _ when not c.cstruct ->
2574: A.COMPOUND_INIT [(A.INFIELD_INIT ("___matching_field",
2575: A.NEXT_INIT),
2576: ie)]
2577: | _, _ -> ie
2578: in
2579: (* Maybe specs contains an unnamed composite. Replace with the name so that
2580: * when we do again the specs we get the right name *)
2581: let specs1 =
2582: match typ with
2583: TComp (ci, _) ->
2584: List.map
2585: (function
2586: A.SpecType (A.Tstruct ("", flds, [])) ->
2587: A.SpecType (A.Tstruct (ci.cname, None, []))
2588: | A.SpecType (A.Tunion ("", flds, [])) ->
2589: A.SpecType (A.Tunion (ci.cname, None, []))
2590: | s -> s) specs
2591: | _ -> specs
2592: in
2593: specs1, dt, ie'
2594:
2595: and isIntConstExp (aexp) : exp option =
2596: match doExp true aexp (AExp None) with
2597: (* first, filter for those Const exps that are integers *)
2598: | (c, (Const (CInt64 (i,_,_)) as p),_) when isEmpty c ->
2599: Some p
2600: | (c, (Const (CChr i) as p),_) when isEmpty c ->
2601: Some p
2602: (* other Const expressions are not ok *)
2603: | (_, (Const _), _) ->
2604: None
2605: (* now, anything else that 'doExp true' returned is ok (provided
2606: that it didn't yield side effects); this includes, in particular,
2607: the various sizeof and alignof expression kinds *)
2608: | (c, e, _) when isEmpty c ->
2609: Some e
2610: (* we only get here when the expression had side effects *)
2611: | _ ->
2612: None
2613:
2614: (* this is like 'isIntConstExp', but retrieves the actual integer
2615: * the expression denotes; I have not extended it to work with
2616: * sizeof/alignof since (for CCured) we can't const-eval those,
2617: * and it's not clear whether they can be bitfield width specifiers
2618: * anyway (since that's where this function is used) *)
2619: and isIntegerConstant (aexp) : int option =
2620: match doExp true aexp (AExp None) with
2621: (c, (Const (CInt64 (i,_,_)) as p),_) when isEmpty c ->
2622: Some (Int64.to_int i)
2623: | (c, (Const (CChr i) as p),_) when isEmpty c ->
2624: Some (Char.code i)
2625: | _ -> None
2626:
2627: (* Process an expression and in the process do some type checking,
2628: * extract the effects as separate statements *)
2629: and doExp (isconst: bool) (* In a constant *)
2630: (e: A.expression)
2631: (what: expAction) : (chunk * exp * typ) =
2632: (* A subexpression of array type is automatically turned into StartOf(e).
2633: * Similarly an expression of function type is turned into AddrOf. So
2634: * essentially doExp should never return things of type TFun or TArray *)
2635: let processArrayFun e t =
2636: match e, unrollType t with
2637: (Lval(lv) | CastE(_, Lval lv)), TArray(tbase, _, a) ->
2638: mkStartOfAndMark lv, TPtr(tbase, a)
2639: | (Lval(lv) | CastE(_, Lval lv)), TFun _ ->
2640: mkAddrOfAndMark lv, TPtr(t, [])
2641: | _, (TArray _ | TFun _) ->
2642: E.s (error "Array or function expression is not lval: %a@!"
2643: d_plainexp e)
2644: | _ -> e, t
2645: in
2646: (* Before we return we call finishExp *)
2647: let finishExp ?(newWhat=what)
2648: (se: chunk) (e: exp) (t: typ) : chunk * exp * typ =
2649: match newWhat with
2650: ADrop -> (se, e, t)
2651: | AExpLeaveArrayFun ->
2652: (se, e, t) (* It is important that we do not do "processArrayFun" in
2653: * this case. We exploit this when we process the typeOf
2654: * construct *)
2655: | AExp _ ->
2656: let (e', t') = processArrayFun e t in
2657: (se, e', t')
2658:
2659: | ASet (lv, lvt) -> begin
2660: (* See if the set was done already *)
2661: match e with
2662: Lval(lv') when lv == lv' ->
2663: (se, e, t)
2664: | _ ->
2665: let (e', t') = processArrayFun e t in
2666: let (t'', e'') = castTo t' lvt e' in
2667: (*
2668: ignore (E.log "finishExp: e = %a\n e'' = %a\n" d_plainexp e d_plainexp e'');
2669: *)
2670: (se +++ (Set(lv, e'', !currentLoc)), e'', t'')
2671: end
2672: in
2673: let rec findField (n: string) (fidlist: fieldinfo list) : offset * typ =
2674: (* Depth first search for the field. This appears to be what GCC does.
2675: * MSVC checks that there are no ambiguous field names, so it does not
2676: * matter how we search *)
2677: let rec search = function
2678: [] -> NoOffset, voidType (* Did not find *)
2679: | fid :: rest when fid.fname = n -> Field(fid, NoOffset), fid.ftype
2680: | fid :: rest when prefix annonCompFieldName fid.fname -> begin
2681: match unrollType fid.ftype with
2682: TComp (ci, _) ->
2683: let off, t = search ci.cfields in
2684: if off = NoOffset then
2685: search rest (* Continue searching *)
2686: else
2687: Field (fid, off), t
2688: | _ -> E.s (bug "unnamed field type is not a struct/union")
2689: end
2690: | _ :: rest -> search rest
2691: in
2692: let off, t = search fidlist in
2693: if off = NoOffset then
2694: E.s (error "Cannot find field %s" n);
2695: off, t
2696: in
2697: try
2698: match e with
2699: | A.NOTHING when what = ADrop -> finishExp empty (integer 0) intType
2700: | A.NOTHING ->
2701: let res = Const(CStr "exp_nothing") in
2702: finishExp empty res (typeOf res)
2703:
2704: (* Do the potential lvalues first *)
2705: | A.VARIABLE n -> begin
2706: (* Look up in the environment *)
2707: try
2708: let envdata = H.find env n in
2709: match envdata with
2710: EnvVar vi, _ ->
2711: if isconst &&
2712: not (isFunctionType vi.vtype) &&
2713: not (isArrayType vi.vtype)then
2714: E.s (error "variable appears in constant");
2715: finishExp empty (Lval(var vi)) vi.vtype
2716: | EnvEnum (tag, typ), _ ->
2717: finishExp empty tag typ
2718: | _ -> raise Not_found
2719: with Not_found -> begin
2720: if isOldStyleVarArgName n then
2721: E.s (error "Cannot resolve variable %s. This could be a CIL bug due to the handling of old-style variable argument functions.\n" n)
2722: else
2723: E.s (error "Cannot resolve variable %s.\n" n)
2724: end
2725: end
2726: | A.INDEX (e1, e2) -> begin
2727: (* Recall that doExp turns arrays into StartOf pointers *)
2728: let (se1, e1', t1) = doExp false e1 (AExp None) in
2729: let (se2, e2', t2) = doExp false e2 (AExp None) in
2730: let se = se1 @@ se2 in
2731: let (e1'', t1, e2'', tresult) =
2732: (* Either e1 or e2 can be the pointer *)
2733: match unrollType t1, unrollType t2 with
2734: TPtr(t1e,_), (TInt _|TEnum _) -> e1', t1, e2', t1e
2735: | (TInt _|TEnum _), TPtr(t2e,_) -> e2', t2, e1', t2e
2736: | _ ->
2737: E.s (error
2738: "Expecting a pointer type in index:@! t1=%a@!t2=%a@!"
2739: d_plaintype t1 d_plaintype t2)
2740: in
2741: (* We have to distinguish the construction based on the type of e1'' *)
2742: let res =
2743: match e1'' with
2744: StartOf array -> (* A real array indexing operation *)
2745: addOffsetLval (Index(e2'', NoOffset)) array
2746: | _ -> (* Turn into *(e1 + e2) *)
2747: mkMem (BinOp(IndexPI, e1'', e2'', t1)) NoOffset
2748: in
2749: (* Do some optimization of StartOf *)
2750: finishExp se (Lval res) tresult
2751:
2752: end
2753: | A.UNARY (A.MEMOF, e) ->
2754: if isconst then
2755: E.s (error "MEMOF in constant");
2756: let (se, e', t) = doExp false e (AExp None) in
2757: let tresult =
2758: match unrollType t with
2759: | TPtr(te, _) -> te
2760: | _ -> E.s (error "Expecting a pointer type in *. Got %a@!"
2761: d_plaintype t)
2762: in
2763: finishExp se
2764: (Lval (mkMem e' NoOffset))
2765: tresult
2766:
2767: (* e.str = (& e + off(str)). If e = (be + beoff) then e.str = (be
2768: * + beoff + off(str)) *)
2769: | A.MEMBEROF (e, str) ->
2770: (* member of is actually allowed if we only take the address *)
2771: (* if isconst then
2772: E.s (error "MEMBEROF in constant"); *)
2773: let (se, e', t') = doExp false e (AExp None) in
2774: let lv =
2775: match e' with
2776: Lval x -> x
2777: | CastE(_, Lval x) -> x
2778: | _ -> E.s (error "Expected an lval in MEMBEROF (field %s)" str)
2779: in
2780: let field_offset, field_type =
2781: match unrollType t' with
2782: TComp (comp, _) -> findField str comp.cfields
2783: | _ -> E.s (error "expecting a struct with field %s" str)
2784: in
2785: let lv' = Lval(addOffsetLval field_offset lv) in
2786: finishExp se lv' field_type
2787:
2788: (* e->str = * (e + off(str)) *)
2789: | A.MEMBEROFPTR (e, str) ->
2790: if isconst then
2791: E.s (error "MEMBEROFPTR in constant");
2792: let (se, e', t') = doExp false e (AExp None) in
2793: let pointedt =
2794: match unrollType t' with
2795: TPtr(t1, _) -> t1
2796: | TArray(t1,_,_) -> t1
2797: | _ -> E.s (error "expecting a pointer to a struct")
2798: in
2799: let field_offset, field_type =
2800: match unrollType pointedt with
2801: TComp (comp, _) -> findField str comp.cfields
2802: | x ->
2803: E.s (error
2804: "expecting a struct with field %s. Found %a. t1 is %a"
2805: str d_type x d_type t')
2806: in
2807: finishExp se (Lval (mkMem e' field_offset)) field_type
2808:
2809:
2810: | A.CONSTANT ct -> begin
2811: let hasSuffix str =
2812: let l = String.length str in
2813: fun s ->
2814: let ls = String.length s in
2815: l >= ls && s = String.uppercase (String.sub str (l - ls) ls)
2816: in
2817: match ct with
2818: A.CONST_INT str -> begin
2819: let res = parseInt str in
2820: finishExp empty res (typeOf res)
2821: end
2822:
2823: (*
2824: | A.CONST_WSTRING wstr ->
2825: let len = List.length wstr in
2826: let wchar_t = !wcharType in
2827: (* We will make an array big enough to contain the wide
2828: * characters and the wide-null terminator *)
2829: let ws_t = TArray(wchar_t, Some (integer len), []) in
2830: let ws =
2831: makeGlobalVar ("wide_string" ^ string_of_int !lastStructId)
2832: ws_t
2833: in
2834: ws.vstorage <- Static;
2835: incr lastStructId;
2836: (* Make the initializer. Idx is a wide_char index. *)
2837: let rec loop (idx: int) (s: int64 list) =
2838: match s with
2839: [] -> []
2840: | wc::rest ->
2841: let wc_cilexp = Const (CInt64(wc, IInt, None)) in
2842: (Index(integer idx, NoOffset),
2843: SingleInit (mkCast wc_cilexp wchar_t))
2844: :: loop (idx + 1) rest
2845: in
2846: (* Add the definition for the array *)
2847: cabsPushGlobal (GVar(ws,
2848: {init = Some (CompoundInit(ws_t,
2849: loop 0 wstr))},
2850: !currentLoc));
2851: finishExp empty (StartOf(Var ws, NoOffset))
2852: (TPtr(wchar_t, []))
2853: *)
2854:
2855: | A.CONST_WSTRING (ws: int64 list) ->
2856: (* takes a list of strings, and converts it to a WIDE string. *)
2857: let intlist_to_wstring (str: int64 list) : string =
2858: (* L"\xabcd" "e" must to go
2859: L"\xabcd\x65" and NOT L"\xabcde" *)
2860: let rec loop lst must_escape = match lst with
2861: [] -> "" (* "\000" GN: nul-termination is implicit *)
2862: | hd :: tl ->
2863: let must_escape_now = must_escape ||
2864: (compare hd (Int64.of_int 255) > 0) ||
2865: (compare hd Int64.zero < 0) in
2866: let this_piece =
2867: if must_escape_now then
2868: Printf.sprintf "\\x%Lx" hd
2869: else
2870: String.make 1 (Char.chr (Int64.to_int hd))
2871: in
2872: this_piece ^ (loop tl must_escape_now)
2873: in loop str false
2874: in
2875: let res = Const(CWStr ((* intlist_to_wstring *) ws)) in
2876: finishExp empty res (typeOf res)
2877:
2878: | A.CONST_STRING s ->
2879: (* Maybe we burried __FUNCTION__ in there *)
2880: let s' =
2881: try
2882: let start = String.index s (Char.chr 0) in
2883: let l = String.length s in
2884: let tofind = (String.make 1 (Char.chr 0)) ^ "__FUNCTION__" in
2885: let past = start + String.length tofind in
2886: if past <= l &&
2887: String.sub s start (String.length tofind) = tofind then
2888: (if start > 0 then String.sub s 0 start else "") ^
2889: !currentFunctionFDEC.svar.vname ^
2890: (if past < l then String.sub s past (l - past) else "")
2891: else
2892: s
2893: with Not_found -> s
2894: in
2895: let res = Const(CStr s') in
2896: finishExp empty res (typeOf res)
2897:
2898: | A.CONST_CHAR char_list ->
2899: let a, b = (interpret_character_constant char_list) in
2900: finishExp empty (Const a) b
2901:
2902: | A.CONST_WCHAR char_list ->
2903: let value = reduce_multichar !wcharType char_list in
2904: let result = kinteger64 !wcharKind value in
2905: finishExp empty result (typeOf result)
2906:
2907: | A.CONST_FLOAT str -> begin
2908: (* Maybe it ends in U or UL. Strip those *)
2909: let l = String.length str in
2910: let hasSuffix = hasSuffix str in
2911: let baseint, kind =
2912: if hasSuffix "L" then
2913: String.sub str 0 (l - 1), FLongDouble
2914: else if hasSuffix "F" then
2915: String.sub str 0 (l - 1), FFloat
2916: else if hasSuffix "D" then
2917: String.sub str 0 (l - 1), FDouble
2918: else
2919: str, FDouble
2920: in
2921: try
2922: finishExp empty
2923: (Const(CReal(float_of_string baseint, kind,
2924: Some str)))
2925: (TFloat(kind,[]))
2926: with e -> begin
2927: ignore (E.log "float_of_string %s (%s)\n" str
2928: (Printexc.to_string e));
2929: let res = Const(CStr "booo CONS_FLOAT") in
2930: finishExp empty res (typeOf res)
2931: end
2932: end
2933: end
2934:
2935: | A.TYPE_SIZEOF (bt, dt) ->
2936: let typ = doOnlyType bt dt in
2937: finishExp empty (SizeOf(typ)) !typeOfSizeOf
2938:
2939: (* Intercept the sizeof("string") *)
2940: | A.EXPR_SIZEOF (A.CONSTANT (A.CONST_STRING s)) -> begin
2941: (* Process the string first *)
2942: match doExp isconst (A.CONSTANT (A.CONST_STRING s)) (AExp None) with
2943: _, Const(CStr s), _ ->
2944: finishExp empty (SizeOfStr s) !typeOfSizeOf
2945: | _ -> E.s (bug "cabs2cil: sizeOfStr")
2946: end
2947:
2948: | A.EXPR_SIZEOF e ->
2949: (* Allow non-constants in sizeof *)
2950: (* Do not convert arrays and functions into pointers *)
2951: let (se, e', t) = doExp false e AExpLeaveArrayFun in
2952: (* !!!! The book says that the expression is not evaluated, so we
2953: * drop the potential side-effects
2954: if isNotEmpty se then
2955: ignore (warn "Warning: Dropping side-effect in EXPR_SIZEOF\n");
2956: *)
2957: let size =
2958: match e' with (* If we are taking the sizeof an
2959: * array we must drop the StartOf *)
2960: StartOf(lv) -> SizeOfE (Lval(lv))
2961:
2962: (* Maybe we are taking the sizeof for a CStr. In that case we
2963: * mean the pointer to the start of the string *)
2964: | Const(CStr _) -> SizeOf (charPtrType)
2965:
2966: (* Maybe we are taking the sizeof a variable-sized array *)
2967: | Lval (Var vi, NoOffset) -> begin
2968: try
2969: H.find varSizeArrays vi.vid
2970: with Not_found -> SizeOfE e'
2971: end
2972: | _ -> SizeOfE e'
2973: in
2974: finishExp empty size !typeOfSizeOf
2975:
2976: | A.TYPE_ALIGNOF (bt, dt) ->
2977: let typ = doOnlyType bt dt in
2978: finishExp empty (AlignOf(typ)) !typeOfSizeOf
2979:
2980: | A.EXPR_ALIGNOF e ->
2981: let (se, e', t) = doExp false e AExpLeaveArrayFun in
2982: (* !!!! The book says that the expression is not evaluated, so we
2983: * drop the potential side-effects
2984: if isNotEmpty se then
2985: ignore (warn "Warning: Dropping side-effect in EXPR_ALIGNOF\n");
2986: *)
2987: let e'' =
2988: match e' with (* If we are taking the alignof an
2989: * array we must drop the StartOf *)
2990: StartOf(lv) -> Lval(lv)
2991:
2992: | _ -> e'
2993: in
2994: finishExp empty (AlignOfE(e'')) !typeOfSizeOf
2995:
2996: | A.CAST ((specs, dt), ie) ->
2997: let s', dt', ie' = preprocessCast specs dt ie in
2998: (* We know now that we can do s' and dt' many times *)
2999: let typ = doOnlyType s' dt' in
3000: let what' =
3001: match what with
3002: AExp (Some _) -> AExp (Some typ)
3003: | AExp None -> what
3004: | ADrop | AExpLeaveArrayFun -> what
3005: | ASet (lv, lvt) ->
3006: (* If the cast from typ to lvt would be dropped, then we
3007: * continue with a Set *)
3008: if false && typeSig typ = typeSig lvt then
3009: what
3010: else
3011: AExp None (* We'll create a temporary *)
3012: in
3013: (* Remember here if we have done the Set *)
3014: let (se, e', t') =
3015: match ie' with
3016: A.SINGLE_INIT e -> doExp isconst e what'
3017:
3018: | A.NO_INIT -> E.s (error "missing expression in cast")
3019: | A.COMPOUND_INIT _ -> begin
3020: (* Pretend that we are declaring and initializing a brand new
3021: * variable *)
3022: let newvar = "__constr_expr_" ^ string_of_int (!constrExprId) in
3023: incr constrExprId;
3024: let spec_res = doSpecList "" s' in
3025: let se1 =
3026: if !scopes == [] then begin
3027: ignore (createGlobal spec_res
3028: ((newvar, dt', [], cabslu), ie'));
3029: empty
3030: end else
3031: createLocal spec_res ((newvar, dt', [], cabslu), ie')
3032: in
3033: (* Now pretend that e is just a reference to the newly created
3034: * variable *)
3035: let se, e', t' = doExp isconst (A.VARIABLE newvar) what' in
3036: (* If typ is an array then the doExp above has already added a
3037: * StartOf. We must undo that now so that it is done once by
3038: * the finishExp at the end of this case *)
3039: let e2, t2 =
3040: match unrollType typ, e' with
3041: TArray _, StartOf lv -> Lval lv, typ
3042: | _, _ -> e', t'
3043: in
3044: se1 @@ se, e2, t2
3045: end
3046: in
3047: let (t'', e'') =
3048: match typ with
3049: TVoid _ when what' = ADrop -> (t', e') (* strange GNU thing *)
3050: | _ ->
3051: (* Do this to check the cast *)
3052: let newtyp, newexp = castTo ~fromsource:true t' typ e' in
3053: newtyp, newexp
3054: in
3055: finishExp se e'' t''
3056:
3057: | A.UNARY(A.MINUS, e) ->
3058: let (se, e', t) = doExp isconst e (AExp None) in
3059: if isIntegralType t then
3060: let tres = integralPromotion t in
3061: let e'' =
3062: match e' with
3063: | Const(CInt64(i, ik, _)) -> kinteger64 ik (Int64.neg i)
3064: | _ -> UnOp(Neg, mkCastT e' t tres, tres)
3065: in
3066: finishExp se e'' tres
3067: else
3068: if isArithmeticType t then
3069: finishExp se (UnOp(Neg,e',t)) t
3070: else
3071: E.s (error "Unary - on a non-arithmetic type")
3072:
3073: | A.UNARY(A.BNOT, e) ->
3074: let (se, e', t) = doExp isconst e (AExp None) in
3075: if isIntegralType t then
3076: let tres = integralPromotion t in
3077: let e'' = UnOp(BNot, mkCastT e' t tres, tres) in
3078: finishExp se e'' tres
3079: else
3080: E.s (error "Unary ~ on a non-integral type")
3081:
3082: | A.UNARY(A.PLUS, e) -> doExp isconst e what
3083:
3084:
3085: | A.UNARY(A.ADDROF, e) -> begin
3086: match e with
3087: A.COMMA el -> (* GCC extension *)
3088: doExp false
3089: (A.COMMA (replaceLastInList el (fun e -> A.UNARY(A.ADDROF, e))))
3090: what
3091: | A.QUESTION (e1, e2, e3) -> (* GCC extension *)
3092: doExp false
3093: (A.QUESTION (e1, A.UNARY(A.ADDROF, e2), A.UNARY(A.ADDROF, e3)))
3094: what
3095: | A.VARIABLE s when
3096: isOldStyleVarArgName s
3097: && (match !currentFunctionFDEC.svar.vtype with
3098: TFun(_, _, true, _) -> true | _ -> false) ->
3099: (* We are in an old-style variable argument function and we are
3100: * taking the address of the argument that was removed while
3101: * processing the function type. We compute the address based on
3102: * the address of the last real argument *)
3103: if !msvcMode then begin
3104: let rec getLast = function
3105: [] -> E.s (unimp "old-style variable argument function without real arguments")
3106: | [a] -> a
3107: | _ :: rest -> getLast rest
3108: in
3109: let last = getLast !currentFunctionFDEC.sformals in
3110: let res = mkAddrOfAndMark (var last) in
3111: let tres = typeOf res in
3112: let tres', res' = castTo tres (TInt(IULong, [])) res in
3113: (* Now we must add to this address to point to the next
3114: * argument. Round up to a multiple of 4 *)
3115: let sizeOfLast =
3116: (((bitsSizeOf last.vtype) + 31) / 32) * 4
3117: in
3118: let res'' =
3119: BinOp(PlusA, res', kinteger IULong sizeOfLast, tres')
3120: in
3121: finishExp empty res'' tres'
3122: end else begin (* On GCC the only reliable way to do this is to
3123: * call builtin_next_arg. If we take the address of
3124: * a local we are going to get the address of a copy
3125: * of the local ! *)
3126:
3127: doExp isconst
3128: (A.CALL (A.VARIABLE "__builtin_next_arg",
3129: [A.CONSTANT (A.CONST_INT "0")]))
3130: what
3131: end
3132:
3133: | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *)
3134: A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ |
3135: A.CAST (_, A.COMPOUND_INIT _)) -> begin
3136: let (se, e', t) = doExp false e (AExp None) in
3137: (* ignore (E.log "ADDROF on %a : %a\n" d_plainexp e'
3138: d_plaintype t); *)
3139: match e' with
3140: ( Lval x | CastE(_, Lval x)) ->
3141: finishExp se (mkAddrOfAndMark x) (TPtr(t, []))
3142:
3143: | StartOf (lv) ->
3144: let tres = TPtr(typeOfLval lv, []) in (* pointer to array *)
3145: finishExp se (mkAddrOfAndMark lv) tres
3146:
3147: (* Function names are converted into pointers to the function.
3148: * Taking the address-of again does not change things *)
3149: | AddrOf (Var v, NoOffset) when isFunctionType v.vtype ->
3150: finishExp se e' t
3151:
3152: | _ -> E.s (error "Expected lval for ADDROF. Got %a@!"
3153: d_plainexp e')
3154: end
3155: | _ -> E.s (error "Unexpected operand for addrof")
3156: end
3157: | A.UNARY((A.PREINCR|A.PREDECR) as uop, e) -> begin
3158: match e with
3159: A.COMMA el -> (* GCC extension *)
3160: doExp isconst
3161: (A.COMMA (replaceLastInList el
3162: (fun e -> A.UNARY(uop, e))))
3163: what
3164: | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *)
3165: doExp isconst
3166: (A.QUESTION (e1, A.UNARY(uop, e2q),
3167: A.UNARY(uop, e3q)))
3168: what
3169:
3170: | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *)
3171: A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ |
3172: A.CAST _ (* A GCC extension *)) -> begin
3173: let uop' = if uop = A.PREINCR then PlusA else MinusA in
3174: if isconst then
3175: E.s (error "PREINCR or PREDECR in constant");
3176: let (se, e', t) = doExp false e (AExp None) in
3177: let lv =
3178: match e' with
3179: Lval x -> x
3180: | CastE (_, Lval x) -> x (* A GCC extension. The operation is
3181: * done at the cast type. The result
3182: * is also of the cast type *)
3183: | _ -> E.s (error "Expected lval for ++ or --")
3184: in
3185: let tresult, result = doBinOp uop' e' t one intType in
3186: finishExp (se +++ (Set(lv, mkCastT result tresult t,
3187: !currentLoc)))
3188: e'
3189: tresult (* Should this be t instead ??? *)
3190: end
3191: | _ -> E.s (error "Unexpected operand for prefix -- or ++")
3192: end
3193:
3194: | A.UNARY((A.POSINCR|A.POSDECR) as uop, e) -> begin
3195: match e with
3196: A.COMMA el -> (* GCC extension *)
3197: doExp isconst
3198: (A.COMMA (replaceLastInList el
3199: (fun e -> A.UNARY(uop, e))))
3200: what
3201: | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *)
3202: doExp isconst
3203: (A.QUESTION (e1, A.UNARY(uop, e2q), A.UNARY(uop, e3q)))
3204: what
3205:
3206: | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *)
3207: A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ |
3208: A.CAST _ (* A GCC extension *) ) -> begin
3209: if isconst then
3210: E.s (error "POSTINCR or POSTDECR in constant");
3211: (* If we do not drop the result then we must save the value *)
3212: let uop' = if uop = A.POSINCR then PlusA else MinusA in
3213: let (se, e', t) = doExp false e (AExp None) in
3214: let lv =
3215: match e' with
3216: Lval x -> x
3217: | CastE (_, Lval x) -> x (* GCC extension. The addition must
3218: * be be done at the cast type. The
3219: * result of this is also of the cast
3220: * type *)
3221: | _ -> E.s (error "Expected lval for ++ or --")
3222: in
3223: let tresult, opresult = doBinOp uop' e' t one intType in
3224: let se', result =
3225: if what <> ADrop then
3226: let tmp = newTempVar t in
3227: se +++ (Set(var tmp, e', !currentLoc)), Lval(var tmp)
3228: else
3229: se, e'
3230: in
3231: finishExp
3232: (se' +++ (Set(lv, mkCastT opresult tresult t,
3233: !currentLoc)))
3234: result
3235: tresult (* Should this be t instead ??? *)
3236: end
3237: | _ -> E.s (error "Unexpected operand for suffix ++ or --")
3238: end
3239:
3240: | A.BINARY(A.ASSIGN, e1, e2) -> begin
3241: match e1 with
3242: A.COMMA el -> (* GCC extension *)
3243: doExp isconst
3244: (A.COMMA (replaceLastInList el
3245: (fun e -> A.BINARY(A.ASSIGN, e, e2))))
3246: what
3247: | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *)
3248: doExp isconst
3249: (A.QUESTION (e1, A.BINARY(A.ASSIGN, e2q, e2),
3250: A.BINARY(A.ASSIGN, e3q, e2)))
3251: what
3252: | A.CAST (t, A.SINGLE_INIT e) -> (* GCC extension *)
3253: doExp isconst
3254: (A.CAST (t,
3255: A.SINGLE_INIT (A.BINARY(A.ASSIGN, e,
3256: A.CAST (t, A.SINGLE_INIT e2)))))
3257: what
3258:
3259: | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *)
3260: A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ ) -> begin
3261: if isconst then E.s (error "ASSIGN in constant");
3262: let (se1, e1', lvt) = doExp false e1 (AExp None) in
3263: let lv =
3264: match e1' with
3265: Lval x -> x
3266: | _ -> E.s (error "Expected lval for assignment. Got %a\n"
3267: d_plainexp e1')
3268: in
3269: let (se2, e'', t'') = doExp false e2 (ASet(lv, lvt)) in
3270: finishExp (se1 @@ se2) e1' lvt
3271: end
3272: | _ -> E.s (error "Invalid left operand for ASSIGN")
3273: end
3274:
3275: | A.BINARY((A.ADD|A.SUB|A.MUL|A.DIV|A.MOD|A.BAND|A.BOR|A.XOR|
3276: A.SHL|A.SHR|A.EQ|A.NE|A.LT|A.GT|A.GE|A.LE) as bop, e1, e2) ->
3277: let bop' = convBinOp bop in
3278: let (se1, e1', t1) = doExp isconst e1 (AExp None) in
3279: let (se2, e2', t2) = doExp isconst e2 (AExp None) in
3280: let tresult, result = doBinOp bop' e1' t1 e2' t2 in
3281: finishExp (se1 @@ se2) result tresult
3282:
3283: (* assignment operators *)
3284: | A.BINARY((A.ADD_ASSIGN|A.SUB_ASSIGN|A.MUL_ASSIGN|A.DIV_ASSIGN|
3285: A.MOD_ASSIGN|A.BAND_ASSIGN|A.BOR_ASSIGN|A.SHL_ASSIGN|
3286: A.SHR_ASSIGN|A.XOR_ASSIGN) as bop, e1, e2) -> begin
3287: match e1 with
3288: A.COMMA el -> (* GCC extension *)
3289: doExp isconst
3290: (A.COMMA (replaceLastInList el
3291: (fun e -> A.BINARY(bop, e, e2))))
3292: what
3293: | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *)
3294: doExp isconst
3295: (A.QUESTION (e1, A.BINARY(bop, e2q, e2),
3296: A.BINARY(bop, e3q, e2)))
3297: what
3298:
3299: | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *)
3300: A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ |
3301: A.CAST _ (* GCC extension *) ) -> begin
3302: if isconst then
3303: E.s (error "op_ASSIGN in constant");
3304: let bop' = match bop with
3305: A.ADD_ASSIGN -> PlusA
3306: | A.SUB_ASSIGN -> MinusA
3307: | A.MUL_ASSIGN -> Mult
3308: | A.DIV_ASSIGN -> Div
3309: | A.MOD_ASSIGN -> Mod
3310: | A.BAND_ASSIGN -> BAnd
3311: | A.BOR_ASSIGN -> BOr
3312: | A.XOR_ASSIGN -> BXor
3313: | A.SHL_ASSIGN -> Shiftlt
3314: | A.SHR_ASSIGN -> Shiftrt
3315: | _ -> E.s (error "binary +=")
3316: in
3317: let (se1, e1', t1) = doExp false e1 (AExp None) in
3318: let lv1 =
3319: match e1' with
3320: Lval x -> x
3321: | CastE (_, Lval x) -> x (* GCC extension. The operation and
3322: * the result are at the cast type *)
3323: | _ -> E.s (error "Expected lval for assignment with arith")
3324: in
3325: let (se2, e2', t2) = doExp false e2 (AExp None) in
3326: let tresult, result = doBinOp bop' e1' t1 e2' t2 in
3327: (* We must cast the result to the type of the lv1, which may be
3328: * different than t1 if lv1 was a Cast *)
3329: let _, result' = castTo tresult (typeOfLval lv1) result in
3330: (* The type of the result is the type of the left-hand side *)
3331: finishExp (se1 @@ se2 +++
3332: (Set(lv1, result', !currentLoc)))
3333: e1'
3334: t1
3335: end
3336: | _ -> E.s (error "Unexpected left operand for assignment with arith")
3337: end
3338:
3339:
3340: | A.BINARY((A.AND|A.OR), _, _) | A.UNARY(A.NOT, _) -> begin
3341: let ce = doCondExp isconst e in
3342: (* We must normalize the result to 0 or 1 *)
3343: match ce with
3344: CEExp (se, ((Const _) as c)) ->
3345: finishExp se (if isZero c then zero else one) intType
3346: | CEExp (se, e) ->
3347: let e' =
3348: let te = typeOf e in
3349: let _, zte = castTo intType te zero in
3350: BinOp(Ne, e, zte, te)
3351: in
3352: finishExp se e' intType
3353: | _ ->
3354: let tmp = var (newTempVar intType) in
3355: finishExp (compileCondExp ce
3356: (empty +++ (Set(tmp, integer 1,
3357: !currentLoc)))
3358: (empty +++ (Set(tmp, integer 0,
3359: !currentLoc))))
3360: (Lval tmp)
3361: intType
3362: end
3363:
3364: | A.CALL(f, args) ->
3365: if isconst then
3366: E.s (error "CALL in constant");
3367: let (sf, f', ft') =
3368: match f with (* Treat the VARIABLE case separate
3369: * becase we might be calling a
3370: * function that does not have a
3371: * prototype. In that case assume it
3372: * takes INTs as arguments *)
3373: A.VARIABLE n -> begin
3374: try
3375: let vi, _ = lookupVar n in
3376: (empty, Lval(var vi), vi.vtype) (* Found. Do not use
3377: * finishExp. Simulate what =
3378: * AExp None *)
3379: with Not_found -> begin
3380: ignore (warnOpt "Calling function %s without prototype." n);
3381: let ftype = TFun(intType, None, false,
3382: [Attr("missingproto",[])]) in
3383: (* Add a prototype to the environment *)
3384: let proto, _ =
3385: makeGlobalVarinfo false (makeGlobalVar n ftype) in
3386: (* Make it EXTERN *)
3387: proto.vstorage <- Extern;
3388: H.add noProtoFunctions proto.vid true;
3389: (* Add it to the file as well *)
3390: cabsPushGlobal (GVarDecl (proto, !currentLoc));
3391: (empty, Lval(var proto), ftype)
3392: end
3393: end
3394: | _ -> doExp false f (AExp None)
3395: in
3396: (* Get the result type and the argument types *)
3397: let (resType, argTypes, isvar, f'') =
3398: match unrollType ft' with
3399: TFun(rt,at,isvar,a) -> (rt,at,isvar,f')
3400: | TPtr (t, _) -> begin
3401: match unrollType t with
3402: TFun(rt,at,isvar,a) -> (* Make the function pointer
3403: * explicit *)
3404: let f'' =
3405: match f' with
3406: AddrOf lv -> Lval(lv)
3407: | _ -> Lval(mkMem f' NoOffset)
3408: in
3409: (rt,at,isvar, f'')
3410: | x ->
3411: E.s (error "Unexpected type of the called function %a: %a"
3412: d_exp f' d_type x)
3413: end
3414: | x -> E.s (error "Unexpected type of the called function %a: %a"
3415: d_exp f' d_type x)
3416: in
3417: let argTypesList = argsToList argTypes in
3418: (* Drop certain qualifiers from the result type *)
3419: let resType' = resType in
3420: (* Before we do the arguments we try to intercept a few builtins. For
3421: * these we have defined then with a different type, so we do not
3422: * want to give warnings. *)
3423: let isVarArgBuiltin =
3424: match f'' with
3425: Lval (Var fv, NoOffset) ->
3426: fv.vname = "__builtin_stdarg_start" ||
3427: fv.vname = "__builtin_va_arg" ||
3428: fv.vname = "__builtin_next_arg"
3429: | _ -> false
3430: in
3431:
3432: (* Do the arguments. In REVERSE order !!! Both GCC and MSVC do this *)
3433: let rec loopArgs
3434: : (string * typ * attributes) list * A.expression list
3435: -> (chunk * exp list) = function
3436: | ([], []) -> (empty, [])
3437:
3438: | args, [] ->
3439: if not isVarArgBuiltin then
3440: ignore (warnOpt
3441: "Too few arguments in call to %a."
3442: d_exp f');
3443: (empty, [])
3444:
3445: | ((_, at, _) :: atypes, a :: args) ->
3446: let (ss, args') = loopArgs (atypes, args) in
3447: let (sa, a', att) = doExp false a (AExp (Some at)) in
3448: let (at'', a'') = castTo att at a' in
3449: (ss @@ sa, a'' :: args')
3450:
3451: | ([], args) -> (* No more types *)
3452: if not isvar && argTypes != None && not isVarArgBuiltin then
3453: (* Do not give a warning for functions without a prototype*)
3454: ignore (warnOpt "Too many arguments in call to %a" d_exp f');
3455: let rec loop = function
3456: [] -> (empty, [])
3457: | a :: args ->
3458: let (ss, args') = loop args in
3459: let (sa, a', at) = doExp false a (AExp None) in
3460: (ss @@ sa, a' :: args')
3461: in
3462: loop args
3463: in
3464: let (sargs, args') = loopArgs (argTypesList, args) in
3465: let f3, what3, args3, is__builtin_va_arg =
3466: let rec dropCasts = function CastE (_, e) -> dropCasts e | e -> e in
3467: (* Get the name of the last formal *)
3468: let getNameLastFormal () : string =
3469: match !currentFunctionFDEC.svar.vtype with
3470: TFun(_, Some args, true, _) -> begin
3471: match List.rev args with
3472: (last_par_name, _, _) :: _ -> last_par_name
3473: | _ -> ""
3474: end
3475: | _ -> ""
3476: in
3477: match f'' with
3478: Lval(Var fv, NoOffset) -> begin
3479: if fv.vname = "__builtin_va_arg" then begin
3480: match args' with
3481: marker :: SizeOf resTyp :: _ -> begin
3482: (* Make a variable of the desired type *)
3483: let destlv, destlvtyp =
3484: match what with
3485: ASet (lv, lvt) -> lv, lvt
3486: | _ -> var (newTempVar resTyp), resTyp
3487: in
3488: f'',
3489: ASet (destlv, destlvtyp),
3490: [marker; SizeOf resTyp; AddrOf destlv],
3491: true
3492: end
3493: | _ ->
3494: ignore (warn "Invalid call to %s\n" fv.vname);
3495: f'',what, args', false
3496: end else if fv.vname = "__builtin_stdarg_start" then begin
3497: match args' with
3498: marker :: last :: [] -> begin
3499: let isOk =
3500: match dropCasts last with
3501: Lval (Var lastv, NoOffset) ->
3502: lastv.vname = getNameLastFormal ()
3503: | _ -> false
3504: in
3505: if not isOk then
3506: ignore (warn "The second argument in call to %s should be the last formal argument\n" fv.vname);
3507:
3508: (* Flx_cil_check that "lastv" is indeed the last variable in the
3509: * prototype and then drop it *)
3510: f'', what, [marker], false
3511: end
3512: | _ ->
3513: ignore (warn "Invalid call to %s\n" fv.vname);
3514: f'',what, args', false
3515:
3516: (* We have to turn uses of __builtin_varargs_start into uses
3517: * of __builtin_stdarg_start (because we have dropped the
3518: * __builtin_va_alist argument from this function *)
3519:
3520: end else if fv.vname = "__builtin_varargs_start" then begin
3521: (* Lookup the prototype for the replacement *)
3522: let v, _ =
3523: try lookupGlobalVar "__builtin_stdarg_start"
3524: with Not_found -> E.s (bug "Cannot find __builtin_stdarg_start to replace %s\n" fv.vname)
3525: in
3526: Lval (var v),
3527: what,
3528: args',
3529: false
3530:
3531: end else if fv.vname = "__builtin_next_arg" then begin
3532: match args' with
3533: last :: [] -> begin
3534: let isOk =
3535: match dropCasts last with
3536: Lval (Var lastv, NoOffset) ->
3537: lastv.vname = getNameLastFormal ()
3538: | _ -> false
3539: in
3540: if not isOk then
3541: ignore (warn "The argument in call to %s should be the last formal argument\n" fv.vname);
3542:
3543: f'', what, [ ], false
3544: end
3545: | _ ->
3546: ignore (warn "Invalid call to %s\n" fv.vname);
3547: f'',what, args', false
3548: end else
3549: f'', what, args', false
3550: end
3551: | _ -> f'',what, args', false
3552: in
3553: begin
3554: match what3 with
3555: ADrop ->
3556: finishExp
3557: (sf @@ sargs +++ (Call(None,f3,args3, !currentLoc)))
3558: (integer 0) intType
3559: (* Set to a variable of corresponding type *)
3560: | ASet(lv, vtype) ->
3561: (* Make an exception here for __builtin_va_arg *)
3562: if is__builtin_va_arg then
3563: finishExp
3564: (sf @@ sargs
3565: +++ (Call(None,f3,args3, !currentLoc)))
3566: (Lval(lv))
3567: vtype
3568: else
3569: finishExp
3570: (sf @@ sargs
3571: +++ (Call(Some lv,f3,args3, !currentLoc)))
3572: (Lval(lv))
3573: vtype
3574:
3575: | _ -> begin
3576: (* Must create a temporary *)
3577: match f3, args3 with (* Some constant folding *)
3578: Lval(Var fv, NoOffset), [Const _]
3579: when fv.vname = "__builtin_constant_p" ->
3580: finishExp (sf @@ sargs) (integer 1) intType
3581: | _ ->
3582: let tmp, restyp' =
3583: match what3 with
3584: AExp (Some t) -> newTempVar t, t
3585: | _ -> newTempVar resType', resType'
3586: in
3587: let i = Call(Some (var tmp),f3,args3, !currentLoc) in
3588: finishExp (sf @@ sargs +++ i) (Lval(var tmp)) restyp'
3589: end
3590: end
3591:
3592: | A.COMMA el ->
3593: if isconst then
3594: E.s (error "COMMA in constant");
3595: let rec loop sofar = function
3596: [e] ->
3597: let (se, e', t') = doExp false e what in (* Pass on the action *)
3598: (sofar @@ se, e', t')
3599: (*
3600: finishExp (sofar @@ se) e' t' (* does not hurt to do it twice.
3601: * GN: it seems it does *)
3602: *)
3603: | e :: rest ->
3604: let (se, _, _) = doExp false e ADrop in
3605: loop (sofar @@ se) rest
3606: | [] -> E.s (error "empty COMMA expression")
3607: in
3608: loop empty el
3609:
3610: | A.QUESTION (e1,e2,e3) when what = ADrop ->
3611: if isconst then
3612: E.s (error "QUESTION with ADrop in constant");
3613: let (se3,_,_) = doExp false e3 ADrop in
3614: let se2 =
3615: match e2 with
3616: A.NOTHING -> skipChunk
3617: | _ -> let (se2,_,_) = doExp false e2 ADrop in se2
3618: in
3619: finishExp (doCondition isconst e1 se2 se3) zero intType
3620:
3621: | A.QUESTION (e1, e2, e3) -> begin (* what is not ADrop *)
3622: (* Compile the conditional expression *)
3623: let ce1 = doCondExp isconst e1 in
3624: (* Now we must find the type of both branches, in order to compute
3625: * the type of the result *)
3626: let se2, e2'o (* is an option. None means use e1 *), t2 =
3627: match e2 with
3628: A.NOTHING -> begin (* The same as the type of e1 *)
3629: match ce1 with
3630: CEExp (_, e1') -> empty, None, typeOf e1' (* Do not promote
3631: to bool *)
3632: | _ -> empty, None, intType
3633: end
3634: | _ ->
3635: let se2, e2', t2 = doExp isconst e2 (AExp None) in
3636: se2, Some e2', t2
3637: in
3638: (* Do e3 for real *)
3639: let se3, e3', t3 = doExp isconst e3 (AExp None) in
3640: (* Compute the type of the result *)
3641: let tresult = conditionalConversion t2 t3 in
3642: match ce1 with
3643: CEExp (se1, Const(CInt64(i, _, _)))
3644: when i = Int64.zero && canDrop se2 ->
3645: finishExp (se1 @@ se3) (snd (castTo t3 tresult e3')) tresult
3646: | CEExp (se1, (Const(CInt64(i, _, _)) as e1'))
3647: when i <> Int64.zero && canDrop se3 -> begin
3648: match e2'o with
3649: None -> (* use e1' *)
3650: finishExp (se1 @@ se2) (snd (castTo t2 tresult e1')) tresult
3651: | Some e2' ->
3652: finishExp (se1 @@ se2) (snd (castTo t2 tresult e2')) tresult
3653: end
3654:
3655: | _ -> (* Use a conditional *) begin
3656: match e2 with
3657: A.NOTHING ->
3658: let tmp = var (newTempVar tresult) in
3659: let (se1, _, _) = doExp isconst e1 (ASet(tmp, tresult)) in
3660: let (se3, _, _) = doExp isconst e3 (ASet(tmp, tresult)) in
3661: finishExp (se1 @@ ifChunk (Lval(tmp)) lu
3662: skipChunk se3)
3663: (Lval(tmp))
3664: tresult
3665: | _ ->
3666: let lv, lvt =
3667: match what with
3668: | ASet (lv, lvt) -> lv, lvt
3669: | _ ->
3670: let tmp = newTempVar tresult in
3671: var tmp, tresult
3672: in
3673: (* Now do e2 and e3 for real *)
3674: let (se2, _, _) = doExp isconst e2 (ASet(lv, lvt)) in
3675: let (se3, _, _) = doExp isconst e3 (ASet(lv, lvt)) in
3676: finishExp (doCondition isconst e1 se2 se3) (Lval(lv)) tresult
3677: end
3678:
3679: (*
3680: (* Do these only to collect the types *)
3681: let se2, e2', t2' =
3682: match e2 with
3683: A.NOTHING -> (* A GNU thing. Use e1 as e2 *)
3684: doExp isconst e1 (AExp None)
3685: | _ -> doExp isconst e2 (AExp None) in
3686: (* Do e3 for real *)
3687: let se3, e3', t3' = doExp isconst e3 (AExp None) in
3688: (* Compute the type of the result *)
3689: let tresult = conditionalConversion e2' t2' e3' t3' in
3690: if (isEmpty se2 || e2 = A.NOTHING)
3691: && isEmpty se3 && isconst then begin
3692: (* Use the Question. This allows Question in initializers without
3693: * having to do constant folding *)
3694: let se1, e1', t1 = doExp isconst e1 (AExp None) in
3695: ignore (checkBool t1 e1');
3696: let e2'' =
3697: if e2 = A.NOTHING then
3698: mkCastT e1' t1 tresult
3699: else mkCastT e2' t2' tresult (* We know se2 is empty *)
3700: in
3701: let e3'' = mkCastT e3' t3' tresult in
3702: let resexp =
3703: match e1' with
3704: Const(CInt64(i, _, _)) when i <> Int64.zero -> e2''
3705: | Const(CInt64(z, _, _)) when z = Int64.zero -> e3''
3706: | _ -> Question(e1', e2'', e3'')
3707: in
3708: finishExp se1 resexp tresult
3709: end else begin (* Now use a conditional *)
3710: match e2 with
3711: A.NOTHING ->
3712: let tmp = var (newTempVar tresult) in
3713: let (se1, _, _) = doExp isconst e1 (ASet(tmp, tresult)) in
3714: let (se3, _, _) = doExp isconst e3 (ASet(tmp, tresult)) in
3715: finishExp (se1 @@ ifChunk (Lval(tmp)) lu
3716: skipChunk se3)
3717: (Lval(tmp))
3718: tresult
3719: | _ ->
3720: let lv, lvt =
3721: match what with
3722: | ASet (lv, lvt) -> lv, lvt
3723: | _ ->
3724: let tmp = newTempVar tresult in
3725: var tmp, tresult
3726: in
3727: (* Now do e2 and e3 for real *)
3728: let (se2, _, _) = doExp isconst e2 (ASet(lv, lvt)) in
3729: let (se3, _, _) = doExp isconst e3 (ASet(lv, lvt)) in
3730: finishExp (doCondition isconst e1 se2 se3) (Lval(lv)) tresult
3731: end
3732: *)
3733: end
3734:
3735: | A.GNU_BODY b -> begin
3736: (* Find the last A.COMPUTATION and remember it. This one is invoked
3737: * on the reversed list of statements. *)
3738: let rec findLastComputation = function
3739: s :: _ ->
3740: let rec findLast = function
3741: A.SEQUENCE (_, s, loc) -> findLast s
3742: | CASE (_, s, _) -> findLast s
3743: | CASERANGE (_, _, s, _) -> findLast s
3744: | LABEL (_, s, _) -> findLast s
3745: | (A.COMPUTATION _) as s -> s
3746: | _ -> raise Not_found
3747: in
3748: findLast s
3749: | [] -> raise Not_found
3750: in
3751: (* Save the previous data *)
3752: let old_gnu = ! gnu_body_result in
3753: let lastComp, isvoidbody =
3754: match what with
3755: ADrop -> (* We are dropping the result *)
3756: A.NOP cabslu, true
3757: | _ ->
3758: try findLastComputation (List.rev b.A.bstmts), false
3759: with Not_found ->
3760: E.s (error "Cannot find COMPUTATION in GNU.body")
3761: (* A.NOP cabslu, true *)
3762: in
3763: (* Prepare some data to be filled by doExp *)
3764: let data : (exp * typ) option ref = ref None in
3765: gnu_body_result := (lastComp, data);
3766:
3767: let se = doBody b in
3768:
3769: gnu_body_result := old_gnu;
3770: match !data with
3771: None when isvoidbody -> finishExp se zero voidType
3772: | None -> E.s (bug "Cannot find COMPUTATION in GNU.body")
3773: | Some (e, t) -> finishExp se e t
3774: end
3775:
3776: | A.LABELADDR l -> begin (* GCC's taking the address of a label *)
3777: let l = lookupLabel l in (* To support locallly declared labels *)
3778: let addrval =
3779: try H.find gotoTargetHash l
3780: with Not_found -> begin
3781: let res = !gotoTargetNextAddr in
3782: incr gotoTargetNextAddr;
3783: H.add gotoTargetHash l res;
3784: res
3785: end
3786: in
3787: finishExp empty (mkCast (integer addrval) voidPtrType) voidPtrType
3788: end
3789:
3790: | A.EXPR_PATTERN _ -> E.s (E.bug "EXPR_PATTERN in cabs2cil input")
3791:
3792: with e -> begin
3793: ignore (E.log "error in doExp (%s)@!" (Printexc.to_string e));
3794: (i2c (dInstr (dprintf "booo_exp(%t)" d_thisloc) !currentLoc),
3795: integer 0, intType)
3796: end
3797:
3798: (* bop is always the arithmetic version. Change it to the appropriate pointer
3799: * version if necessary *)
3800: and doBinOp (bop: binop) (e1: exp) (t1: typ) (e2: exp) (t2: typ) : typ * exp =
3801: let doArithmetic () =
3802: let tres = arithmeticConversion t1 t2 in
3803: (* Keep the operator since it is arithmetic *)
3804: tres,
3805: constFoldBinOp false bop (mkCastT e1 t1 tres) (mkCastT e2 t2 tres) tres
3806: in
3807: let doArithmeticComp () =
3808: let tres = arithmeticConversion t1 t2 in
3809: (* Keep the operator since it is arithemtic *)
3810: intType,
3811: constFoldBinOp false bop (mkCastT e1 t1 tres) (mkCastT e2 t2 tres) intType
3812: in
3813: let doIntegralArithmetic () =
3814: let tres = unrollType (arithmeticConversion t1 t2) in
3815: match tres with
3816: TInt _ ->
3817: tres,
3818: constFoldBinOp false bop (mkCastT e1 t1 tres) (mkCastT e2 t2 tres) tres
3819: | _ -> E.s (error "%a operator on a non-integer type" d_binop bop)
3820: in
3821: let pointerComparison e1 t1 e2 t2 =
3822: (* Cast both sides to an integer *)
3823: let commontype = !upointType in
3824: intType,
3825: constFoldBinOp false bop (mkCastT e1 t1 commontype)
3826: (mkCastT e2 t2 commontype) intType
3827: in
3828:
3829: match bop with
3830: (Mult|Div) -> doArithmetic ()
3831: | (Mod|BAnd|BOr|BXor) -> doIntegralArithmetic ()
3832: | (Shiftlt|Shiftrt) -> (* ISO 6.5.7. Only integral promotions. The result
3833: * has the same type as the left hand side *)
3834: if !msvcMode then
3835: (* MSVC has a bug. We duplicate it here *)
3836: doIntegralArithmetic ()
3837: else
3838: let t1' = integralPromotion t1 in
3839: let t2' = integralPromotion t2 in
3840: t1',
3841: constFoldBinOp false bop (mkCastT e1 t1 t1') (mkCastT e2 t2 t2') t1'
3842:
3843: | (PlusA|MinusA)
3844: when isArithmeticType t1 && isArithmeticType t2 -> doArithmetic ()
3845: | (Eq|Ne|Lt|Le|Ge|Gt)
3846: when isArithmeticType t1 && isArithmeticType t2 ->
3847: doArithmeticComp ()
3848: | PlusA when isPointerType t1 && isIntegralType t2 ->
3849: t1,
3850: constFoldBinOp false PlusPI e1 (mkCastT e2 t2 (integralPromotion t2)) t1
3851: | PlusA when isIntegralType t1 && isPointerType t2 ->
3852: t2,
3853: constFoldBinOp false PlusPI e2 (mkCastT e1 t1 (integralPromotion t1)) t2
3854: | MinusA when isPointerType t1 && isIntegralType t2 ->
3855: t1,
3856: constFoldBinOp false MinusPI e1 (mkCastT e2 t2 (integralPromotion t2)) t1
3857: | MinusA when isPointerType t1 && isPointerType t2 ->
3858: let commontype = t1 in
3859: intType,
3860: constFoldBinOp false MinusPP (mkCastT e1 t1 commontype)
3861: (mkCastT e2 t2 commontype) intType
3862: | (Le|Lt|Ge|Gt|Eq|Ne) when isPointerType t1 && isPointerType t2 ->
3863: pointerComparison e1 t1 e2 t2
3864: | (Eq|Ne) when isPointerType t1 && isZero e2 ->
3865: pointerComparison e1 t1 (mkCastT zero intType t1) t1
3866: | (Eq|Ne) when isPointerType t2 && isZero e1 ->
3867: pointerComparison (mkCastT zero intType t2) t2 e2 t2
3868:
3869:
3870: | (Eq|Ne|Le|Lt|Ge|Gt) when isPointerType t1 && isArithmeticType t2 ->
3871: ignore (warnOpt "Comparison of pointer and non-pointer");
3872: (* Cast both values to upointType *)
3873: doBinOp bop (mkCastT e1 t1 !upointType) !upointType
3874: (mkCastT e2 t2 !upointType) !upointType
3875: | (Eq|Ne|Le|Lt|Ge|Gt) when isArithmeticType t1 && isPointerType t2 ->
3876: ignore (warnOpt "Comparison of pointer and non-pointer");
3877: (* Cast both values to upointType *)
3878: doBinOp bop (mkCastT e1 t1 !upointType) !upointType
3879: (mkCastT e2 t2 !upointType) !upointType
3880:
3881: | _ -> E.s (error "doBinOp: %a\n" d_plainexp (BinOp(bop,e1,e2,intType)))
3882:
3883: (* Constant fold a conditional. This is because we want to avoid having
3884: * conditionals in the initializers. So, we try very hard to avoid creating
3885: * new statements. *)
3886: and doCondExp (isconst: bool)
3887: (e: A.expression) : condExpRes =
3888: let rec addChunkBeforeCE (c0: chunk) = function
3889: CEExp (c, e) -> CEExp (c0 @@ c, e)
3890: | CEAnd (ce1, ce2) -> CEAnd (addChunkBeforeCE c0 ce1, ce2)
3891: | CEOr (ce1, ce2) -> CEOr (addChunkBeforeCE c0 ce1, ce2)
3892: | CENot ce1 -> CENot (addChunkBeforeCE c0 ce1)
3893: in
3894: let rec canDropCE = function
3895: CEExp (c, e) -> canDrop c
3896: | CEAnd (ce1, ce2) | CEOr (ce1, ce2) -> canDropCE ce1 && canDropCE ce2
3897: | CENot (ce1) -> canDropCE ce1
3898: in
3899: match e with
3900: A.BINARY (A.AND, e1, e2) -> begin
3901: let ce1 = doCondExp isconst e1 in
3902: let ce2 = doCondExp isconst e2 in
3903: match ce1, ce2 with
3904: CEExp (se1, (Const(CInt64 _) as ci1)), _ ->
3905: if not (isZero ci1) then
3906: addChunkBeforeCE se1 ce2
3907: else
3908: (* se2 might contain labels so we cannot drop it *)
3909: if canDropCE ce2 then
3910: ce1
3911: else
3912: CEAnd (ce1, ce2)
3913: | CEExp(se1, e1'), CEExp (se2, e2') when
3914: !useLogicalOperators && isEmpty se1 && isEmpty se2 ->
3915: CEExp (empty, BinOp(LAnd,
3916: mkCast e1' intType,
3917: mkCast e2' intType, intType))
3918: | _ -> CEAnd (ce1, ce2)
3919: end
3920:
3921: | A.BINARY (A.OR, e1, e2) -> begin
3922: let ce1 = doCondExp isconst e1 in
3923: let ce2 = doCondExp isconst e2 in
3924: match ce1, ce2 with
3925: CEExp (se1, (Const(CInt64 _) as ci1)), _ ->
3926: if isZero ci1 then
3927: addChunkBeforeCE se1 ce2
3928: else
3929: (* se2 might contain labels so we cannot drop it *)
3930: if canDropCE ce2 then
3931: ce1
3932: else
3933: CEOr (ce1, ce2)
3934:
3935: | CEExp (se1, e1'), CEExp (se2, e2') when
3936: !useLogicalOperators && isEmpty se1 && isEmpty se2 ->
3937: CEExp (empty, BinOp(LOr, mkCast e1' intType,
3938: mkCast e2' intType, intType))
3939: | _ -> CEOr (ce1, ce2)
3940: end
3941:
3942: | A.UNARY(A.NOT, e1) -> begin
3943: match doCondExp isconst e1 with
3944: CEExp (se1, (Const(CInt64 _) as ci1)) ->
3945: if isZero ci1 then
3946: CEExp (se1, one)
3947: else
3948: CEExp (se1, zero)
3949: | CEExp (se1, e) when isEmpty se1 ->
3950: CEExp (empty, UnOp(LNot, mkCast e intType, intType))
3951:
3952: | ce1 -> CENot ce1
3953: end
3954:
3955: | _ ->
3956: let (se, e, t) as rese = doExp isconst e (AExp None) in
3957: ignore (checkBool t e);
3958: CEExp (se, constFold isconst e)
3959:
3960: and compileCondExp (ce: condExpRes) (st: chunk) (sf: chunk) : chunk =
3961: match ce with
3962: | CEAnd (ce1, ce2) ->
3963: let (sf1, sf2) =
3964: (* If sf is small then will copy it *)
3965: try (sf, duplicateChunk sf)
3966: with Failure _ ->
3967: let lab = newLabelName "_L" in
3968: (gotoChunk lab lu, consLabel lab sf !currentLoc false)
3969: in
3970: let st' = compileCondExp ce2 st sf1 in
3971: let sf' = sf2 in
3972: compileCondExp ce1 st' sf'
3973:
3974: | CEOr (ce1, ce2) ->
3975: let (st1, st2) =
3976: (* If st is small then will copy it *)
3977: try (st, duplicateChunk st)
3978: with Failure _ ->
3979: let lab = newLabelName "_L" in
3980: (gotoChunk lab lu, consLabel lab st !currentLoc false)
3981: in
3982: let st' = st1 in
3983: let sf' = compileCondExp ce2 st2 sf in
3984: compileCondExp ce1 st' sf'
3985:
3986: | CENot ce1 -> compileCondExp ce1 sf st
3987:
3988: | CEExp (se, e) -> begin
3989: match e with
3990: Const(CInt64(i,_,_)) when i <> Int64.zero && canDrop sf -> se @@ st
3991: | Const(CInt64(z,_,_)) when z = Int64.zero && canDrop st -> se @@ sf
3992: | _ -> se @@ ifChunk e !currentLoc st sf
3993: end
3994:
3995:
3996: (* A special case for conditionals *)
3997: and doCondition (isconst: bool) (* If we are in constants, we do our best to
3998: * eliminate the conditional *)
3999: (e: A.expression)
4000: (st: chunk)
4001: (sf: chunk) : chunk =
4002: compileCondExp (doCondExp isconst e) st sf
4003:
4004:
4005: and doPureExp (e : A.expression) : exp =
4006: let (se, e', _) = doExp true e (AExp None) in
4007: if isNotEmpty se then
4008: E.s (error "doPureExp: not pure");
4009: e'
4010:
4011: and doInitializer
4012: (vi: varinfo)
4013: (inite: A.init_expression)
4014: (* Return the accumulated chunk, the initializer and the new type (might be
4015: * different for arrays) *)
4016: : chunk * init * typ =
4017:
4018: (* Setup the pre-initializer *)
4019: let topPreInit = ref NoInitPre in
4020: if debugInit then
4021: ignore (E.log "\nStarting a new initializer for %s : %a\n"
4022: vi.vname d_type vi.vtype);
4023: let topSetupInit (o: offset) (e: exp) =
4024: if debugInit then
4025: ignore (E.log " set %a := %a\n" d_lval (Var vi, o) d_exp e);
4026: let newinit = setOneInit !topPreInit o e in
4027: if newinit != !topPreInit then topPreInit := newinit
4028: in
4029: let acc, restl =
4030: let so = makeSubobj vi vi.vtype NoOffset in
4031: doInit vi.vglob topSetupInit so empty [ (A.NEXT_INIT, inite) ]
4032: in
4033: if restl <> [] then
4034: ignore (warn "Ignoring some initializers");
4035: (* sm: we used to do array-size fixups here, but they only worked
4036: * for toplevel array types; now, collectInitializer does the job,
4037: * including for nested array types *)
4038: let typ' = unrollType vi.vtype
4039: in
4040: if debugInit then
4041: ignore (E.log "Collecting the initializer for %s\n" vi.vname);
4042: let (init, typ'') = collectInitializer !topPreInit typ' in
4043: if debugInit then
4044: ignore (E.log "Finished the initializer for %s\n" vi.vname);
4045: acc, init, typ''
4046:
4047:
4048:
4049: (* Consume some initializers. Watch out here. Make sure we use only
4050: * tail-recursion because these things can be big. *)
4051: and doInit
4052: (isconst: bool)
4053: (setone: offset -> exp -> unit) (* Use to announce an intializer *)
4054: (so: subobj)
4055: (acc: chunk)
4056: (initl: (A.initwhat * A.init_expression) list)
4057:
4058: (* Return the resulting chunk along with some unused initializers *)
4059: : chunk * (A.initwhat * A.init_expression) list =
4060:
4061: let whoami () = d_lval () (Var so.host, so.soOff) in
4062:
4063: let initl1 =
4064: match initl with
4065: | (A.NEXT_INIT,
4066: A.SINGLE_INIT (A.CAST ((s, dt), ie))) :: rest ->
4067: let s', dt', ie' = preprocessCast s dt ie in
4068: (A.NEXT_INIT, A.SINGLE_INIT (A.CAST ((s', dt'), ie'))) :: rest
4069: | _ -> initl
4070: in
4071: (* Sometimes we have a cast in front of a compound (in GCC). This
4072: * appears as a single initializer. Ignore the cast *)
4073: let initl2 =
4074: match initl1 with
4075: (what,
4076: A.SINGLE_INIT (A.CAST (_, A.COMPOUND_INIT ci))) :: rest ->
4077: (what, A.COMPOUND_INIT ci) :: rest
4078: | _ -> initl1
4079: in
4080: let allinitl = initl2 in
4081:
4082: if debugInit then begin
4083: ignore (E.log "doInit for %t %s (current %a). Looking at: " whoami
4084: (if so.eof then "(eof)" else "")
4085: d_lval (Var so.host, so.curOff));
4086: (match allinitl with
4087: [] -> ignore (E.log "[]")
4088: | (what, ie) :: _ ->
4089: withFlx_cil_cprint
4090: Flx_cil_cprint.print_init_expression (A.COMPOUND_INIT [(what, ie)]));
4091: ignore (E.log "\n");
4092: end;
4093: match unrollType so.soTyp, allinitl with
4094: _, [] -> acc, [] (* No more initializers return *)
4095:
4096: (* No more subobjects *)
4097: | _, (A.NEXT_INIT, _) :: _ when so.eof -> acc, allinitl
4098:
4099:
4100: (* If we are at an array of characters and the initializer is a
4101: * string literal (optionally enclosed in braces) then explode the
4102: * string into characters *)
4103: | TArray(bt, leno, _),
4104: (A.NEXT_INIT,
4105: (A.SINGLE_INIT(A.CONSTANT (A.CONST_STRING s))|
4106: A.COMPOUND_INIT
4107: [(A.NEXT_INIT,
4108: A.SINGLE_INIT(A.CONSTANT
4109: (A.CONST_STRING s)))])) :: restil
4110: when (match unrollType bt with
4111: TInt((IChar|IUChar|ISChar), _) -> true
4112: | TInt _ ->
4113: (*Base type is a scalar other than char. Maybe a wchar_t?*)
4114: E.s (error "Using a string literal to initialize something other than a character array.\n")
4115: | _ -> false (* OK, this is probably an array of strings. Handle *)
4116: ) (* it with the other arrays below.*)
4117: ->
4118: let charinits =
4119: let init c = A.NEXT_INIT, A.SINGLE_INIT(A.CONSTANT (A.CONST_CHAR [c]))
4120: in
4121: let collector =
4122: (* ISO 6.7.8 para 14: final NUL added only if no size specified, or
4123: * if there is room for it; btw, we can't rely on zero-init of
4124: * globals, since this array might be a local variable *)
4125: if ((isNone leno) or ((String.length s) < (integerArrayLength leno)))
4126: then ref [init Int64.zero]
4127: else ref []
4128: in
4129: for pos = String.length s - 1 downto 0 do
4130: collector := init (Int64.of_int (Char.code (s.[pos]))) :: !collector
4131: done;
4132: !collector
4133: in
4134: (* Create a separate object for the array *)
4135: let so' = makeSubobj so.host so.soTyp so.soOff in
4136: (* Go inside the array *)
4137: let leno = integerArrayLength leno in
4138: so'.stack <- [InArray(so'.curOff, bt, leno, ref 0)];
4139: normalSubobj so';
4140: let acc', initl' = doInit isconst setone so' acc charinits in
4141: if initl' <> [] then
4142: ignore (warn "Too many initializers for character array %t" whoami);
4143: (* Advance past the array *)
4144: advanceSubobj so;
4145: (* Continue *)
4146: let res = doInit isconst setone so acc' restil in
4147: res
4148:
4149: (* If we are at an array of WIDE characters and the initializer is a
4150: * WIDE string literal (optionally enclosed in braces) then explore
4151: * the WIDE string into characters *)
4152: (* [weimer] Wed Jan 30 15:38:05 PST 2002
4153: * Despite what the compiler says, this match case is used and it is
4154: * important. *)
4155: | TArray(bt, leno, _),
4156: (A.NEXT_INIT,
4157: (A.SINGLE_INIT(A.CONSTANT (A.CONST_WSTRING s)) |
4158: A.COMPOUND_INIT
4159: [(A.NEXT_INIT,
4160: A.SINGLE_INIT(A.CONSTANT
4161: (A.CONST_WSTRING s)))])) :: restil
4162: when(let bt' = unrollType bt in
4163: match bt' with
4164: (* compare bt to wchar_t, ignoring signed vs. unsigned *)
4165: TInt _ when (bitsSizeOf bt') = (bitsSizeOf !wcharType) -> true
4166: | TInt _ ->
4167: (*Base type is a scalar other than wchar_t. Maybe a char?*)
4168: E.s (error "Using a wide string literal to initialize something other than a wchar_t array.\n")
4169: | _ -> false (* OK, this is probably an array of strings. Handle *)
4170: ) (* it with the other arrays below.*)
4171: ->
4172: let maxWChar = (* (2**(bitsSizeOf !wcharType)) - 1 *)
4173: Int64.sub (Int64.shift_left Int64.one (bitsSizeOf !wcharType))
4174: Int64.one in
4175: let charinits =
4176: let init c =
4177: if (compare c maxWChar > 0) then (* if c > maxWChar *)
4178: E.s (error "cab2cil:doInit:character 0x%Lx too big." c);
4179: A.NEXT_INIT,
4180: A.SINGLE_INIT(A.CONSTANT (A.CONST_INT (Int64.to_string c)))
4181: in
4182: (List.map init s) @
4183: (
4184: (* ISO 6.7.8 para 14: final NUL added only if no size specified, or
4185: * if there is room for it; btw, we can't rely on zero-init of
4186: * globals, since this array might be a local variable *)
4187: if ((isNone leno) or ((List.length s) < (integerArrayLength leno)))
4188: then [init Int64.zero]
4189: else [])
4190: (*
4191: List.map
4192: (fun c ->
4193: if (compare c maxWChar > 0) then (* if c > maxWChar *)
4194: E.s (error "cab2cil:doInit:character 0x%Lx too big." c)
4195: else
4196: (A.NEXT_INIT,
4197: A.SINGLE_INIT(A.CONSTANT (A.CONST_INT (Int64.to_string c)))))
4198: s
4199: *)
4200: in
4201: (* Create a separate object for the array *)
4202: let so' = makeSubobj so.host so.soTyp so.soOff in
4203: (* Go inside the array *)
4204: let leno = integerArrayLength leno in
4205: so'.stack <- [InArray(so'.curOff, bt, leno, ref 0)];
4206: normalSubobj so';
4207: let acc', initl' = doInit isconst setone so' acc charinits in
4208: if initl' <> [] then
4209: (* sm: see above regarding ISO 6.7.8 para 14, which is not implemented
4210: * for wchar_t because, as far as I can tell, we don't even put in
4211: * the automatic NUL (!) *)
4212: ignore (warn "Too many initializers for wchar_t array %t" whoami);
4213: (* Advance past the array *)
4214: advanceSubobj so;
4215: (* Continue *)
4216: doInit isconst setone so acc' restil
4217:
4218: (* If we are at an array and we see a single initializer then it must
4219: * be one for the first element *)
4220: | TArray(bt, leno, al), (A.NEXT_INIT, A.SINGLE_INIT oneinit) :: restil ->
4221: (* Grab the length if there is one *)
4222: let leno = integerArrayLength leno in
4223: so.stack <- InArray(so.soOff, bt, leno, ref 0) :: so.stack;
4224: normalSubobj so;
4225: (* Start over with the fields *)
4226: doInit isconst setone so acc allinitl
4227:
4228: (* If we are at a composite and we see a single initializer of the same
4229: * type as the composite then grab it all. If the type is not the same
4230: * then we must go on and try to initialize the fields *)
4231: | TComp (comp, _), (A.NEXT_INIT, A.SINGLE_INIT oneinit) :: restil ->
4232: let se, oneinit', t' = doExp isconst oneinit (AExp None) in
4233: if (match unrollType t' with
4234: TComp (comp', _) when comp'.ckey = comp.ckey -> true
4235: | _ -> false)
4236: then begin
4237: (* Initialize the whole struct *)
4238: setone so.soOff oneinit';
4239: (* Advance to the next subobject *)
4240: advanceSubobj so;
4241: doInit isconst setone so (acc @@ se) restil
4242: end else begin (* Try to initialize fields *)
4243: let toinit = fieldsToInit comp None in
4244: so.stack <- InComp(so.soOff, comp, toinit) :: so.stack;
4245: normalSubobj so;
4246: doInit isconst setone so acc allinitl
4247: end
4248:
4249: (* A scalar with a single initializer *)
4250: | _, (A.NEXT_INIT, A.SINGLE_INIT oneinit) :: restil ->
4251: let se, oneinit', t' = doExp isconst oneinit (AExp(Some so.soTyp)) in
4252: setone so.soOff (mkCastT oneinit' t' so.soTyp);
4253: (* Move on *)
4254: advanceSubobj so;
4255: doInit isconst setone so (acc @@ se) restil
4256:
4257:
4258: (* An array with a compound initializer. The initializer is for the
4259: * array elements *)
4260: | TArray (bt, leno, _), (A.NEXT_INIT, A.COMPOUND_INIT initl) :: restil ->
4261: (* Create a separate object for the array *)
4262: let so' = makeSubobj so.host so.soTyp so.soOff in
4263: (* Go inside the array *)
4264: let leno = integerArrayLength leno in
4265: so'.stack <- [InArray(so'.curOff, bt, leno, ref 0)];
4266: normalSubobj so';
4267: let acc', initl' = doInit isconst setone so' acc initl in
4268: if initl' <> [] then
4269: ignore (warn "Too many initializers for array %t" whoami);
4270: (* Advance past the array *)
4271: advanceSubobj so;
4272: (* Continue *)
4273: let res = doInit isconst setone so acc' restil in
4274: res
4275:
4276: (* We have a designator that tells us to select the matching union field.
4277: * This is to support a GCC extension *)
4278: | TComp(ci, _), [(A.NEXT_INIT,
4279: A.COMPOUND_INIT [(A.INFIELD_INIT ("___matching_field",
4280: A.NEXT_INIT),
4281: A.SINGLE_INIT oneinit)])]
4282: when not ci.cstruct ->
4283: (* Do the expression to find its type *)
4284: let _, _, t' = doExp isconst oneinit (AExp None) in
4285: let tsig = typeSigWithAttrs (fun _ -> []) t' in
4286: let rec findField = function
4287: [] -> E.s (error "Cannot find matching union field in cast")
4288: | fi :: rest when typeSigWithAttrs (fun _ -> []) fi.ftype = tsig -> fi
4289: | _ :: rest -> findField rest
4290: in
4291: let fi = findField ci.cfields in
4292: (* Change the designator and redo *)
4293: doInit isconst setone so acc [(A.INFIELD_INIT (fi.fname, A.NEXT_INIT),
4294: A.SINGLE_INIT oneinit)]
4295:
4296:
4297: (* A structure with a composite initializer. We initialize the fields*)
4298: | TComp (comp, _), (A.NEXT_INIT, A.COMPOUND_INIT initl) :: restil ->
4299: (* Create a separate subobject iterator *)
4300: let so' = makeSubobj so.host so.soTyp so.soOff in
4301: (* Go inside the comp *)
4302: so'.stack <- [InComp(so'.curOff, comp, fieldsToInit comp None)];
4303: normalSubobj so';
4304: let acc', initl' = doInit isconst setone so' acc initl in
4305: if initl' <> [] then
4306: ignore (warn "Too many initializers for structure");
4307: (* Advance past the structure *)
4308: advanceSubobj so;
4309: (* Continue *)
4310: doInit isconst setone so acc' restil
4311:
4312: (* A scalar with a initializer surrounded by braces *)
4313: | _, (A.NEXT_INIT, A.COMPOUND_INIT [(A.NEXT_INIT,
4314: A.SINGLE_INIT oneinit)]) :: restil ->
4315: let se, oneinit', t' = doExp isconst oneinit (AExp(Some so.soTyp)) in
4316: setone so.soOff (mkCastT oneinit' t' so.soTyp);
4317: (* Move on *)
4318: advanceSubobj so;
4319: doInit isconst setone so (acc @@ se) restil
4320:
4321: | t, (A.NEXT_INIT, _) :: _ ->
4322: E.s (unimp "doInit: unexpected NEXT_INIT for %a\n" d_type t);
4323:
4324: (* We have a designator *)
4325: | _, (what, ie) :: restil when what != A.NEXT_INIT ->
4326: (* Process a designator and position to the designated subobject *)
4327: let rec addressSubobj
4328: (so: subobj)
4329: (what: A.initwhat)
4330: (acc: chunk) : chunk =
4331: (* Always start from the current element *)
4332: so.stack <- []; so.eof <- false;
4333: normalSubobj so;
4334: let rec address (what: A.initwhat) (acc: chunk) : chunk =
4335: match what with
4336: A.NEXT_INIT -> acc
4337: | A.INFIELD_INIT (fn, whatnext) -> begin
4338: match unrollType so.soTyp with
4339: TComp (comp, _) ->
4340: let toinit = fieldsToInit comp (Some fn) in
4341: so.stack <- InComp(so.soOff, comp, toinit) :: so.stack;
4342: normalSubobj so;
4343: address whatnext acc
4344:
4345: | _ -> E.s (error "Field designator %s not in a struct " fn)
4346: end
4347:
4348: | A.ATINDEX_INIT(idx, whatnext) -> begin
4349: match unrollType so.soTyp with
4350: TArray (bt, leno, _) ->
4351: let ilen = integerArrayLength leno in
4352: let nextidx', doidx =
4353: let (doidx, idxe', _) =
4354: doExp true idx (AExp(Some intType)) in
4355: match constFold true idxe', isNotEmpty doidx with
4356: Const(CInt64(x, _, _)), false -> Int64.to_int x, doidx
4357: | _ -> E.s (error
4358: "INDEX initialization designator is not a constant")
4359: in
4360: if nextidx' < 0 || nextidx' >= ilen then
4361: E.s (error "INDEX designator is outside bounds");
4362: so.stack <-
4363: InArray(so.soOff, bt, ilen, ref nextidx') :: so.stack;
4364: normalSubobj so;
4365: address whatnext (acc @@ doidx)
4366:
4367: | _ -> E.s (error "INDEX designator for a non-array")
4368: end
4369:
4370: | A.ATINDEXRANGE_INIT _ ->
4371: E.s (bug "addressSubobj: INDEXRANGE")
4372: in
4373: address what acc
4374: in
4375: (* First expand the INDEXRANGE by making copies *)
4376: let rec expandRange (top: A.initwhat -> A.initwhat) = function
4377: | A.INFIELD_INIT (fn, whatnext) ->
4378: expandRange (fun what -> top (A.INFIELD_INIT(fn, what))) whatnext
4379: | A.ATINDEX_INIT (idx, whatnext) ->
4380: expandRange (fun what -> top (A.ATINDEX_INIT(idx, what))) whatnext
4381:
4382: | A.ATINDEXRANGE_INIT (idxs, idxe) ->
4383: let (doidxs, idxs', _) =
4384: doExp true idxs (AExp(Some intType)) in
4385: let (doidxe, idxe', _) =
4386: doExp true idxe (AExp(Some intType)) in
4387: if isNotEmpty doidxs || isNotEmpty doidxe then
4388: E.s (error "Range designators are not constants\n");
4389: let first, last =
4390: match constFold true idxs', constFold true idxe' with
4391: Const(CInt64(s, _, _)),
4392: Const(CInt64(e, _, _)) ->
4393: Int64.to_int s, Int64.to_int e
4394: | _ -> E.s (error
4395: "INDEX_RANGE initialization designator is not a constant")
4396: in
4397: if first < 0 || first > last then
4398: E.s (error
4399: "start index larger than end index in range initializer");
4400: let rec loop (i: int) =
4401: if i > last then restil
4402: else
4403: (top (A.ATINDEX_INIT(A.CONSTANT(A.CONST_INT(string_of_int i)),
4404: A.NEXT_INIT)), ie)
4405: :: loop (i + 1)
4406: in
4407: doInit isconst setone so acc (loop first)
4408:
4409: | A.NEXT_INIT -> (* We have not found any RANGE *)
4410: let acc' = addressSubobj so what acc in
4411: doInit isconst setone so (acc @@ acc')
4412: ((A.NEXT_INIT, ie) :: restil)
4413: in
4414: expandRange (fun x -> x) what
4415:
4416: | t, (what, ie) :: _ ->
4417: E.s (bug "doInit: cases for t=%a" d_type t)
4418:
4419:
4420: (* Create and add to the file (if not already added) a global. Return the
4421: * varinfo *)
4422: and createGlobal (specs : (typ * storage * bool * A.attribute list))
4423: (((n,ndt,a,cloc) as nm, inite) : A.init_name) : varinfo =
4424: try
4425: if debugGlobal then
4426: ignore (E.log "createGlobal: %s\n" n);
4427: (* Make a first version of the varinfo *)
4428: let vi = makeVarInfoFlx_cil_cabs ~isformal:false
4429: ~isglobal:true (convLoc cloc) specs (n,ndt,a) in
4430: (* Add the variable to the environment before doing the initializer
4431: * because it might refer to the variable itself *)
4432: if isFunctionType vi.vtype then begin
4433: if inite != A.NO_INIT then
4434: E.s (error "Function declaration with initializer (%s)\n"
4435: vi.vname);
4436: (* sm: if it's a function prototype, and the storage class *)
4437: (* isn't specified, make it 'extern'; this fixes a problem *)
4438: (* with no-storage prototype and static definition *)
4439: if vi.vstorage = NoStorage then
4440: (*(trace "sm" (dprintf "adding extern to prototype of %s\n" n));*)
4441: vi.vstorage <- Extern;
4442: end;
4443: let vi, alreadyInEnv = makeGlobalVarinfo (inite != A.NO_INIT) vi in
4444: (*
4445: ignore (E.log "createGlobal %a: %s type=%a\n"
4446: d_loc (convLoc cloc) vi.vname d_plaintype vi.vtype);
4447: *)
4448: (* Do the initializer and complete the array type if necessary *)
4449: let init : init option =
4450: if inite = A.NO_INIT then
4451: None
4452: else
4453: let se, ie', et = doInitializer vi inite in
4454: (* Maybe we now have a better type *)
4455: vi.vtype <- et;
4456: if isNotEmpty se then
4457: E.s (error "global initializer");
4458: Some ie'
4459: in
4460:
4461: try
4462: let oldloc = H.find alreadyDefined vi.vname in
4463: if init != None then begin
4464: E.s (error "Global %s was already defined at %a\n"
4465: vi.vname d_loc oldloc);
4466: end;
4467: if debugGlobal then
4468: ignore (E.log " global %s was already defined\n" vi.vname);
4469: (* Do not declare it again *)
4470: vi
4471: with Not_found -> begin
4472: (* Not already defined *)
4473: if debugGlobal then
4474: ignore (E.log " first definition for %s\n" vi.vname);
4475: if init != None then begin
4476: (* weimer: Sat Dec 8 17:43:34 2001
4477: * MSVC NT Kernel headers include this lovely line:
4478: * extern const GUID __declspec(selectany) \
4479: * MOUNTDEV_MOUNTED_DEVICE_GUID = { 0x53f5630d, 0xb6bf, 0x11d0, { \
4480: * 0x94, 0xf2, 0x00, 0xa0, 0xc9, 0x1e, 0xfb, 0x8b } };
4481: * So we allow "extern" + "initializer" if "const" is
4482: * around. *)
4483: (* sm: As I read the ISO spec, in particular 6.9.2 and 6.7.8,
4484: * "extern int foo = 3" is exactly equivalent to "int foo = 3";
4485: * that is, if you put an initializer, then it is a definition,
4486: * and "extern" is redundantly giving the name external linkage.
4487: * gcc emits a warning, I guess because it is contrary to
4488: * usual practice, but I think CIL warnings should be about
4489: * semantic rather than stylistic issues, so I see no reason to
4490: * even emit a warning. *)
4491: if vi.vstorage = Extern then
4492: vi.vstorage <- NoStorage; (* equivalent and canonical *)
4493:
4494: H.add alreadyDefined vi.vname !currentLoc;
4495: H.remove mustTurnIntoDef vi.vid;
4496: cabsPushGlobal (GVar(vi, {init = init}, !currentLoc));
4497: vi
4498: end else begin
4499: if not (isFunctionType vi.vtype)
4500: && not (H.mem mustTurnIntoDef vi.vid) then
4501: begin
4502: H.add mustTurnIntoDef vi.vid true
4503: end;
4504: if not alreadyInEnv then begin (* Only one declaration *)
4505: (* If it has function type it is a prototype *)
4506: cabsPushGlobal (GVarDecl (vi, !currentLoc));
4507: vi
4508: end else begin
4509: if debugGlobal then
4510: ignore (E.log " already in env %s\n" vi.vname);
4511: vi
4512: end
4513: end
4514: end
4515: with e -> begin
4516: ignore (E.log "error in createGlobal(%s: %a): %s\n" n
4517: d_loc !currentLoc
4518: (Printexc.to_string e));
4519: cabsPushGlobal (dGlobal (dprintf "booo - error in global %s (%t)"
4520: n d_thisloc) !currentLoc);
4521: dummyFunDec.svar
4522: end
4523: (*
4524: ignore (E.log "Env after processing global %s is:@!%t@!"
4525: n docEnv);
4526: ignore (E.log "Alpha after processing global %s is:@!%t@!"
4527: n docAlphaTable)
4528: *)
4529:
4530: (* Must catch the Static local variables. Make them global *)
4531: and createLocal ((_, sto, _, _) as specs)
4532: ((((n, ndt, a, cloc) : A.name),
4533: (e: A.init_expression)) as init_name)
4534: : chunk =
4535: let loc = convLoc cloc in
4536: (* Flx_cil_check if we are declaring a function *)
4537: let rec isProto (dt: decl_type) : bool =
4538: match dt with
4539: | PROTO (JUSTBASE, _, _) -> true
4540: | PROTO (x, _, _) -> isProto x
4541: | PARENTYPE (_, x, _) -> isProto x
4542: | ARRAY (x, _, _) -> isProto x
4543: | PTR (_, x) -> isProto x
4544: | _ -> false
4545: in
4546: match ndt with
4547: (* Maybe we have a function prototype in local scope. Make it global. We
4548: * do this even if the storage is Static *)
4549: | _ when isProto ndt ->
4550: let vi = createGlobal specs init_name in
4551: (* Add it to the environment to shadow previous decls *)
4552: addLocalToEnv n (EnvVar vi);
4553: empty
4554:
4555: | _ when sto = Static ->
4556: if debugGlobal then
4557: ignore (E.log "createGlobal (local static): %s\n" n);
4558:
4559: (* Now alpha convert it to make sure that it does not conflict with
4560: * existing globals or locals from this function. *)
4561: let newname, _ = newAlphaName true "" n in
4562: (* Make it global *)
4563: let vi = makeVarInfoFlx_cil_cabs ~isformal:false
4564: ~isglobal:true
4565: loc specs (newname, ndt, a) in
4566: (* However, we have a problem if a real global appears later with the
4567: * name that we have happened to choose for this one. Remember these names
4568: * for later. *)
4569: H.add staticLocals vi.vname vi;
4570: (* Add it to the environment as a local so that the name goes out of
4571: * scope properly *)
4572: addLocalToEnv n (EnvVar vi);
4573: let init : init option =
4574: if e = A.NO_INIT then
4575: None
4576: else begin
4577: let se, ie', et = doInitializer vi e in
4578: (* Maybe we now have a better type *)
4579: vi.vtype <- et;
4580: if isNotEmpty se then
4581: E.s (error "global static initializer");
4582: (* Maybe the initializer refers to the function itself.
4583: Push a prototype for the function, just in case. Hopefully,
4584: if does not refer to the locals *)
4585: cabsPushGlobal (GVarDecl (!currentFunctionFDEC.svar, !currentLoc));
4586: Some ie'
4587: end
4588: in
4589: cabsPushGlobal (GVar(vi, {init = init}, !currentLoc));
4590: empty
4591:
4592: (* Maybe we have an extern declaration. Make it a global *)
4593: | _ when sto = Extern ->
4594: let vi = createGlobal specs init_name in
4595: (* Add it to the local environment to ensure that it shadows previous
4596: * local variables *)
4597: addLocalToEnv n (EnvVar vi);
4598: empty
4599:
4600: | _ ->
4601: (* Make a variable of potentially variable size. If se0 <> empty then
4602: * it is a variable size variable *)
4603: let vi,se0,len,isvarsize =
4604: makeVarSizeVarInfo loc specs (n, ndt, a) in
4605:
4606: let vi = alphaConvertVarAndAddToEnv true vi in (* Replace vi *)
4607: let se1 =
4608: if isvarsize then begin (* Variable-sized array *)
4609: ignore (warn "Variable-sized local variable %s" vi.vname);
4610: (* Make a local variable to keep the length *)
4611: let savelen =
4612: makeVarInfoFlx_cil_cabs
4613: ~isformal:false
4614: ~isglobal:false
4615: loc
4616: (TInt(IUInt, []), NoStorage, false, [])
4617: ("__lengthof" ^ vi.vname,JUSTBASE, [])
4618: in
4619: (* Register it *)
4620: let savelen = alphaConvertVarAndAddToEnv true savelen in
4621: (* Compute the sizeof *)
4622: let sizeof =
4623: BinOp(Mult,
4624: SizeOfE (Lval(Mem(Lval(var vi)), NoOffset)),
4625: Lval (var savelen), !typeOfSizeOf) in
4626: (* Register the length *)
4627: H.add varSizeArrays vi.vid sizeof;
4628: (* There can be no initializer for this *)
4629: if e != A.NO_INIT then
4630: E.s (error "Variable-sized array cannot have initializer");
4631: se0 +++ (Set(var savelen, len, !currentLoc))
4632: (* Initialize the variable *)
4633: +++ (Call(Some(var vi), Lval(var allocaFun.svar),
4634: [ sizeof ], !currentLoc))
4635: end else empty
4636: in
4637: if e = A.NO_INIT then
4638: se1 (* skipChunk *)
4639: else begin
4640: let se4, ie', et = doInitializer vi e in
4641: (* Fix the length *)
4642: (match vi.vtype, ie', et with
4643: (* We have a length now *)
4644: TArray(_,None, _), _, TArray(_, Some _, _) -> vi.vtype <- et
4645: (* Initializing a local array *)
4646: | TArray(TInt((IChar|IUChar|ISChar), _) as bt, None, a),
4647: SingleInit(Const(CStr s)), _ ->
4648: vi.vtype <- TArray(bt,
4649: Some (integer (String.length s + 1)),
4650: a)
4651: | _, _, _ -> ());
4652: (* Now create assignments instead of the initialization *)
4653: se1 @@ se4 @@ (assignInit (Var vi, NoOffset) ie' et empty)
4654: end
4655:
4656:
4657: (* Do one declaration *)
4658: and doDecl (isglobal: bool) : A.definition -> chunk = function
4659: | A.DECDEF ((s, nl), loc) ->
4660: currentLoc := convLoc(loc);
4661: (* Do the specifiers exactly once *)
4662: let sugg =
4663: match nl with
4664: [] -> ""
4665: | ((n, _, _, _), _) :: _ -> n
4666: in
4667: let spec_res = doSpecList sugg s in
4668: (* Do all the variables and concatenate the resulting statements *)
4669: let doOneDeclarator (acc: chunk) (n: init_name) =
4670: if isglobal then begin
4671: (* For a global we ignore the varinfo that is created *)
4672: ignore (createGlobal spec_res n);
4673: acc
4674: end else
4675: acc @@ createLocal spec_res n
4676: in
4677: List.fold_left doOneDeclarator empty nl
4678:
4679: | A.TYPEDEF (ng, loc) ->
4680: currentLoc := convLoc(loc);
4681: doTypedef ng; empty
4682:
4683: | A.ONLYTYPEDEF (s, loc) ->
4684: currentLoc := convLoc(loc);
4685: doOnlyTypedef s; empty
4686:
4687: | A.GLOBASM (s,loc) when isglobal ->
4688: currentLoc := convLoc(loc);
4689: cabsPushGlobal (GAsm (s, !currentLoc));
4690: empty
4691:
4692: | A.PRAGMA (a, loc) when isglobal -> begin
4693: currentLoc := convLoc(loc);
4694: match doAttr ("dummy", [a]) with
4695: [Attr("dummy", [a'])] ->
4696: let a'' =
4697: match a' with
4698: | ACons (s, args) -> Attr (s, args)
4699: | _ -> E.s (error "Unexpected attribute in #pragma")
4700: in
4701: cabsPushGlobal (GPragma (a'', !currentLoc));
4702: empty
4703:
4704: | _ -> E.s (error "Too many attributes in pragma")
4705: end
4706: | A.TRANSFORMER (_, _, _) -> E.s (E.bug "TRANSFORMER in cabs2cil input")
4707: | A.EXPRTRANSFORMER (_, _, _) ->
4708: E.s (E.bug "EXPRTRANSFORMER in cabs2cil input")
4709:
4710: (* If there are multiple definitions of extern inline, turn all but the
4711: * first into a prototype *)
4712: | A.FUNDEF (((specs,(n,dt,a,loc')) : A.single_name),
4713: (body : A.block), loc, _)
4714: when isglobal && isExtern specs && isInline specs
4715: && (H.mem genv (n ^ "__extinline")) ->
4716: currentLoc := convLoc(loc);
4717: ignore (warn "Duplicate extern inline definition for %s ignored"
4718: n);
4719: (* Treat it as a prototype *)
4720: doDecl isglobal (A.DECDEF ((specs, [((n,dt,a,loc'), A.NO_INIT)]), loc))
4721:
4722: | A.FUNDEF (((specs,(n,dt,a, _)) : A.single_name),
4723: (body : A.block), loc1, loc2) when isglobal ->
4724: begin
4725: let funloc = convLoc loc1 in
4726: let endloc = convLoc loc2 in
4727: (* ignore (E.log "Definition of %s at %a\n" n d_loc funloc); *)
4728: currentLoc := funloc;
4729: E.withContext
4730: (fun _ -> dprintf "2cil: %s" n)
4731: (fun _ ->
4732: try
4733: (* Make the fundec right away, and we'll populate it later. We
4734: * need this throughout the code to create temporaries. *)
4735: currentFunctionFDEC :=
4736: { svar = makeGlobalVar "@tempname@" voidType;
4737: slocals = []; (* For now we'll put here both the locals and
4738: * the formals. Then "endFunction" will
4739: * separate them *)
4740: sformals = []; (* Not final yet *)
4741: smaxid = 0;
4742: sbody = dummyFunDec.sbody; (* Not final yet *)
4743: smaxstmtid = None;
4744: };
4745: !currentFunctionFDEC.svar.vdecl <- funloc;
4746:
4747: constrExprId := 0;
4748: (* Setup the environment. Add the formals to the locals. Maybe
4749: * they need alpha-conv *)
4750: enterScope (); (* Start the scope *)
4751:
4752: H.clear varSizeArrays;
4753:
4754: (* Do not process transparent unions in function definitions.
4755: * We'll do it later *)
4756: transparentUnionArgs := [];
4757:
4758: (* Fix the NAME and the STORAGE *)
4759: let _ =
4760: let bt,sto,inl,attrs = doSpecList n specs in
4761: !currentFunctionFDEC.svar.vinline <- inl;
4762:
4763: let ftyp, funattr =
4764: doType (AttrName false) bt (A.PARENTYPE(attrs, dt, a)) in
4765: !currentFunctionFDEC.svar.vtype <- ftyp;
4766: !currentFunctionFDEC.svar.vattr <- funattr;
4767:
4768: (* If this is the definition of an extern inline then we change
4769: * its name, by adding the suffix __extinline. We also make it
4770: * static *)
4771: let n', sto' =
4772: let n' = n ^ "__extinline" in
4773: if inl && sto = Extern then
4774: n', Static
4775: else begin
4776: (* Maybe this is the body of a previous extern inline. Then
4777: * we must take that one out of the environment because it
4778: * is not used from here on. This will also ensure that
4779: * then we make this functions' varinfo we will not think
4780: * it is a duplicate definition *)
4781: (try
4782: ignore (lookupVar n'); (* n' is defined *)
4783: let oldvi, _ = lookupVar n in
4784: if oldvi.vname <> n' then
4785: E.s (bug "extern inline redefinition: %s (expected %s)"
4786: oldvi.vname n');
4787: H.remove env n; H.remove genv n;
4788: H.remove env n'; H.remove genv n'
4789: with Not_found -> ());
4790: n, sto
4791: end
4792: in
4793: (* Now we have the name and the storage *)
4794: !currentFunctionFDEC.svar.vname <- n';
4795: !currentFunctionFDEC.svar.vstorage <- sto'
4796: in
4797:
4798: (* Add the function itself to the environment. Add it before
4799: * you do the body because the function might be recursive. Add
4800: * it also before you add the formals to the environment
4801: * because there might be a formal with the same name as the
4802: * function and we want it to take precedence. *)
4803: (* Make a variable out of it and put it in the environment *)
4804: !currentFunctionFDEC.svar <-
4805: fst (makeGlobalVarinfo true !currentFunctionFDEC.svar);
4806:
4807: (* If it is extern inline then we add it to the global
4808: * environment for the original name as well. This will ensure
4809: * that all uses of this function will refer to the renamed
4810: * function *)
4811: addGlobalToEnv n (EnvVar !currentFunctionFDEC.svar);
4812:
4813: if H.mem alreadyDefined !currentFunctionFDEC.svar.vname then
4814: E.s (error "There is a definition already for %s" n);
4815:
4816: (*
4817: ignore (E.log "makefunvar:%s@! type=%a@! vattr=%a@!"
4818: n d_type thisFunctionVI.vtype
4819: d_attrlist thisFunctionVI.vattr);
4820: *)
4821:
4822: (* makeGlobalVarinfo might have changed the type of the function
4823: * (when combining it with the type of the prototype). So get the
4824: * type only now. *)
4825:
4826: (**** Process the TYPE and the FORMALS ***)
4827: let _ =
4828: let (returnType, formals_t, isvararg, funta) =
4829: splitFunctionTypeVI !currentFunctionFDEC.svar
4830: in
4831: (* Record the returnType for doStatement *)
4832: currentReturnType := returnType;
4833:
4834:
4835: (* Create the formals and add them to the environment. *)
4836: (* sfg: extract locations for the formals from dt *)
4837: let doFormal (loc : location) (fn, ft, fa) =
4838: let f = makeVarinfo false fn ft in
4839: (f.vdecl <- loc;
4840: f.vattr <- fa;
4841: alphaConvertVarAndAddToEnv true f)
4842: in
4843: let rec doFormals fl' ll' =
4844: begin
4845: match (fl', ll') with
4846: | [], _ -> []
4847:
4848: | fl, [] -> (* no more locs available *)
4849: List.map (doFormal !currentLoc) fl
4850:
4851: | f::fl, (_,(_,_,_,l))::ll ->
4852: (* sfg: these lets seem to be necessary to
4853: * force the right order of evaluation *)
4854: let f' = doFormal (convLoc l) f in
4855: let fl' = doFormals fl ll in
4856: f' :: fl'
4857: end
4858: in
4859: let fmlocs = (match dt with PROTO(_, fml, _) -> fml | _ -> []) in
4860: let formals = doFormals (argsToList formals_t) fmlocs in
4861:
4862: (* Recreate the type based on the formals. *)
4863: let ftype = TFun(returnType,
4864: Some (List.map (fun f -> (f.vname,
4865: f.vtype,
4866: f.vattr)) formals),
4867: isvararg, funta) in
4868: (*
4869: ignore (E.log "Funtype of %s: %a\n" n' d_type ftype);
4870: *)
4871: (* Now fix the names of the formals in the type of the function
4872: * as well *)
4873: !currentFunctionFDEC.svar.vtype <- ftype;
4874: !currentFunctionFDEC.sformals <- formals;
4875: in
4876: (* Now change the type of transparent union args back to what it
4877: * was so that the body type checks. We must do it this late
4878: * because makeGlobalVarinfo from above might choke if we give
4879: * the function a type containing transparent unions *)
4880: let _ =
4881: let rec fixbackFormals (idx: int) (args: varinfo list) : unit=
4882: match args with
4883: [] -> ()
4884: | a :: args' ->
4885: (* Fix the type back to a transparent union type *)
4886: (try
4887: let origtype = List.assq idx !transparentUnionArgs in
4888: a.vtype <- origtype;
4889: with Not_found -> ());
4890: fixbackFormals (idx + 1) args'
4891: in
4892: fixbackFormals 0 !currentFunctionFDEC.sformals;
4893: transparentUnionArgs := [];
4894: in
4895:
4896: (********** Now do the BODY *************)
4897: let _ =
4898: let stmts = doBody body in
4899: (* Finish everything *)
4900: exitScope ();
4901:
4902: (* Now fill in the computed goto statement with cases. Do this
4903: * before mkFunctionbody which resolves the gotos *)
4904: (match !gotoTargetData with
4905: Some (switchv, switch) ->
4906: let switche, l =
4907: match switch.skind with
4908: Switch (switche, _, _, l) -> switche, l
4909: | _ -> E.s(bug "the computed goto statement not a switch")
4910: in
4911: (* Build a default chunk that segfaults *)
4912: let default =
4913: defaultChunk
4914: l
4915: (i2c (Set ((Mem (mkCast (integer 0) intPtrType),
4916: NoOffset),
4917: integer 0, l)))
4918: in
4919: let bodychunk = ref default in
4920: H.iter (fun lname laddr ->
4921: bodychunk :=
4922: caseRangeChunk
4923: [integer laddr] l
4924: (gotoChunk lname l @@ !bodychunk))
4925: gotoTargetHash;
4926: (* Now recreate the switch *)
4927: let newswitch = switchChunk switche !bodychunk l in
4928: (* We must still share the old switch statement since we
4929: * have already inserted the goto's *)
4930: let newswitchkind =
4931: match newswitch.stmts with
4932: [ s]
4933: when newswitch.postins = [] && newswitch.cases = []->
4934: s.skind
4935: | _ -> E.s (bug "Unexpected result from switchChunk")
4936: in
4937: switch.skind <- newswitchkind
4938:
4939: | None -> ());
4940: (* Now finish the body and store it *)
4941: !currentFunctionFDEC.sbody <- mkFunctionBody stmts;
4942: (* Reset the global parameters *)
4943: gotoTargetData := None;
4944: H.clear gotoTargetHash;
4945: gotoTargetNextAddr := 0;
4946: in
4947:
4948:
4949:
4950: (*
4951: ignore (E.log "endFunction %s at %t:@! sformals=%a@! slocals=%a@!"
4952: !currentFunctionFDEC.svar.vname d_thisloc
4953: (docList (chr ',') (fun v -> text v.vname))
4954: !currentFunctionFDEC.sformals
4955: (docList (chr ',') (fun v -> text v.vname))
4956: !currentFunctionFDEC.slocals);
4957: *)
4958:
4959: let rec dropFormals formals locals =
4960: match formals, locals with
4961: [], l -> l
4962: | f :: formals, l :: locals ->
4963: if f != l then
4964: E.s (bug "formal %s is not in locals (found instead %s)"
4965: f.vname l.vname);
4966: dropFormals formals locals
4967: | _ -> E.s (bug "Too few locals")
4968: in
4969: !currentFunctionFDEC.slocals
4970: <- dropFormals !currentFunctionFDEC.sformals
4971: (List.rev !currentFunctionFDEC.slocals);
4972: setMaxId !currentFunctionFDEC;
4973:
4974: (* Now go over the types of the formals and pull out the formals
4975: * with transparent union type. Replace them with some shadow
4976: * parameters and then add assignments *)
4977: let _ =
4978: let newformals, newbody =
4979: List.fold_right (* So that the formals come out in order *)
4980: (fun f (accform, accbody) ->
4981: match isTransparentUnion f.vtype with
4982: None -> (f :: accform, accbody)
4983: | Some fstfield ->
4984: (* A new shadow to be placed in the formals. Use
4985: * makeTempVar to update smaxid and all others. *)
4986: let shadow =
4987: makeTempVar !currentFunctionFDEC fstfield.ftype in
4988: (* Now take it out of the locals and replace it with
4989: * the current formal. It is not worth optimizing this
4990: * one *)
4991: !currentFunctionFDEC.slocals <-
4992: f ::
4993: (List.filter (fun x -> x.vid <> shadow.vid)
4994: !currentFunctionFDEC.slocals);
4995: (shadow :: accform,
4996: mkStmt (Instr [Set ((Var f, Field(fstfield,
4997: NoOffset)),
4998: Lval (var shadow),
4999: !currentLoc)]) :: accbody))
5000: !currentFunctionFDEC.sformals
5001: ([], !currentFunctionFDEC.sbody.bstmts)
5002: in
5003: !currentFunctionFDEC.sbody.bstmts <- newbody;
5004: (* To make sure sharing with the type is proper *)
5005: setFormals !currentFunctionFDEC newformals;
5006: in
5007:
5008: (* Now see whether we can fall through to the end of the function
5009: * *)
5010: (* weimer: Sat Dec 8 17:30:47 2001 MSVC NT kernel headers include
5011: * functions like long convert(x) { __asm { mov eax, x \n cdq } }
5012: * That set a return value via an ASM statement. As a result, I
5013: * am changing this so a final ASM statement does not count as
5014: * "fall through" for the purposes of this warning. *)
5015: let instrFallsThrough (i : instr) = match i with
5016: Set _ -> true
5017: | Call (None, Lval (Var e, NoOffset), _, _) ->
5018: (* See if this is exit, or if it has the noreturn attribute *)
5019: if e.vname = "exit" then false
5020: else if hasAttribute "noreturn" e.vattr then false
5021: else true
5022: | Call _ -> true
5023: | Asm _ -> false
5024: in
5025: let rec stmtFallsThrough (s: stmt) : bool =
5026: match s.skind with
5027: Instr(il) ->
5028: List.fold_left (fun acc elt ->
5029: acc && instrFallsThrough elt) true il
5030: | Return _ | Break _ | Continue _ -> false
5031: | Goto _ -> false
5032: | If (_, b1, b2, _) ->
5033: blockFallsThrough b1 || blockFallsThrough b2
5034: | Switch (e, b, targets, _) ->
5035: (* See if there is a "default" case *)
5036: if not
5037: (List.exists (fun s ->
5038: List.exists (function Default _ -> true | _ -> false)
5039: s.labels)
5040: targets) then begin
5041: (*
5042: ignore (E.log "Switch falls through because no default");
5043:
5044: *) true (* We fall through because there is no default *)
5045: end else begin
5046: (* We must examine all cases. If any falls through,
5047: * then the switch falls through. *)
5048: blockFallsThrough b
5049: end
5050: | Loop _ -> true (* Conservative *)
5051: | Block b -> blockFallsThrough b
5052: | TryFinally (b, h, _) -> blockFallsThrough h
5053: | TryExcept (b, _, h, _) -> true (* Conservative *)
5054: and blockFallsThrough b =
5055: let rec fall = function
5056: [] -> true
5057: | s :: rest ->
5058: if stmtFallsThrough s then begin
5059: (*
5060: ignore (E.log "Stmt %a falls through\n" d_stmt s);
5061: *)
5062: fall rest
5063: end else begin
5064: (*
5065: ignore (E.log "Stmt %a DOES NOT fall through\n"
5066: d_stmt s);
5067: *)
5068: (* If we are not falling thorough then maybe there
5069: * are labels who are *)
5070: labels rest
5071: end
5072: and labels = function
5073: [] -> false
5074: (* We have a label, perhaps we can jump here *)
5075: | s :: rest when s.labels <> [] ->
5076: (*
5077: ignore (E.log "invoking fall %a: %a\n"
5078: d_loc !currentLoc d_stmt s);
5079: *)
5080: fall (s :: rest)
5081: | _ :: rest -> labels rest
5082: in
5083: let res = fall b.bstmts in
5084: (*
5085: ignore (E.log "blockFallsThrough=%b %a\n" res d_block b);
5086: *)
5087: res
5088: in
5089: if blockFallsThrough !currentFunctionFDEC.sbody then begin
5090: let retval =
5091: match unrollType !currentReturnType with
5092: TVoid _ -> None
5093: | (TInt _ | TEnum _ | TFloat _ | TPtr _) as rt ->
5094: ignore (warn "Body of function %s falls-through. Adding a return statement\n" !currentFunctionFDEC.svar.vname);
5095: Some (mkCastT zero intType rt)
5096: | _ ->
5097: ignore (warn "Body of function %s falls-through and cannot find an appropriate return value\n" !currentFunctionFDEC.svar.vname);
5098: None
5099: in
5100: !currentFunctionFDEC.sbody.bstmts <-
5101: !currentFunctionFDEC.sbody.bstmts
5102: @ [mkStmt (Return(retval, endloc))]
5103: end;
5104:
5105: (* ignore (E.log "The env after finishing the body of %s:\n%t\n"
5106: n docEnv); *)
5107: cabsPushGlobal (GFun (!currentFunctionFDEC, funloc));
5108: empty
5109: with e -> begin
5110: ignore (E.log "error in collectFunction %s: %s\n"
5111: n (Printexc.to_string e));
5112: cabsPushGlobal (GAsm("error in function " ^ n, !currentLoc));
5113: empty
5114: end)
5115: () (* argument of E.withContext *)
5116: end (* FUNDEF *)
5117:
5118: | LINKAGE (n, loc, dl) ->
5119: currentLoc := convLoc loc;
5120: if n <> "C" then
5121: ignore (warn "Encountered linkage specification \"%s\"" n);
5122: if not isglobal then
5123: E.s (error "Encountered linkage specification in local scope");
5124: (* For now drop the linkage on the floor !!! *)
5125: List.iter
5126: (fun d ->
5127: let s = doDecl isglobal d in
5128: if isNotEmpty s then
5129: E.s (bug "doDecl returns non-empty statement for global"))
5130: dl;
5131: empty
5132:
5133: | NAMESPACE (n, loc, dl) ->
5134: currentLoc := convLoc loc;
5135: List.iter
5136: (fun d ->
5137: let s = doDecl isglobal d in
5138: if isNotEmpty s then
5139: E.s (bug "doDecl returns non-empty statement for global"))
5140: dl;
5141: empty
5142:
5143: | _ -> E.s (error "unexpected form of declaration")
5144:
5145: and doTypedef ((specs, nl): A.name_group) =
5146: try
5147: (* Do the specifiers exactly once *)
5148: let bt, sto, inl, attrs = doSpecList (suggestAnonName nl) specs in
5149: if sto <> NoStorage || inl then
5150: E.s (error "Storage or inline specifier not allowed in typedef");
5151: let createTypedef ((n,ndt,a,loc) : A.name) =
5152: (* E.s (error "doTypeDef") *)
5153: try
5154: let newTyp, tattr =
5155: doType AttrType bt (A.PARENTYPE(attrs, ndt, a)) in
5156: let newTyp' = cabsTypeAddAttributes tattr newTyp in
5157: (* Create a new name for the type. Use the same name space as that of
5158: * variables to avoid confusion between variable names and types. This
5159: * is actually necessary in some cases. *)
5160: let n', _ = newAlphaName true "" n in
5161: let ti = { tname = n'; ttype = newTyp'; treferenced = false } in
5162: (* Since we use the same name space, we might later hit a global with
5163: * the same name and we would want to change the name of the global.
5164: * It is better to change the name of the type instead. So, remember
5165: * all types whose names have changed *)
5166: H.add typedefs n' ti;
5167: let namedTyp = TNamed(ti, []) in
5168: (* Register the type. register it as local because we might be in a
5169: * local context *)
5170: addLocalToEnv (kindPlusName "type" n) (EnvTyp (TNamed(ti, [])));
5171: cabsPushGlobal (GType (ti, !currentLoc))
5172: with e -> begin
5173: ignore (E.log "Error on A.TYPEDEF (%s)\n"
5174: (Printexc.to_string e));
5175: cabsPushGlobal (GAsm ("booo_typedef:" ^ n, !currentLoc))
5176: end
5177: in
5178: List.iter createTypedef nl
5179: with e -> begin
5180: ignore (E.log "Error on A.TYPEDEF (%s)\n"
5181: (Printexc.to_string e));
5182: let fstname =
5183: match nl with
5184: [] -> "<missing name>"
5185: | (n, _, _, _) :: _ -> n
5186: in
5187: cabsPushGlobal (GAsm ("booo_typedef: " ^ fstname, !currentLoc))
5188: end
5189:
5190: and doOnlyTypedef (specs: A.spec_elem list) : unit =
5191: try
5192: let bt, sto, inl, attrs = doSpecList "" specs in
5193: if sto <> NoStorage || inl then
5194: E.s (error "Storage or inline specifier not allowed in typedef");
5195: let restyp, nattr = doType AttrType bt (A.PARENTYPE(attrs,
5196: A.JUSTBASE, [])) in
5197: if nattr <> [] then
5198: ignore (warn "Ignoring identifier attribute");
5199: (* doSpec will register the type. *)
5200: (* See if we are defining a composite or enumeration type, and in that
5201: * case move the attributes from the defined type into the composite type
5202: * *)
5203: let isadef =
5204: List.exists
5205: (function
5206: A.SpecType(A.Tstruct(_, Some _, _)) -> true
5207: | A.SpecType(A.Tunion(_, Some _, _)) -> true
5208: | A.SpecType(A.Tenum(_, Some _, _)) -> true
5209: | _ -> false) specs
5210: in
5211: match restyp with
5212: TComp(ci, al) ->
5213: if isadef then begin
5214: ci.cattr <- cabsAddAttributes ci.cattr al;
5215: (* The GCompTag was already added *)
5216: end else (* Add a GCompTagDecl *)
5217: cabsPushGlobal (GCompTagDecl(ci, !currentLoc))
5218: | TEnum(ei, al) ->
5219: if isadef then begin
5220: ei.eattr <- cabsAddAttributes ei.eattr al;
5221: end else
5222: cabsPushGlobal (GEnumTagDecl(ei, !currentLoc))
5223: | _ ->
5224: ignore (warn "Ignoring un-named typedef that does not introduce a struct or enumeration type\n")
5225:
5226: with e -> begin
5227: ignore (E.log "Error on A.ONLYTYPEDEF (%s)\n"
5228: (Printexc.to_string e));
5229: cabsPushGlobal (GAsm ("booo_typedef", !currentLoc))
5230: end
5231:
5232: and assignInit (lv: lval)
5233: (ie: init)
5234: (iet: typ)
5235: (acc: chunk) : chunk =
5236: match ie with
5237: SingleInit e ->
5238: let (_, e'') = castTo iet (typeOfLval lv) e in
5239: acc +++ (Set(lv, e'', !currentLoc))
5240: | CompoundInit (t, initl) ->
5241: foldLeftCompound
5242: ~doinit:(fun off i it acc ->
5243: assignInit (addOffsetLval off lv) i it acc)
5244: ~ct:t
5245: ~initl:initl
5246: ~acc:acc
5247: (*
5248: | ArrayInit (bt, len, initl) ->
5249: let idx = ref ( -1 ) in
5250: List.fold_left
5251: (fun acc i ->
5252: assignInit (addOffsetLval (Index(integer !idx, NoOffset)) lv) i bt acc)
5253: acc
5254: initl
5255: *)
5256: (* Now define the processors for body and statement *)
5257: and doBody (blk: A.block) : chunk =
5258: enterScope ();
5259: (* Rename the labels and add them to the environment *)
5260: List.iter (fun l -> ignore (genNewLocalLabel l)) blk.blabels;
5261: (* See if we have some attributes *)
5262: let battrs = doAttributes blk.A.battrs in
5263:
5264: let bodychunk =
5265: afterConversion
5266: (List.fold_left (* !!! @ evaluates its arguments backwards *)
5267: (fun prev s -> let res = doStatement s in prev @@ res)
5268: empty
5269: blk.A.bstmts)
5270: in
5271: exitScope ();
5272: if battrs = [] then
5273: bodychunk
5274: else begin
5275: let b = c2block bodychunk in
5276: b.battrs <- battrs;
5277: s2c (mkStmt (Block b))
5278: end
5279:
5280: and doStatement (s : A.statement) : chunk =
5281: try
5282: match s with
5283: A.NOP _ -> skipChunk
5284: | A.COMPUTATION (e, loc) ->
5285: currentLoc := convLoc loc;
5286: let (lasts, data) = !gnu_body_result in
5287: if lasts == s then begin (* This is the last in a GNU_BODY *)
5288: let (s', e', t') = doExp false e (AExp None) in
5289: data := Some (e', t'); (* Record the result *)
5290: s'
5291: end else
5292: let (s', _, _) = doExp false e ADrop in
5293: (* drop the side-effect free expression *)
5294: (* And now do some peep-hole optimizations *)
5295: s'
5296:
5297: | A.BLOCK (b, loc) ->
5298: currentLoc := convLoc loc;
5299: doBody b
5300:
5301: | A.SEQUENCE (s1, s2, loc) ->
5302: (doStatement s1) @@ (doStatement s2)
5303:
5304: | A.IF(e,st,sf,loc) ->
5305: let st' = doStatement st in
5306: let sf' = doStatement sf in
5307: currentLoc := convLoc loc;
5308: doCondition false e st' sf'
5309:
5310: | A.WHILE(e,s,loc) ->
5311: startLoop true;
5312: let s' = doStatement s in
5313: exitLoop ();
5314: let loc' = convLoc loc in
5315: currentLoc := loc';
5316: loopChunk ((doCondition false e skipChunk
5317: (breakChunk loc'))
5318: @@ s')
5319:
5320: | A.DOWHILE(e,s,loc) ->
5321: startLoop false;
5322: let s' = doStatement s in
5323: let loc' = convLoc loc in
5324: currentLoc := loc';
5325: let s'' =
5326: consLabContinue (doCondition false e skipChunk (breakChunk loc'))
5327: in
5328: exitLoop ();
5329: loopChunk (s' @@ s'')
5330:
5331: | A.FOR(fc1,e2,e3,s,loc) -> begin
5332: let loc' = convLoc loc in
5333: currentLoc := loc';
5334: enterScope (); (* Just in case we have a declaration *)
5335: let (se1, _, _) =
5336: match fc1 with
5337: FC_EXP e1 -> doExp false e1 ADrop
5338: | FC_DECL d1 -> (doDecl false d1, zero, voidType)
5339: in
5340: let (se3, _, _) = doExp false e3 ADrop in
5341: startLoop false;
5342: let s' = doStatement s in
5343: currentLoc := loc';
5344: let s'' = consLabContinue se3 in
5345: exitLoop ();
5346: let res =
5347: match e2 with
5348: A.NOTHING -> (* This means true *)
5349: se1 @@ loopChunk (s' @@ s'')
5350: | _ ->
5351: se1 @@ loopChunk ((doCondition false e2 skipChunk (breakChunk loc'))
5352: @@ s' @@ s'')
5353: in
5354: exitScope ();
5355: res
5356: end
5357: | A.BREAK loc ->
5358: let loc' = convLoc loc in
5359: currentLoc := loc';
5360: breakChunk loc'
5361:
5362: | A.CONTINUE loc ->
5363: let loc' = convLoc loc in
5364: currentLoc := loc';
5365: continueOrLabelChunk loc'
5366:
5367: | A.RETURN (A.NOTHING, loc) ->
5368: let loc' = convLoc loc in
5369: currentLoc := loc';
5370: (match !currentReturnType with
5371: TVoid _ -> ()
5372: | _ ->
5373: ignore (warn "Return statement without a value in function returning %a\n" d_type !currentReturnType));
5374: returnChunk None loc'
5375:
5376: | A.RETURN (e, loc) -> begin
5377: let loc' = convLoc loc in
5378: currentLoc := loc';
5379: (* Sometimes we return the result of a void function call *)
5380: match !currentReturnType with
5381: TVoid _ ->
5382: ignore (warn "Return statement with a value in function returning void");
5383: let (se, _, _) = doExp false e ADrop in
5384: se @@ returnChunk None loc'
5385: | _ ->
5386: let (se, e', et) =
5387: doExp false e (AExp (Some !currentReturnType)) in
5388: let (et'', e'') = castTo et (!currentReturnType) e' in
5389: se @@ (returnChunk (Some e'') loc')
5390: end
5391:
5392: | A.SWITCH (e, s, loc) ->
5393: let loc' = convLoc loc in
5394: currentLoc := loc';
5395: let (se, e', et) = doExp false e (AExp (Some intType)) in
5396: let (et'', e'') = castTo et intType e' in
5397: let s' = doStatement s in
5398: se @@ (switchChunk e'' s' loc')
5399:
5400: | A.CASE (e, s, loc) ->
5401: let loc' = convLoc loc in
5402: currentLoc := loc';
5403: let (se, e', et) = doExp false e (AExp None) in
5404: if isNotEmpty se then
5405: E.s (error "Case statement with a non-constant");
5406: caseRangeChunk [constFold false e'] loc' (doStatement s)
5407:
5408: | A.CASERANGE (el, eh, s, loc) ->
5409: let loc' = convLoc loc in
5410: currentLoc := loc';
5411: let (sel, el', etl) = doExp false el (AExp None) in
5412: let (seh, eh', etl) = doExp false eh (AExp None) in
5413: if isNotEmpty sel || isNotEmpty seh then
5414: E.s (error "Case statement with a non-constant");
5415: let il, ih =
5416: match constFold true el', constFold true eh' with
5417: Const(CInt64(il, _, _)), Const(CInt64(ih, _, _)) ->
5418: Int64.to_int il, Int64.to_int ih
5419: | _ -> E.s (unimp "Cannot understand the constants in case range")
5420: in
5421: if il > ih then
5422: E.s (error "Empty case range");
5423: let rec mkAll (i: int) =
5424: if i > ih then [] else integer i :: mkAll (i + 1)
5425: in
5426: caseRangeChunk (mkAll il) loc' (doStatement s)
5427:
5428:
5429: | A.DEFAULT (s, loc) ->
5430: let loc' = convLoc loc in
5431: currentLoc := loc';
5432: defaultChunk loc' (doStatement s)
5433:
5434: | A.LABEL (l, s, loc) ->
5435: let loc' = convLoc loc in
5436: currentLoc := loc';
5437: (* Lookup the label because it might have been locally defined *)
5438: consLabel (lookupLabel l) (doStatement s) loc' true
5439:
5440: | A.GOTO (l, loc) ->
5441: let loc' = convLoc loc in
5442: currentLoc := loc';
5443: (* Maybe we need to rename this label *)
5444: gotoChunk (lookupLabel l) loc'
5445:
5446: | A.COMPGOTO (e, loc) -> begin
5447: let loc' = convLoc loc in
5448: currentLoc := loc';
5449: (* Do the expression *)
5450: let se, e', t' = doExp false e (AExp (Some voidPtrType)) in
5451: match !gotoTargetData with
5452: Some (switchv, switch) -> (* We have already generated this one *)
5453: se
5454: @@ i2c(Set (var switchv, mkCast e' uintType, loc'))
5455: @@ s2c(mkStmt(Goto (ref switch, loc')))
5456:
5457: | None -> begin
5458: (* Make a temporary variable *)
5459: let vchunk = createLocal
5460: (TInt(IUInt, []), NoStorage, false, [])
5461: (("__compgoto", A.JUSTBASE, [], loc), A.NO_INIT)
5462: in
5463: if not (isEmpty vchunk) then
5464: E.s (unimp "Non-empty chunk in creating temporary for goto *");
5465: let switchv, _ =
5466: try lookupVar "__compgoto"
5467: with Not_found -> E.s (bug "Cannot find temporary for goto *");
5468: in
5469: (* Make a switch statement. We'll fill in the statements at the
5470: * end of the function *)
5471: let switch = mkStmt (Switch (Lval(var switchv),
5472: mkBlock [], [], loc')) in
5473: (* And make a label for it since we'll goto it *)
5474: switch.labels <- [Label ("__docompgoto", loc', false)];
5475: gotoTargetData := Some (switchv, switch);
5476: se @@ i2c (Set(var switchv, mkCast e' uintType, loc')) @@
5477: s2c switch
5478: end
5479: end
5480:
5481: | A.DEFINITION d ->
5482: doDecl false d
5483:
5484: | A.ASM (asmattr, tmpls, outs, ins, clobs, loc) ->
5485: (* Make sure all the outs are variables *)
5486: let loc' = convLoc loc in
5487: let attr' = doAttributes asmattr in
5488: currentLoc := loc';
5489: let temps : (lval * varinfo) list ref = ref [] in
5490: let stmts : chunk ref = ref empty in
5491: let outs' =
5492: List.map
5493: (fun (c, e) ->
5494: let (se, e', t) = doExp false e (AExp None) in
5495: let lv =
5496: match e' with
5497: | Lval lval
5498: | StartOf lval -> lval
5499: | _ -> E.s (error "Expected lval for ASM outputs")
5500: in
5501: stmts := !stmts @@ se;
5502: (c, lv)) outs
5503: in
5504: (* Get the side-effects out of expressions *)
5505: let ins' =
5506: List.map
5507: (fun (c, e) ->
5508: let (se, e', et) = doExp false e (AExp None) in
5509: stmts := !stmts @@ se;
5510: (c, e'))
5511: ins
5512: in
5513: !stmts @@
5514: (i2c (Asm(attr', tmpls, outs', ins', clobs, loc')))
5515:
5516: | TRY_FINALLY (b, h, loc) ->
5517: let loc' = convLoc loc in
5518: currentLoc := loc';
5519: let b': chunk = doBody b in
5520: let h': chunk = doBody h in
5521: if b'.cases <> [] || h'.cases <> [] then
5522: E.s (error "Try statements cannot contain switch cases");
5523:
5524: s2c (mkStmt (TryFinally (c2block b', c2block h', loc')))
5525:
5526: | TRY_EXCEPT (b, e, h, loc) ->
5527: let loc' = convLoc loc in
5528: currentLoc := loc';
5529: let b': chunk = doBody b in
5530: (* Now do e *)
5531: let ((se: chunk), e', t') = doExp false e (AExp None) in
5532: let h': chunk = doBody h in
5533: if b'.cases <> [] || h'.cases <> [] || se.cases <> [] then
5534: E.s (error "Try statements cannot contain switch cases");
5535: (* Now take se and try to convert it to a list of instructions. This
5536: * might not be always possible *)
5537: let il' =
5538: match compactStmts se.stmts with
5539: [] -> se.postins
5540: | [ s ] -> begin
5541: match s.skind with
5542: Instr il -> il @ se.postins
5543: | _ -> E.s (error "Except expression contains unexpected statement")
5544: end
5545: | _ -> E.s (error "Except expression contains too many statements")
5546: in
5547: s2c (mkStmt (TryExcept (c2block b', (il', e'), c2block h', loc')))
5548:
5549: with e -> begin
5550: (ignore (E.log "Error in doStatement (%s)\n" (Printexc.to_string e)));
5551: consLabel "booo_statement" empty (convLoc (get_statementloc s)) false
5552: end
5553:
5554:
5555: (* Translate a file *)
5556: let convFile ((fname : string), (dl : Flx_cil_cabs.definition list)) : Flx_cil_cil.file =
5557: (* Clean up the global types *)
5558: E.hadErrors := false;
5559: initGlobals();
5560: startFile ();
5561: H.clear compInfoNameEnv;
5562: H.clear enumInfoNameEnv;
5563: H.clear mustTurnIntoDef;
5564: H.clear alreadyDefined;
5565: H.clear staticLocals;
5566: H.clear typedefs;
5567: H.clear isomorphicStructs;
5568: annonCompFieldNameId := 0;
5569: if !E.verboseFlag || !Flx_cil_cilutil.printStages then
5570: ignore (E.log "Converting CABS->CIL\n");
5571: (* Setup the built-ins, but do not add their prototypes to the file *)
5572: let setupBuiltin name (resTyp, argTypes, isva) =
5573: let v =
5574: makeGlobalVar name (TFun(resTyp,
5575: Some (List.map (fun at -> ("", at, []))
5576: argTypes),
5577: isva, [])) in
5578: ignore (alphaConvertVarAndAddToEnv true v)
5579: in
5580: H.iter setupBuiltin (if !msvcMode then msvcBuiltins else gccBuiltins);
5581:
5582: let globalidx = ref 0 in
5583: let doOneGlobal (d: A.definition) =
5584: let s = doDecl true d in
5585: if isNotEmpty s then
5586: E.s (bug "doDecl returns non-empty statement for global");
5587: (* See if this is one of the globals which we can leave alone. Increment
5588: * globalidx and see if we must leave this alone. *)
5589: if
5590: (match d with
5591: A.DECDEF _ -> true
5592: | A.FUNDEF _ -> true
5593: | _ -> false) && (incr globalidx; !globalidx = !nocil) then begin
5594: (* Create a file where we put the CABS output *)
5595: let temp_cabs_name = "__temp_cabs" in
5596: let temp_cabs = open_out temp_cabs_name in
5597: (* Now print the CABS in there *)
5598: Flx_cil_cprint.commit (); Flx_cil_cprint.flush ();
5599: let old = !Flx_cil_cprint.out in (* Save the old output channel *)
5600: Flx_cil_cprint.out := temp_cabs;
5601: Flx_cil_cprint.print_def d;
5602: Flx_cil_cprint.commit (); Flx_cil_cprint.flush ();
5603: flush !Flx_cil_cprint.out;
5604: Flx_cil_cprint.out := old;
5605: close_out temp_cabs;
5606: (* Now read everythign in *and create a GText from it *)
5607: let temp_cabs = open_in temp_cabs_name in
5608: let buff = Buffer.create 1024 in
5609: Buffer.add_string buff "// Start of CABS form\n";
5610: Buffer.add_channel buff temp_cabs (in_channel_length temp_cabs);
5611: Buffer.add_string buff "// End of CABS form\n";
5612: close_in temp_cabs;
5613: (* Try to pop the last thing in the file *)
5614: (match !theFile with
5615: _ :: rest -> theFile := rest
5616: | _ -> ());
5617: (* Insert in the file a GText *)
5618: cabsPushGlobal (GText(Buffer.contents buff))
5619: end
5620: in
5621: List.iter doOneGlobal dl;
5622: let globals = ref (popGlobals ()) in
5623:
5624: H.clear noProtoFunctions;
5625: H.clear mustTurnIntoDef;
5626: H.clear alreadyDefined;
5627: H.clear compInfoNameEnv;
5628: H.clear enumInfoNameEnv;
5629: H.clear isomorphicStructs;
5630: H.clear staticLocals;
5631: H.clear typedefs;
5632: H.clear env;
5633: H.clear genv;
5634: if false then ignore (E.log "Flx_cil_cabs2cil converted %d globals\n" !globalidx);
5635: (* We are done *)
5636: { fileName = fname;
5637: globals = !globals;
5638: globinit = None;
5639: globinitcalled = false;
5640: }
5641:
Start ocaml section to src/flx_cil_cabs2cil.mli[1
/1
]
1: # 19813 "./lpsrc/flx_cil.ipk"
2: val convFile: Flx_cil_cabs.file -> Flx_cil_cil.file
3:
4: (* Set this integer to the index of the global to be left in CABS form. Use
5: * -1 to disable *)
6: val nocil: int ref
7:
8: (* Indicates whether we're allowed to duplicate small chunks of code. *)
9: val allowDuplication: bool ref
10:
Start ocaml section to src/flx_cil_patch.ml[1
/1
]
1: # 19824 "./lpsrc/flx_cil.ipk"
2:
3:
4: (* patch.ml *)
5: (* CABS file patching *)
6:
7: open Flx_cil_cabs
8: open Flx_cil_cabs_helper
9: open Flx_cil_trace
10: open Flx_cil_pretty
11: open Flx_cil_cabsvisit
12:
13: (* binding of a unification variable to a syntactic construct *)
14: type binding =
15: | BSpecifier of string * spec_elem list
16: | BName of string * string
17: | BExpr of string * expression
18:
19: (* thrown when unification fails *)
20: exception NoMatch
21:
22: (* thrown when an attempt to find the associated binding fails *)
23: exception BadBind of string
24:
25: (* trying to isolate performance problems; will hide all the *)
26: (* potentially expensive debugging output behind "if verbose .." *)
27: let verbose : bool = true
28:
29:
30: (* raise NoMatch if x and y are not equal *)
31: let mustEq (x : 'a) (y : 'a) : unit =
32: begin
33: if (x <> y) then (
34: if verbose then
35: (trace "patchDebug" (dprintf "mismatch by structural disequality\n"));
36: raise NoMatch
37: )
38: end
39:
40: (* why isn't this in the core Ocaml library? *)
41: let identity x = x
42:
43:
44: let isPatternVar (s : string) : bool =
45: begin
46: ((String.length s) >= 1) && ((String.get s 0) = '@')
47: end
48:
49: (* 's' is actually "@name(blah)"; extract the 'blah' *)
50: let extractPatternVar (s : string) : string =
51: (*(trace "patch" (dprintf "extractPatternVar %s\n" s));*)
52: (String.sub s 6 ((String.length s) - 7))
53:
54:
55: (* a few debugging printers.. *)
56: let printExpr (e : expression) =
57: begin
58: if (verbose && traceActive "patchDebug") then (
59: Flx_cil_cprint.print_expression e; Flx_cil_cprint.force_new_line ();
60: Flx_cil_cprint.flush ()
61: )
62: end
63:
64: let printSpec (spec: spec_elem list) =
65: begin
66: if (verbose && traceActive "patchDebug") then (
67: Flx_cil_cprint.print_specifiers spec; Flx_cil_cprint.force_new_line ();
68: Flx_cil_cprint.flush ()
69: )
70: end
71:
72: let printSpecs (pat : spec_elem list) (tgt : spec_elem list) =
73: begin
74: (printSpec pat);
75: (printSpec tgt)
76: end
77:
78: let printDecl (pat : name) (tgt : name) =
79: begin
80: if (verbose && traceActive "patchDebug") then (
81: Flx_cil_cprint.print_name pat; Flx_cil_cprint.force_new_line ();
82: Flx_cil_cprint.print_name tgt; Flx_cil_cprint.force_new_line ();
83: Flx_cil_cprint.flush ()
84: )
85: end
86:
87: let printDeclType (pat : decl_type) (tgt : decl_type) =
88: begin
89: if (verbose && traceActive "patchDebug") then (
90: Flx_cil_cprint.print_decl "__missing_field_name" pat; Flx_cil_cprint.force_new_line ();
91: Flx_cil_cprint.print_decl "__missing_field_name" tgt; Flx_cil_cprint.force_new_line ();
92: Flx_cil_cprint.flush ()
93: )
94: end
95:
96: let printDefn (d : definition) =
97: begin
98: if (verbose && traceActive "patchDebug") then (
99: Flx_cil_cprint.print_def d;
100: Flx_cil_cprint.flush ()
101: )
102: end
103:
104:
105: (* class to describe how to modify the tree for subtitution *)
106: class substitutor (bindings : binding list) = object(self)
107: inherit nopFlx_cil_cabsVisitor as super
108:
109: (* look in the binding list for a given name *)
110: method findBinding (name : string) : binding =
111: begin
112: try
113: (List.find
114: (fun b ->
115: match b with
116: | BSpecifier(n, _) -> n=name
117: | BName(n, _) -> n=name
118: | BExpr(n, _) -> n=name)
119: bindings)
120: with
121: Not_found -> raise (BadBind ("name not found: " ^ name))
122: end
123:
124: method vexpr (e:expression) : expression visitAction =
125: begin
126: match e with
127: | EXPR_PATTERN(name) -> (
128: match (self#findBinding name) with
129: | BExpr(_, expr) -> ChangeTo(expr) (* substitute bound expression *)
130: | _ -> raise (BadBind ("wrong type: " ^ name))
131: )
132: | _ -> DoChildren
133: end
134:
135: (* use of a name *)
136: method vvar (s:string) : string =
137: begin
138: if (isPatternVar s) then (
139: let nameString = (extractPatternVar s) in
140: match (self#findBinding nameString) with
141: | BName(_, str) -> str (* substitute *)
142: | _ -> raise (BadBind ("wrong type: " ^ nameString))
143: )
144: else
145: s
146: end
147:
148: (* binding introduction of a name *)
149: method vname (k: nameKind) (spec: specifier) (n: name) : name visitAction =
150: begin
151: match n with (s (*variable name*), dtype, attrs, loc) -> (
152: let replacement = (self#vvar s) in (* use replacer from above *)
153: if (s <> replacement) then
154: ChangeTo(replacement, dtype, attrs, loc)
155: else
156: DoChildren (* no replacement *)
157: )
158: end
159:
160: method vspec (specList: specifier) : specifier visitAction =
161: begin
162: if verbose then (trace "patchDebug" (dprintf "substitutor: vspec\n"));
163: (printSpec specList);
164:
165: (* are any of the specifiers SpecPatterns? we have to check the entire *)
166: (* list, not just the head, because e.g. "typedef @specifier(foo)" has *)
167: (* "typedef" as the head of the specifier list *)
168: if (List.exists (fun elt -> match elt with
169: | SpecPattern(_) -> true
170: | _ -> false)
171: specList) then begin
172: (* yes, replace the existing list with one got by *)
173: (* replacing all occurrences of SpecPatterns *)
174: (trace "patchDebug" (dprintf "at least one spec pattern\n"));
175: ChangeTo
176: (List.flatten
177: (List.map
178: (* for each specifier element, yield the specifier list *)
179: (* to which it maps; then we'll flatten the final result *)
180: (fun elt ->
181: match elt with
182: | SpecPattern(name) -> (
183: match (self#findBinding name) with
184: | BSpecifier(_, replacement) -> (
185: (trace "patchDebug" (dprintf "replacing pattern %s\n" name));
186: replacement
187: )
188: | _ -> raise (BadBind ("wrong type: " ^ name))
189: )
190: | _ -> [elt] (* leave this one alone *)
191: )
192: specList
193: )
194: )
195: end
196: else
197: (* none of the specifiers in specList are patterns *)
198: DoChildren
199: end
200:
201: method vtypespec (tspec: typeSpecifier) : typeSpecifier visitAction =
202: begin
203: match tspec with
204: | Tnamed(str) when (isPatternVar str) ->
205: ChangeTo(Tnamed(self#vvar str))
206: | Tstruct(str, fields, extraAttrs) when (isPatternVar str) -> (
207: (trace "patchDebug" (dprintf "substituting %s\n" str));
208: ChangeDoChildrenPost(Tstruct((self#vvar str), fields, extraAttrs), identity)
209: )
210: | Tunion(str, fields, extraAttrs) when (isPatternVar str) ->
211: (trace "patchDebug" (dprintf "substituting %s\n" str));
212: ChangeDoChildrenPost(Tunion((self#vvar str), fields, extraAttrs), identity)
213: | _ -> DoChildren
214: end
215:
216: end
217:
218:
219: (* why can't I have forward declarations in the language?!! *)
220: let unifyExprFwd : (expression -> expression -> binding list) ref
221: = ref (fun e e -> [])
222:
223:
224: (* substitution for expressions *)
225: let substExpr (bindings : binding list) (expr : expression) : expression =
226: begin
227: if verbose then
228: (trace "patchDebug" (dprintf "substExpr with %d bindings\n" (List.length bindings)));
229: (printExpr expr);
230:
231: (* apply the transformation *)
232: let result = (visit_cabsExpression (new substitutor bindings :> cabsVisitor) expr) in
233: (printExpr result);
234:
235: result
236: end
237:
238: let d_loc (_:unit) (loc: cabsloc) : doc =
239: text loc.filename ++ chr ':' ++ num loc.lineno
240:
241:
242: (* class to describe how to modify the tree when looking for places *)
243: (* to apply expression transformers *)
244: class exprTransformer (srcpattern : expression) (destpattern : expression)
245: (patchline : int) (srcloc : cabsloc) = object(self)
246: inherit nopFlx_cil_cabsVisitor as super
247:
248: method vexpr (e:expression) : expression visitAction =
249: begin
250: (* see if the source pattern matches this subexpression *)
251: try (
252: let bindings = (!unifyExprFwd srcpattern e) in
253:
254: (* match! *)
255: (trace "patch" (dprintf "expr match: patch line %d, src %a\n"
256: patchline d_loc srcloc));
257: ChangeTo(substExpr bindings destpattern)
258: )
259:
260: with NoMatch -> (
261: (* doesn't apply *)
262: DoChildren
263: )
264: end
265:
266: (* other constructs left unchanged *)
267: end
268:
269:
270: let unifyList (pat : 'a list) (tgt : 'a list)
271: (unifyElement : 'a -> 'a -> binding list) : binding list =
272: begin
273: if verbose then
274: (trace "patchDebug" (dprintf "unifyList (pat len %d, tgt len %d)\n"
275: (List.length pat) (List.length tgt)));
276:
277: (* walk down the lists *)
278: let rec loop pat tgt : binding list =
279: match pat, tgt with
280: | [], [] -> []
281: | (pelt :: prest), (telt :: trest) ->
282: (unifyElement pelt telt) @
283: (loop prest trest)
284: | _,_ -> (
285: (* no match *)
286: if verbose then (
287: (trace "patchDebug" (dprintf "mismatching list length\n"));
288: );
289: raise NoMatch
290: )
291: in
292: (loop pat tgt)
293: end
294:
295:
296: let gettime () : float =
297: (Unix.times ()).Unix.tms_utime
298:
299: let rec applyFlx_cil_patch (patchFile : file) (srcFile : file) : file =
300: begin
301: let patch : definition list = (snd patchFile) in
302: let srcFname : string = (fst srcFile) in
303: let src : definition list = (snd srcFile) in
304:
305: (trace "patchTime" (dprintf "applyFlx_cil_patch start: %f\n" (gettime ())));
306: if (traceActive "patchDebug") then
307: Flx_cil_cprint.out := stdout (* hack *)
308: else ();
309:
310: (* more hackery *)
311: unifyExprFwd := unifyExpr;
312:
313: (* patch a single source definition, yield transformed *)
314: let rec patchDefn (patch : definition list) (d : definition) : definition list =
315: begin
316: match patch with
317: | TRANSFORMER(srcpattern, destpattern, loc) :: rest -> (
318: if verbose then
319: (trace "patchDebug"
320: (dprintf "considering applying defn pattern at line %d to src at %a\n"
321: loc.lineno d_loc (get_definitionloc d)));
322:
323: (* see if the source pattern matches the definition 'd' we have *)
324: try (
325: let bindings = (unifyDefn srcpattern d) in
326:
327: (* we have a match! apply the substitutions *)
328: (trace "patch" (dprintf "defn match: patch line %d, src %a\n"
329: loc.lineno d_loc (get_definitionloc d)));
330:
331: (List.map (fun destElt -> (substDefn bindings destElt)) destpattern)
332: )
333:
334: with NoMatch -> (
335: (* no match, continue down list *)
336: (*(trace "patch" (dprintf "no match\n"));*)
337: (patchDefn rest d)
338: )
339: )
340:
341: | EXPRTRANSFORMER(srcpattern, destpattern, loc) :: rest -> (
342: if verbose then
343: (trace "patchDebug"
344: (dprintf "considering applying expr pattern at line %d to src at %a\n"
345: loc.lineno d_loc (get_definitionloc d)));
346:
347: (* walk around in 'd' looking for expressions to modify *)
348: let dList = (visit_cabsDefinition
349: ((new exprTransformer srcpattern destpattern
350: loc.lineno (get_definitionloc d))
351: :> cabsVisitor)
352: d
353: ) in
354:
355: (* recursively invoke myself to try additional patches *)
356: (* since visit_cabsDefinition might return a list, I'll try my *)
357: (* addtional patches on every yielded definition, then collapse *)
358: (* all of them into a single list *)
359: (List.flatten (List.map (fun d -> (patchDefn rest d)) dList))
360: )
361:
362: | _ :: rest -> (
363: (* not a transformer; just keep going *)
364: (patchDefn rest d)
365: )
366: | [] -> (
367: (* reached the end of the patch file with no match *)
368: [d] (* have to wrap it in a list ... *)
369: )
370: end in
371:
372: (* transform all the definitions *)
373: let result : definition list =
374: (List.flatten (List.map (fun d -> (patchDefn patch d)) src)) in
375:
376: (*Flx_cil_cprint.print_defs result;*)
377:
378: if (traceActive "patchDebug") then (
379: (* avoid flush bug? yes *)
380: Flx_cil_cprint.force_new_line ();
381: Flx_cil_cprint.flush ()
382: );
383:
384: (trace "patchTime" (dprintf "applyFlx_cil_patch finish: %f\n" (gettime ())));
385: (srcFname, result)
386: end
387:
388:
389: (* given a definition pattern 'pat', and a target concrete defintion 'tgt', *)
390: (* determine if they can be unified; if so, return the list of bindings of *)
391: (* unification variables in pat; otherwise raise NoMatch *)
392: and unifyDefn (pat : definition) (tgt : definition) : binding list =
393: begin
394: match pat, tgt with
395: | DECDEF((pspecifiers, pdeclarators), _),
396: DECDEF((tspecifiers, tdeclarators), _) -> (
397: if verbose then
398: (trace "patchDebug" (dprintf "unifyDefn of DECDEFs\n"));
399: (unifySpecifiers pspecifiers tspecifiers) @
400: (unifyInitDeclarators pdeclarators tdeclarators)
401: )
402:
403: | TYPEDEF((pspec, pdecl), _),
404: TYPEDEF((tspec, tdecl), _) -> (
405: if verbose then
406: (trace "patchDebug" (dprintf "unifyDefn of TYPEDEFs\n"));
407: (unifySpecifiers pspec tspec) @
408: (unifyDeclarators pdecl tdecl)
409: )
410:
411: | ONLYTYPEDEF(pspec, _),
412: ONLYTYPEDEF(tspec, _) -> (
413: if verbose then
414: (trace "patchDebug" (dprintf "unifyDefn of ONLYTYPEDEFs\n"));
415: (unifySpecifiers pspec tspec)
416: )
417:
418: | _, _ -> (
419: if verbose then
420: (trace "patchDebug" (dprintf "mismatching definitions\n"));
421: raise NoMatch
422: )
423: end
424:
425: and unifySpecifier (pat : spec_elem) (tgt : spec_elem) : binding list =
426: begin
427: if verbose then
428: (trace "patchDebug" (dprintf "unifySpecifier\n"));
429: (printSpecs [pat] [tgt]);
430:
431: if (pat = tgt) then [] else
432:
433: match pat, tgt with
434: | SpecType(tspec1), SpecType(tspec2) ->
435: (unifyTypeSpecifier tspec1 tspec2)
436: | SpecPattern(name), _ ->
437: (* record that future occurrances of @specifier(name) will yield this specifier *)
438: if verbose then
439: (trace "patchDebug" (dprintf "found specifier match for %s\n" name));
440: [BSpecifier(name, [tgt])]
441: | _,_ -> (
442: (* no match *)
443: if verbose then (
444: (trace "patchDebug" (dprintf "mismatching specifiers\n"));
445: );
446: raise NoMatch
447: )
448: end
449:
450: and unifySpecifiers (pat : spec_elem list) (tgt : spec_elem list) : binding list =
451: begin
452: if verbose then
453: (trace "patchDebug" (dprintf "unifySpecifiers\n"));
454: (printSpecs pat tgt);
455:
456: (* canonicalize the specifiers by sorting them *)
457: let pat' = (List.stable_sort compare pat) in
458: let tgt' = (List.stable_sort compare tgt) in
459:
460: (* if they are equal, they match with no further checking *)
461: if (pat' = tgt') then [] else
462:
463: (* walk down the lists; don't walk the sorted lists because the *)
464: (* pattern must always be last, if it occurs *)
465: let rec loop pat tgt : binding list =
466: match pat, tgt with
467: | [], [] -> []
468: | [SpecPattern(name)], _ ->
469: (* final SpecPattern matches anything which comes after *)
470: (* record that future occurrences of @specifier(name) will yield this specifier *)
471: if verbose then
472: (trace "patchDebug" (dprintf "found specifier match for %s\n" name));
473: [BSpecifier(name, tgt)]
474: | (pspec :: prest), (tspec :: trest) ->
475: (unifySpecifier pspec tspec) @
476: (loop prest trest)
477: | _,_ -> (
478: (* no match *)
479: if verbose then (
480: (trace "patchDebug" (dprintf "mismatching specifier list length\n"));
481: );
482: raise NoMatch
483: )
484: in
485: (loop pat tgt)
486: end
487:
488: and unifyTypeSpecifier (pat: typeSpecifier) (tgt: typeSpecifier) : binding list =
489: begin
490: if verbose then
491: (trace "patchDebug" (dprintf "unifyTypeSpecifier\n"));
492:
493: if (pat = tgt) then [] else
494:
495: match pat, tgt with
496: | Tnamed(s1), Tnamed(s2) -> (unifyString s1 s2)
497: | Tstruct(name1, None, _), Tstruct(name2, None, _) ->
498: (unifyString name1 name2)
499: | Tstruct(name1, Some(fields1), _), Tstruct(name2, Some(fields2), _) ->
500: (* ignoring extraAttrs b/c we're just trying to come up with a list
501: * of substitutions, and there's no unify_attributes function, and
502: * I don't care at this time about checking that they are equal .. *)
503: (unifyString name1 name2) @
504: (unifyList fields1 fields2 unifyField)
505: | Tunion(name1, None, _), Tstruct(name2, None, _) ->
506: (unifyString name1 name2)
507: | Tunion(name1, Some(fields1), _), Tunion(name2, Some(fields2), _) ->
508: (unifyString name1 name2) @
509: (unifyList fields1 fields2 unifyField)
510: | Tenum(name1, None, _), Tenum(name2, None, _) ->
511: (unifyString name1 name2)
512: | Tenum(name1, Some(items1), _), Tenum(name2, Some(items2), _) ->
513: (mustEq items1 items2); (* enum items *)
514: (unifyString name1 name2)
515: | TtypeofE(exp1), TtypeofE(exp2) ->
516: (unifyExpr exp1 exp2)
517: | TtypeofT(spec1, dtype1), TtypeofT(spec2, dtype2) ->
518: (unifySpecifiers spec1 spec2) @
519: (unifyDeclType dtype1 dtype2)
520: | _ -> (
521: if verbose then (trace "patchDebug" (dprintf "mismatching typeSpecifiers\n"));
522: raise NoMatch
523: )
524: end
525:
526: and unifyField (pat : field_group) (tgt : field_group) : binding list =
527: begin
528: match pat,tgt with (spec1, list1), (spec2, list2) -> (
529: (unifySpecifiers spec1 spec2) @
530: (unifyList list1 list2 unifyNameExprOpt)
531: )
532: end
533:
534: and unifyNameExprOpt (pat : name * expression option)
535: (tgt : name * expression option) : binding list =
536: begin
537: match pat,tgt with
538: | (name1, None), (name2, None) -> (unifyName name1 name2)
539: | (name1, Some(exp1)), (name2, Some(exp2)) ->
540: (unifyName name1 name2) @
541: (unifyExpr exp1 exp2)
542: | _,_ -> []
543: end
544:
545: and unifyName (pat : name) (tgt : name) : binding list =
546: begin
547: match pat,tgt with (pstr, pdtype, pattrs, ploc), (tstr, tdtype, tattrs, tloc) ->
548: (mustEq pattrs tattrs);
549: (unifyString pstr tstr) @
550: (unifyDeclType pdtype tdtype)
551: end
552:
553: and unifyInitDeclarators (pat : init_name list) (tgt : init_name list) : binding list =
554: begin
555: (*
556: if verbose then
557: (trace "patchDebug" (dprintf "unifyInitDeclarators, pat %d, tgt %d\n"
558: (List.length pat) (List.length tgt)));
559: *)
560:
561: match pat, tgt with
562: | ((pdecl, piexpr) :: prest),
563: ((tdecl, tiexpr) :: trest) ->
564: (unifyDeclarator pdecl tdecl) @
565: (unifyInitExpr piexpr tiexpr) @
566: (unifyInitDeclarators prest trest)
567: | [], [] -> []
568: | _, _ -> (
569: if verbose then
570: (trace "patchDebug" (dprintf "mismatching init declarators\n"));
571: raise NoMatch
572: )
573: end
574:
575: and unifyDeclarators (pat : name list) (tgt : name list) : binding list =
576: (unifyList pat tgt unifyDeclarator)
577:
578: and unifyDeclarator (pat : name) (tgt : name) : binding list =
579: begin
580: if verbose then
581: (trace "patchDebug" (dprintf "unifyDeclarator\n"));
582: (printDecl pat tgt);
583:
584: match pat, tgt with
585: | (pname, pdtype, pattr, ploc),
586: (tname, tdtype, tattr, tloc) ->
587: (mustEq pattr tattr);
588: (unifyDeclType pdtype tdtype) @
589: (unifyString pname tname)
590: end
591:
592: and unifyDeclType (pat : decl_type) (tgt : decl_type) : binding list =
593: begin
594: if verbose then
595: (trace "patchDebug" (dprintf "unifyDeclType\n"));
596: (printDeclType pat tgt);
597:
598: match pat, tgt with
599: | JUSTBASE, JUSTBASE -> []
600: | PARENTYPE(pattr1, ptype, pattr2),
601: PARENTYPE(tattr1, ttype, tattr2) ->
602: (mustEq pattr1 tattr1);
603: (mustEq pattr2 tattr2);
604: (unifyDeclType ptype ttype)
605: | ARRAY(ptype, pattr, psz),
606: ARRAY(ttype, tattr, tsz) ->
607: (mustEq pattr tattr);
608: (unifyDeclType ptype ttype) @
609: (unifyExpr psz tsz)
610: | PTR(pattr, ptype),
611: PTR(tattr, ttype) ->
612: (mustEq pattr tattr);
613: (unifyDeclType ptype ttype)
614: | PROTO(ptype, pformals, pva),
615: PROTO(ttype, tformals, tva) ->
616: (mustEq pva tva);
617: (unifyDeclType ptype ttype) @
618: (unifySingleNames pformals tformals)
619: | _ -> (
620: if verbose then
621: (trace "patchDebug" (dprintf "mismatching decl_types\n"));
622: raise NoMatch
623: )
624: end
625:
626: and unifySingleNames (pat : single_name list) (tgt : single_name list) : binding list =
627: begin
628: if verbose then
629: (trace "patchDebug" (dprintf "unifySingleNames, pat %d, tgt %d\n"
630: (List.length pat) (List.length tgt)));
631:
632: match pat, tgt with
633: | [], [] -> []
634: | (pspec, pdecl) :: prest,
635: (tspec, tdecl) :: trest ->
636: (unifySpecifiers pspec tspec) @
637: (unifyDeclarator pdecl tdecl) @
638: (unifySingleNames prest trest)
639: | _, _ -> (
640: if verbose then
641: (trace "patchDebug" (dprintf "mismatching single_name lists\n"));
642: raise NoMatch
643: )
644: end
645:
646: and unifyString (pat : string) (tgt : string) : binding list =
647: begin
648: (* equal? match with no further ado *)
649: if (pat = tgt) then [] else
650:
651: (* is the pattern a variable? *)
652: if (isPatternVar pat) then
653: (* pat is actually "@name(blah)"; extract the 'blah' *)
654: let varname = (extractPatternVar pat) in
655:
656: (* when substituted, this name becomes 'tgt' *)
657: if verbose then
658: (trace "patchDebug" (dprintf "found name match for %s\n" varname));
659: [BName(varname, tgt)]
660:
661: else (
662: if verbose then
663: (trace "patchDebug" (dprintf "mismatching names: %s and %s\n" pat tgt));
664: raise NoMatch
665: )
666: end
667:
668: and unifyExpr (pat : expression) (tgt : expression) : binding list =
669: begin
670: (* if they're equal, that's good enough *)
671: if (pat = tgt) then [] else
672:
673: (* shorter name *)
674: let ue = unifyExpr in
675:
676: (* because of the equality check above, I can omit some cases *)
677: match pat, tgt with
678: | UNARY(pop, pexpr),
679: UNARY(top, texpr) ->
680: (mustEq pop top);
681: (ue pexpr texpr)
682: | BINARY(pop, pexp1, pexp2),
683: BINARY(top, texp1, texp2) ->
684: (mustEq pop top);
685: (ue pexp1 texp1) @
686: (ue pexp2 texp2)
687: | QUESTION(p1, p2, p3),
688: QUESTION(t1, t2, t3) ->
689: (ue p1 t1) @
690: (ue p2 t2) @
691: (ue p3 t3)
692: | CAST((pspec, ptype), piexpr),
693: CAST((tspec, ttype), tiexpr) ->
694: (mustEq ptype ttype);
695: (unifySpecifiers pspec tspec) @
696: (unifyInitExpr piexpr tiexpr)
697: | CALL(pfunc, pargs),
698: CALL(tfunc, targs) ->
699: (ue pfunc tfunc) @
700: (unifyExprs pargs targs)
701: | COMMA(pexprs),
702: COMMA(texprs) ->
703: (unifyExprs pexprs texprs)
704: | EXPR_SIZEOF(pexpr),
705: EXPR_SIZEOF(texpr) ->
706: (ue pexpr texpr)
707: | TYPE_SIZEOF(pspec, ptype),
708: TYPE_SIZEOF(tspec, ttype) ->
709: (mustEq ptype ttype);
710: (unifySpecifiers pspec tspec)
711: | EXPR_ALIGNOF(pexpr),
712: EXPR_ALIGNOF(texpr) ->
713: (ue pexpr texpr)
714: | TYPE_ALIGNOF(pspec, ptype),
715: TYPE_ALIGNOF(tspec, ttype) ->
716: (mustEq ptype ttype);
717: (unifySpecifiers pspec tspec)
718: | INDEX(parr, pindex),
719: INDEX(tarr, tindex) ->
720: (ue parr tarr) @
721: (ue pindex tindex)
722: | MEMBEROF(pexpr, pfield),
723: MEMBEROF(texpr, tfield) ->
724: (mustEq pfield tfield);
725: (ue pexpr texpr)
726: | MEMBEROFPTR(pexpr, pfield),
727: MEMBEROFPTR(texpr, tfield) ->
728: (mustEq pfield tfield);
729: (ue pexpr texpr)
730: | GNU_BODY(pblock),
731: GNU_BODY(tblock) ->
732: (mustEq pblock tblock);
733: []
734: | EXPR_PATTERN(name), _ ->
735: (* match, and contribute binding *)
736: if verbose then
737: (trace "patchDebug" (dprintf "found expr match for %s\n" name));
738: [BExpr(name, tgt)]
739: | a, b ->
740: if (verbose && traceActive "patchDebug") then (
741: (trace "patchDebug" (dprintf "mismatching expression\n"));
742: (printExpr a);
743: (printExpr b)
744: );
745: raise NoMatch
746: end
747:
748: and unifyInitExpr (pat : init_expression) (tgt : init_expression) : binding list =
749: begin
750: (*
751: Flx_cil_cprint.print_init_expression pat; Flx_cil_cprint.force_new_line ();
752: Flx_cil_cprint.print_init_expression tgt; Flx_cil_cprint.force_new_line ();
753: Flx_cil_cprint.flush ();
754: *)
755:
756: match pat, tgt with
757: | NO_INIT, NO_INIT -> []
758: | SINGLE_INIT(pe), SINGLE_INIT(te) ->
759: (unifyExpr pe te)
760: | COMPOUND_INIT(plist),
761: COMPOUND_INIT(tlist) -> (
762: let rec loop plist tlist =
763: match plist, tlist with
764: | ((pwhat, piexpr) :: prest),
765: ((twhat, tiexpr) :: trest) ->
766: (mustEq pwhat twhat);
767: (unifyInitExpr piexpr tiexpr) @
768: (loop prest trest)
769: | [], [] -> []
770: | _, _ -> (
771: if verbose then
772: (trace "patchDebug" (dprintf "mismatching compound init exprs\n"));
773: raise NoMatch
774: )
775: in
776: (loop plist tlist)
777: )
778: | _,_ -> (
779: if verbose then
780: (trace "patchDebug" (dprintf "mismatching init exprs\n"));
781: raise NoMatch
782: )
783: end
784:
785: and unifyExprs (pat : expression list) (tgt : expression list) : binding list =
786: (unifyList pat tgt unifyExpr)
787:
788:
789: (* given the list of bindings 'b', substitute them into 'd' to yield a new definition *)
790: and substDefn (bindings : binding list) (defn : definition) : definition =
791: begin
792: if verbose then
793: (trace "patchDebug" (dprintf "substDefn with %d bindings\n" (List.length bindings)));
794: (printDefn defn);
795:
796: (* apply the transformation *)
797: match (visit_cabsDefinition (new substitutor bindings :> cabsVisitor) defn) with
798: | [d] -> d (* expect a singleton list *)
799: | _ -> (failwith "didn't get a singleton list where I expected one")
800: end
801:
802:
803: (* end of file *)
Start ocaml section to src/flx_cil_patch.mli[1
/1
]
1: # 20628 "./lpsrc/flx_cil.ipk"
2:
3:
4: (* patch.mli *)
5: (* interface for patch.ml *)
6:
7: val applyFlx_cil_patch : Flx_cil_cabs.file -> Flx_cil_cabs.file -> Flx_cil_cabs.file
Start ocaml section to src/flx_cil_errormsg.ml[1
/1
]
1: # 20636 "./lpsrc/flx_cil.ipk"
2:
3: open Flx_cil_pretty
4:
5:
6:
7: let debugFlag = ref false (* If set then print debugging info *)
8: let verboseFlag = ref false
9:
10: (**** Error reporting ****)
11: exception Error
12: let s (d : doc) = raise Error
13:
14: let hadErrors = ref false
15:
16: let errorContext = ref []
17: let pushContext f = errorContext := f :: (!errorContext)
18: let popContext () =
19: match !errorContext with
20: _ :: t -> errorContext := t
21: | [] -> s (eprintf "Bug: cannot pop error context")
22:
23:
24: let withContext ctx f x =
25: pushContext ctx;
26: try
27: let res = f x in
28: popContext ();
29: res
30: with e -> begin
31: popContext ();
32: raise e
33: end
34:
35: (* Make sure that showContext calls
36: * each f with its appropriate
37: * errorContext as it was when it was
38: * pushed *)
39: let showContext () =
40: let rec loop = function
41: [] -> ()
42: | f :: rest -> (errorContext := rest; (* Just in case f raises an error *)
43: ignore (eprintf " Context : %t@!" f);
44: loop rest)
45: in
46: let old = !errorContext in
47: try
48: loop old;
49: errorContext := old
50: with e -> begin
51: errorContext := old;
52: raise e
53: end
54:
55: let contextMessage name d =
56: ignore (eprintf "@!%s: %a@!" name insert d);
57: showContext ()
58:
59: let warnFlag = ref false
60:
61: let logChannel : out_channel ref = ref stderr
62:
63:
64: let bug (fmt : ('a,unit,doc) format) : 'a =
65: let f d =
66: hadErrors := true; contextMessage "Bug" d;
67: flush !logChannel;
68: nil
69: in
70: Flx_cil_pretty.gprintf f fmt
71:
72: let error (fmt : ('a,unit,doc) format) : 'a =
73: let f d = hadErrors := true; contextMessage "Error" d;
74: flush !logChannel;
75: nil
76: in
77: Flx_cil_pretty.gprintf f fmt
78:
79: let unimp (fmt : ('a,unit,doc) format) : 'a =
80: let f d = hadErrors := true; contextMessage "Unimplemented" d;
81: flush !logChannel;
82: nil
83: in
84: Flx_cil_pretty.gprintf f fmt
85:
86: let warn (fmt : ('a,unit,doc) format) : 'a =
87: let f d = contextMessage "Warning" d; flush !logChannel; nil in
88: Flx_cil_pretty.gprintf f fmt
89:
90: let warnOpt (fmt : ('a,unit,doc) format) : 'a =
91: let f d =
92: if !warnFlag then contextMessage "Warning" d; flush !logChannel;
93: nil in
94: Flx_cil_pretty.gprintf f fmt
95:
96:
97: let log (fmt : ('a,unit,doc) format) : 'a =
98: let f d = fprint !logChannel 80 d; flush !logChannel; d in
99: Flx_cil_pretty.gprintf f fmt
100:
101: let null (fmt : ('a,unit,doc) format) : 'a =
102: let f d = Flx_cil_pretty.nil in
103: Flx_cil_pretty.gprintf f fmt
104:
105: let check (what: bool) (fmt : ('a,unit,doc) format) : 'a =
106: if what then
107: what
108: else begin
109: let f d =
110: if not what then begin
111: hadErrors := true; contextMessage "Assert" d;
112: flush !logChannel; raise Error
113: end else nil in
114: Flx_cil_pretty.gprintf f fmt
115: end
116:
117: let theLexbuf = ref (Lexing.from_string "")
118:
119: let fail format = Flx_cil_pretty.gprintf (fun x -> Flx_cil_pretty.fprint stderr 80 x;
120: raise (Failure "")) format
121:
122:
123:
124: (***** Handling parsing errors ********)
125: type parseinfo =
126: { mutable linenum: int ; (* Current line *)
127: mutable linestart: int ; (* The position in the buffer where the
128: * current line starts *)
129: mutable fileName : string ; (* Current file *)
130: mutable hfile : string ; (* High-level file *)
131: mutable hline : int; (* High-level line *)
132: lexbuf : Lexing.lexbuf;
133: inchan : in_channel option; (* None, if from a string *)
134: mutable num_errors : int; (* Errors so far *)
135: }
136:
137: let dummyinfo =
138: { linenum = 1;
139: linestart = 0;
140: fileName = "" ;
141: lexbuf = Lexing.from_string "";
142: inchan = None;
143: hfile = "";
144: hline = 0;
145: num_errors = 0;
146: }
147:
148: let current = ref dummyinfo
149:
150: let setHLine (l: int) : unit =
151: !current.hline <- l
152: let setHFile (f: string) : unit =
153: !current.hfile <- f
154:
155: let rem_quotes str = String.sub str 1 ((String.length str) - 2)
156:
157: (* Change \ into / in file names. To avoid complications with escapes *)
158: let cleanFileName str =
159: let str1 =
160: if str <> "" && String.get str 0 = '"' (* '"' ( *)
161: then rem_quotes str else str in
162: let l = String.length str1 in
163: let rec loop (copyto: int) (i: int) =
164: if i >= l then
165: String.sub str1 0 copyto
166: else
167: let c = String.get str1 i in
168: if c <> '\\' then begin
169: String.set str1 copyto c; loop (copyto + 1) (i + 1)
170: end else begin
171: String.set str1 copyto '/';
172: if i < l - 2 && String.get str1 (i + 1) = '\\' then
173: loop (copyto + 1) (i + 2)
174: else
175: loop (copyto + 1) (i + 1)
176: end
177: in
178: loop 0 0
179:
180: let startParsing (fname: string) =
181: let inchan =
182: try open_in fname with
183: _ -> s (error "Cannot find input file %s" fname) in
184: let lexbuf = Lexing.from_channel inchan in
185: let i =
186: { linenum = 1; linestart = 0;
187: fileName = cleanFileName (Filename.basename fname);
188: lexbuf = lexbuf; inchan = Some inchan;
189: hfile = ""; hline = 0;
190: num_errors = 0 } in
191: current := i;
192: lexbuf
193:
194: let startParsingFromString ?(file="<string>") ?(line=1) (str: string) =
195: let lexbuf = Lexing.from_string str in
196: let i =
197: { linenum = line; linestart = line - 1;
198: fileName = file;
199: hfile = ""; hline = 0;
200: lexbuf = lexbuf;
201: inchan = None;
202: num_errors = 0 }
203: in
204: current := i;
205: lexbuf
206:
207: let finishParsing () =
208: let i = !current in
209: (match i.inchan with Some c -> close_in c | _ -> ());
210: current := dummyinfo
211:
212:
213: (* Call this function to announce a new line *)
214: let newline () =
215: let i = !current in
216: i.linenum <- 1 + i.linenum;
217: i.linestart <- Lexing.lexeme_start i.lexbuf
218:
219: let newHline () =
220: let i = !current in
221: i.hline <- 1 + i.hline
222:
223: let setCurrentLine (i: int) =
224: !current.linenum <- i
225:
226: let setCurrentFile (n: string) =
227: !current.fileName <- cleanFileName n
228:
229:
230: let max_errors = 20 (* Stop after 20 errors *)
231:
232: let parse_error (msg: string) : 'a =
233: (* Sometimes the Ocaml parser raises errors in symbol_start and symbol_end *)
234: let token_start, token_end =
235: try Parsing.symbol_start (), Parsing.symbol_end ()
236: with e -> begin
237: ignore (warn "Parsing raised %s\n" (Printexc.to_string e));
238: 0, 0
239: end
240: in
241: let i = !current in
242: let adjStart =
243: if token_start < i.linestart then 0 else token_start - i.linestart in
244: let adjEnd =
245: if token_end < i.linestart then 0 else token_end - i.linestart in
246: output_string
247: stderr
248: (i.fileName ^ "[" ^ (string_of_int i.linenum) ^ ":"
249: ^ (string_of_int adjStart) ^ "-"
250: ^ (string_of_int adjEnd)
251: ^ "]"
252: ^ " : " ^ msg);
253: output_string stderr "\n";
254: flush stderr ;
255: i.num_errors <- i.num_errors + 1;
256: if i.num_errors > max_errors then begin
257: output_string stderr "Too many errors. Aborting.\n" ;
258: exit 1
259: end;
260: raise Parsing.Parse_error
261:
262:
263:
264:
265: (* More parsing support functions: line, file, char count *)
266: let getPosition () : int * string * int =
267: let i = !current in
268: i.linenum, i.fileName, Lexing.lexeme_start i.lexbuf
269:
270:
271: let getHPosition () =
272: !current.hline, !current.hfile
273:
274: (** Type for source-file locations *)
275: type location =
276: { file: string; (** The file name *)
277: line: int; (** The line number *)
278: hfile: string; (** The high-level file name, or "" if not present *)
279: hline: int; (** The high-level line number, or 0 if not present *)
280: }
281:
282: let d_loc () l =
283: text (l.file ^ ":" ^ string_of_int l.line)
284:
285: let d_hloc () (l: location) =
286: dprintf "%s:%d%a" l.file l.line
287: insert (if l.hline > 0 then dprintf " (%s:%d)" l.hfile l.hline else nil)
288:
289: let locUnknown = { file = ""; hfile = ""; line = -1; hline = -1 }
290:
291: let getLocation () =
292: let hl, hf = getHPosition () in
293: let l, f, c = getPosition () in
294: { hfile = hf; hline = hl;
295: file = f; line = l }
296:
Start ocaml section to src/flx_cil_errormsg.mli[1
/1
]
1: # 20933 "./lpsrc/flx_cil.ipk"
2: (** Flx_cil_utility functions for error-reporting *)
3:
4: (** A channel for printing log messages *)
5: val logChannel : out_channel ref
6:
7: (** If set then print debugging info *)
8: val debugFlag : bool ref
9:
10: val verboseFlag : bool ref
11:
12:
13: (** Set to true if you want to see all warnings. *)
14: val warnFlag: bool ref
15:
16: (** Error reporting functions raise this exception *)
17: exception Error
18:
19:
20: (* Error reporting. All of these functions take same arguments as a
21: * Flx_cil_pretty.eprintf. They raise the exception Error after they print their
22: * stuff. However, their type indicates that they return a "Flx_cil_pretty.doc"
23: * (due to the need to use the built-in type "format") return a doc. Thus
24: * use as follows: E.s (E.bug "different lengths (%d != %d)" l1 l2)
25: *)
26:
27: (** Prints an error message of the form [Error: ...].
28: Use in conjunction with s, for example: [E.s (E.error ... )]. *)
29: val error: ('a,unit,Flx_cil_pretty.doc) format -> 'a
30:
31: (** Similar to [error] except that its output has the form [Bug: ...] *)
32: val bug: ('a,unit,Flx_cil_pretty.doc) format -> 'a
33:
34: (** Similar to [error] except that its output has the form [Unimplemented: ...] *)
35: val unimp: ('a,unit,Flx_cil_pretty.doc) format -> 'a
36:
37: (** Stop the execution by raising an Error. Use "s (error "Foo")" *)
38: val s: Flx_cil_pretty.doc -> 'a
39:
40: (** This is set whenever one of the above error functions are called. It must
41: be cleared manually *)
42: val hadErrors: bool ref
43:
44: (** Like {!Flx_cil_errormsg.error} but does not raise the {!Flx_cil_errormsg.Error}
45: * exception. Use: [ignore (E.warn ...)] *)
46: val warn: ('a,unit,Flx_cil_pretty.doc) format -> 'a
47:
48: (** Like {!Flx_cil_errormsg.warn} but optional. Printed only if the
49: * {!Flx_cil_errormsg.warnFlag} is set *)
50: val warnOpt: ('a,unit,Flx_cil_pretty.doc) format -> 'a
51:
52: (** Print something to [logChannel] *)
53: val log: ('a,unit,Flx_cil_pretty.doc) format -> 'a
54:
55: (* All of the error and warning reporting functions can also print a
56: * context. To register a context printing function use "pushContext". To
57: * remove the last registered one use "popContext". If one of the error
58: * reporting functions is called it will invoke all currently registered
59: * context reporting functions in the reverse order they were registered. *)
60:
61: (** Do not actually print (i.e. print to /dev/null) *)
62: val null : ('a,unit,Flx_cil_pretty.doc) format -> 'a
63:
64: (** Registers a context printing function *)
65: val pushContext : (unit -> Flx_cil_pretty.doc) -> unit
66:
67: (** Removes the last registered context printing function *)
68: val popContext : unit -> unit
69:
70: (** Show the context stack to stderr *)
71: val showContext : unit -> unit
72:
73: (** To ensure that the context is registered and removed properly, use the
74: function below *)
75: val withContext : (unit -> Flx_cil_pretty.doc) -> ('a -> 'b) -> 'a -> 'b
76:
77:
78:
79: val newline: unit -> unit (* Call this function to announce a new line *)
80: val newHline: unit -> unit
81:
82: val getPosition: unit -> int * string * int (* Line number, file name,
83: current byte count in file *)
84: val getHPosition: unit -> int * string (** high-level position *)
85:
86: val setHLine: int -> unit
87: val setHFile: string -> unit
88:
89: val setCurrentLine: int -> unit
90: val setCurrentFile: string -> unit
91:
92: (** Type for source-file locations *)
93: type location =
94: { file: string; (** The file name *)
95: line: int; (** The line number *)
96: hfile: string; (** The high-level file name, or "" if not present *)
97: hline: int; (** The high-level line number, or 0 if not present *)
98: }
99:
100: val d_loc: unit -> location -> Flx_cil_pretty.doc
101: val d_hloc: unit -> location -> Flx_cil_pretty.doc
102:
103: val getLocation: unit -> location
104:
105: val parse_error: string -> (* A message *)
106: 'a
107:
108: (** An unknown location for use when you need one but you don't have one *)
109: val locUnknown: location
110:
111:
112: val startParsing: string -> Lexing.lexbuf (* Call this function to start
113: * parsing *)
114: val startParsingFromString: ?file:string -> ?line:int -> string
115: -> Lexing.lexbuf
116:
117: val finishParsing: unit -> unit (* Call this function to finish parsing and
118: * close the input channel *)
119:
120:
Start ocaml section to src/flx_cil_inthash.mli[1
/1
]
1: # 21054 "./lpsrc/flx_cil.ipk"
2: type 'a t = { mutable size : int; mutable data : 'a bucketlist array; }
3: and 'a bucketlist = Empty | Cons of int * 'a * 'a bucketlist
4: val create : int -> 'a t
5: val clear : 'a t -> unit
6: val copy : 'a t -> 'a t
7: val resize : 'a t -> unit
8: val add : 'a t -> int -> 'a -> unit
9: val remove : 'a t -> int -> unit
10: val find_rec : int -> 'a bucketlist -> 'a
11: val find : 'a t -> int -> 'a
12: val find_all : 'a t -> int -> 'a list
13: val replace : 'a t -> int -> 'a -> unit
14: val mem : 'a t -> int -> bool
15: val iter : (int -> 'a -> 'b) -> 'a t -> unit
16: val fold : (int -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
17: val memoize : unit t -> int -> (int -> unit) -> unit
18:
Start ocaml section to src/flx_cil_inthash.ml[1
/1
]
1: # 21073 "./lpsrc/flx_cil.ipk"
2: (** A hash table specialized on integer keys *)
3: type 'a t =
4: { mutable size: int; (* number of elements *)
5: mutable data: 'a bucketlist array } (* the buckets *)
6:
7: and 'a bucketlist =
8: Empty
9: | Cons of int * 'a * 'a bucketlist
10:
11: let create initial_size =
12: let s = min (max 1 initial_size) Sys.max_array_length in
13: { size = 0; data = Array.make s Empty }
14:
15: let clear h =
16: for i = 0 to Array.length h.data - 1 do
17: h.data.(i) <- Empty
18: done;
19: h.size <- 0
20:
21: let copy h =
22: { size = h.size;
23: data = Array.copy h.data }
24:
25: let resize tbl =
26: let odata = tbl.data in
27: let osize = Array.length odata in
28: let nsize = min (2 * osize + 1) Sys.max_array_length in
29: if nsize <> osize then begin
30: let ndata = Array.create nsize Empty in
31: let rec insert_bucket = function
32: Empty -> ()
33: | Cons(key, data, rest) ->
34: insert_bucket rest; (* preserve original order of elements *)
35: let nidx = key mod nsize in
36: ndata.(nidx) <- Cons(key, data, ndata.(nidx)) in
37: for i = 0 to osize - 1 do
38: insert_bucket odata.(i)
39: done;
40: tbl.data <- ndata;
41: end
42:
43: let add h key info =
44: let i = key mod (Array.length h.data) in
45: let bucket = Cons(key, info, h.data.(i)) in
46: h.data.(i) <- bucket;
47: h.size <- succ h.size;
48: if h.size > Array.length h.data lsl 1 then resize h
49:
50: let remove h key =
51: let rec remove_bucket = function
52: Empty ->
53: Empty
54: | Cons(k, i, next) ->
55: if k = key
56: then begin h.size <- pred h.size; next end
57: else Cons(k, i, remove_bucket next) in
58: let i = key mod (Array.length h.data) in
59: h.data.(i) <- remove_bucket h.data.(i)
60:
61: let rec find_rec key = function
62: Empty ->
63: raise Not_found
64: | Cons(k, d, rest) ->
65: if key = k then d else find_rec key rest
66:
67: let find h key =
68: match h.data.(key mod (Array.length h.data)) with
69: Empty -> raise Not_found
70: | Cons(k1, d1, rest1) ->
71: if key = k1 then d1 else
72: match rest1 with
73: Empty -> raise Not_found
74: | Cons(k2, d2, rest2) ->
75: if key = k2 then d2 else
76: match rest2 with
77: Empty -> raise Not_found
78: | Cons(k3, d3, rest3) ->
79: if key = k3 then d3 else find_rec key rest3
80:
81: let find_all h key =
82: let rec find_in_bucket = function
83: Empty ->
84: []
85: | Cons(k, d, rest) ->
86: if k = key then d :: find_in_bucket rest else find_in_bucket rest in
87: find_in_bucket h.data.(key mod (Array.length h.data))
88:
89: let replace h key info =
90: let rec replace_bucket = function
91: Empty ->
92: raise Not_found
93: | Cons(k, i, next) ->
94: if k = key
95: then Cons(k, info, next)
96: else Cons(k, i, replace_bucket next) in
97: let i = key mod (Array.length h.data) in
98: let l = h.data.(i) in
99: try
100: h.data.(i) <- replace_bucket l
101: with Not_found ->
102: h.data.(i) <- Cons(key, info, l);
103: h.size <- succ h.size;
104: if h.size > Array.length h.data lsl 1 then resize h
105:
106: let mem h key =
107: let rec mem_in_bucket = function
108: | Empty ->
109: false
110: | Cons(k, d, rest) ->
111: k = key || mem_in_bucket rest in
112: mem_in_bucket h.data.(key mod (Array.length h.data))
113:
114: let iter f h =
115: let rec do_bucket = function
116: Empty ->
117: ()
118: | Cons(k, d, rest) ->
119: f k d; do_bucket rest in
120: let d = h.data in
121: for i = 0 to Array.length d - 1 do
122: do_bucket d.(i)
123: done
124:
125: let fold (f: int -> 'a -> 'b -> 'b) (h: 'a t) (init: 'b) =
126: let rec do_bucket b accu =
127: match b with
128: Empty ->
129: accu
130: | Cons(k, d, rest) ->
131: do_bucket rest (f k d accu) in
132: let d = h.data in
133: let accu = ref init in
134: for i = 0 to Array.length d - 1 do
135: accu := do_bucket d.(i) !accu
136: done;
137: !accu
138:
139:
140: let memoize (h: 'a t) (key: int) (f: int -> 'a) : 'a =
141: let i = key mod (Array.length h.data) in
142: let rec find_rec key = function
143: Empty -> addit ()
144: | Cons(k, d, rest) ->
145: if key = k then d else find_rec key rest
146: and find_in_bucket key = function
147: Empty -> addit ()
148: | Cons(k1, d1, rest1) ->
149: if key = k1 then d1 else
150: match rest1 with
151: Empty -> addit ()
152: | Cons(k2, d2, rest2) ->
153: if key = k2 then d2 else
154: match rest2 with
155: Empty -> addit ()
156: | Cons(k3, d3, rest3) ->
157: if key = k3 then d3 else find_rec key rest3
158: and addit () =
159: let it = f key in
160: h.data.(i) <- Cons(key, it, h.data.(i));
161: h.size <- succ h.size;
162: if h.size > Array.length h.data lsl 1 then resize h
163: in
164: find_in_bucket key h.data.(i)
165:
166:
Start ocaml section to src/flx_cil_pretty.ml[1
/1
]
1: # 21240 "./lpsrc/flx_cil.ipk"
2:
3: (******************************************************************************)
4: (* Flx_cil_pretty printer
5: This module contains several fast, but sub-optimal heuristics to pretty-print
6: structured text.
7: *)
8:
9: let debug = false
10:
11: (* Choose an algorithm *)
12: type algo = George | Aman | Gap
13: let algo = George
14: let fastMode = ref false
15:
16:
17: (** Whether to print identation or not (for faster printing and smaller
18: * output) *)
19: let printIndent = ref true
20:
21: (******************************************************************************)
22: (* The doc type and constructors *)
23:
24: type doc =
25: Nil
26: | Text of string
27: | Concat of doc * doc
28: | CText of doc * string
29: | Break
30: | Line
31: | LeftFlush
32: | Align
33: | Unalign
34: | Mark
35: | Unmark
36:
37: (* Break a string at \n *)
38: let rec breakString (acc: doc) (str: string) : doc =
39: try
40: (* Printf.printf "breaking string %s\n" str; *)
41: let r = String.index str '\n' in
42: (* Printf.printf "r=%d\n" r; *)
43: let len = String.length str in
44: if r > 0 then begin
45: (* Printf.printf "Taking %s\n" (String.sub str 0 r); *)
46: let acc' = Concat(CText (acc, String.sub str 0 r), Line) in
47: if r = len - 1 then (* The last one *)
48: acc'
49: else begin
50: (* Printf.printf "Continuing with %s\n" (String.sub str (r + 1) (len - r - 1)); *)
51: breakString acc'
52: (String.sub str (r + 1) (len - r - 1))
53: end
54: end else (* The first is a newline *)
55: breakString (Concat(acc, Line))
56: (String.sub str (r + 1) (len - r - 1))
57: with Not_found ->
58: if acc = Nil then Text str else CText (acc, str)
59:
60: let nil = Nil
61: let text s = breakString nil s
62: let num i = text (string_of_int i)
63: let real f = text (string_of_float f)
64: let chr c = text (String.make 1 c)
65: let align = Align
66: let unalign = Unalign
67: let line = Line
68: let leftflush = LeftFlush
69: let break = Break
70: let mark = Mark
71: let unmark = Unmark
72:
73: (* Note that the ++ operator in Ocaml are left-associative. This means
74: * that if you have a long list of ++ then the whole thing is very unbalanced
75: * towards the left side. This is the worst possible case since scanning the
76: * left side of a Concat is the non-tail recursive case. *)
77:
78: let (++) d1 d2 = Concat (d1, d2)
79:
80: (* Ben Liblit fix *)
81: let indent n d = text (String.make n ' ') ++ (align ++ (d ++ unalign))
82:
83: let markup d = mark ++ d ++ unmark
84:
85: (* Format a sequence. The first argument is a separator *)
86: let seq ~(sep:doc) ~(doit:'a -> doc) ~(elements: 'a list) =
87: let rec loop (acc: doc) = function
88: [] -> acc
89: | h :: t ->
90: let fh = doit h in (* Make sure this is done first *)
91: loop (acc ++ sep ++ fh) t
92: in
93: (match elements with
94: [] -> nil
95: | h :: t ->
96: let fh = doit h in loop fh t)
97:
98:
99: let docArray (sep:doc) (doit:int -> 'a -> doc) () (elements:'a array) =
100: let len = Array.length elements in
101: if len = 0 then
102: nil
103: else
104: let rec loop (acc: doc) i =
105: if i >= len then acc else
106: let fi = doit i elements.(i) in (* Make sure this is done first *)
107: loop (acc ++ sep ++ fi) (i + 1)
108: in
109: let f0 = doit 0 elements.(0) in
110: loop f0 1
111:
112: let docOpt delem () = function
113: None -> text "None"
114: | Some e -> text "Some(" ++ (delem () e) ++ chr ')'
115:
116:
117:
118: let docList (sep:doc) (doit:'a -> doc) () (elements:'a list) =
119: seq sep doit elements
120:
121: let insert () d = d
122:
123:
124: let d_list (sep:string) (doit:unit -> 'a -> doc) () (elts:'a list) : doc =
125: (* thunk 'doit' to match docList's interface *)
126: let internalDoit (elt:'a) =
127: (doit () elt) in
128: (docList (text sep) internalDoit () elts)
129:
130:
131: (******************************************************************************)
132: (* Some debugging stuff *)
133:
134: let dbgprintf x = Printf.fprintf stderr x
135:
136: let rec dbgPrintDoc = function
137: Nil -> dbgprintf "(Nil)"
138: | Text s -> dbgprintf "(Text %s)" s
139: | Concat (d1,d2) -> dbgprintf ""; dbgPrintDoc d1; dbgprintf " ++\n ";
140: dbgPrintDoc d2; dbgprintf ""
141: | CText (d,s) -> dbgPrintDoc d; dbgprintf " ++ \"%s\"" s;
142: | Break -> dbgprintf "(Break)"
143: | Line -> dbgprintf "(Line)"
144: | LeftFlush -> dbgprintf "(LeftFlush)"
145: | Align -> dbgprintf "(Align)"
146: | Unalign -> dbgprintf "(Unalign)"
147: | Mark -> dbgprintf "(Mark)"
148: | Unmark -> dbgprintf "(Unmark)"
149:
150: (******************************************************************************)
151: (* The "george" algorithm *)
152:
153: (* When we construct documents, most of the time they are heavily unbalanced
154: * towards the left. This is due to the left-associativity of ++ and also to
155: * the fact that constructors such as docList construct from the let of a
156: * sequence. We would prefer to shift the imbalance to the right to avoid
157: * consuming a lot of stack when we traverse the document *)
158: let rec flatten (acc: doc) = function
159: | Concat (d1, d2) -> flatten (flatten acc d2) d1
160: | CText (d, s) -> flatten (Concat(Text s, acc)) d
161: | Nil -> acc (* Get rid of Nil *)
162: | d -> Concat(d, acc)
163:
164: (* We keep a stack of active aligns. *)
165: type align =
166: { mutable gainBreak: int; (* This is the gain that is associated with
167: * taking the break associated with this
168: * alignment mark. If this is 0, then there
169: * is no break associated with the mark *)
170: mutable isTaken: bool ref; (* If breakGain is > 0 then this is a ref
171: * cell that must be set to true when the
172: * break is taken. These ref cells are also
173: * int the "breaks" list *)
174: deltaFromPrev: int ref; (* The column of this alignment mark -
175: * the column of the previous mark.
176: * Shared with the deltaToNext of the
177: * previous active align *)
178: deltaToNext: int ref (* The column of the next alignment mark -
179: * the columns of this one. Shared with
180: * deltaFromPrev of the next active align *)
181: }
182:
183: (* We use references to avoid the need to pass data around all the time *)
184: let aligns: align list ref = (* The current stack of active alignment marks,
185: * with the top at the head. Never empty. *)
186: ref [{ gainBreak = 0; isTaken = ref false;
187: deltaFromPrev = ref 0; deltaToNext = ref 0; }]
188:
189: let topAlignAbsCol = ref 0 (* The absolute column of the top alignment *)
190:
191: let pushAlign (abscol: int) =
192: let topalign = List.hd !aligns in
193: let res =
194: { gainBreak = 0; isTaken = ref false;
195: deltaFromPrev = topalign.deltaToNext; (* Share with the previous *)
196: deltaToNext = ref 0; (* Allocate a new ref *)} in
197: aligns := res :: !aligns;
198: res.deltaFromPrev := abscol - !topAlignAbsCol;
199: topAlignAbsCol := abscol
200:
201: let popAlign () =
202: match !aligns with
203: top :: t when t != [] ->
204: aligns := t;
205: topAlignAbsCol := !topAlignAbsCol - !(top.deltaFromPrev)
206: | _ -> failwith "Unmatched unalign\n"
207:
208: (** We keep a list of active markup sections. For each one we keep the column
209: * we are in *)
210: let activeMarkups: int list ref = ref []
211:
212:
213: (* Keep a list of ref cells for the breaks, in the same order that we see
214: * them in the document *)
215: let breaks: bool ref list ref = ref []
216:
217: (* The maximum column that we should use *)
218: let maxCol = ref 0
219:
220: (* Sometimes we take all the optional breaks *)
221: let breakAllMode = ref false
222:
223: (* We are taking a newline and moving left *)
224: let newline () =
225: let topalign = List.hd !aligns in (* aligns is never empty *)
226: if debug then
227: dbgprintf "Taking a newline: reseting gain of %d\n" topalign.gainBreak;
228: topalign.gainBreak <- 0; (* Erase the current break info *)
229: if !breakAllMode && !topAlignAbsCol < !maxCol then
230: breakAllMode := false;
231: !topAlignAbsCol (* This is the new column *)
232:
233:
234:
235: (* Choose the align with the best gain. We outght to find a better way to
236: * keep the aligns sorted, especially since they gain never changes (when the
237: * align is the top align) *)
238: let chooseBestGain () : align option =
239: let bestGain = ref 0 in
240: let rec loop (breakingAlign: align option) = function
241: [] -> breakingAlign
242: | a :: resta ->
243: if debug then dbgprintf "Looking at align with gain %d\n" a.gainBreak;
244: if a.gainBreak > !bestGain then begin
245: bestGain := a.gainBreak;
246: loop (Some a) resta
247: end else
248: loop breakingAlign resta
249: in
250: loop None !aligns
251:
252:
253: (* Another one that chooses the break associated with the current align only *)
254: let chooseLastGain () : align option =
255: let topalign = List.hd !aligns in
256: if topalign.gainBreak > 0 then Some topalign else None
257:
258: (* We have just advanced to a new column. See if we must take a line break *)
259: let movingRight (abscol: int) : int =
260: (* Keep taking the best break until we get back to the left of maxCol or no
261: * more are left *)
262: let rec tryAgain abscol =
263: if abscol <= !maxCol then abscol else
264: begin
265: if debug then
266: dbgprintf "Looking for a break to take in column %d\n" abscol;
267: (* Find the best gain there is out there *)
268: match if !fastMode then None else chooseBestGain () with
269: None -> begin
270: (* No breaks are available. Take all breaks from now on *)
271: breakAllMode := true;
272: if debug then
273: dbgprintf "Can't find any breaks\n";
274: abscol
275: end
276: | Some breakingAlign -> begin
277: let topalign = List.hd !aligns in
278: let theGain = breakingAlign.gainBreak in
279: assert (theGain > 0);
280: if debug then dbgprintf "Taking break at %d. gain=%d\n" abscol theGain;
281: breakingAlign.isTaken := true;
282: breakingAlign.gainBreak <- 0;
283: if breakingAlign != topalign then begin
284: breakingAlign.deltaToNext :=
285: !(breakingAlign.deltaToNext) - theGain;
286: topAlignAbsCol := !topAlignAbsCol - theGain
287: end;
288: tryAgain (abscol - theGain)
289: end
290: end
291: in
292: tryAgain abscol
293:
294:
295: (* Keep track of nested align in gprintf. Each gprintf format string must
296: * have properly nested align/unalign pairs. When the nesting depth surpasses
297: * !printDepth then we print ... and we skip until the matching unalign *)
298: let printDepth = ref 10000000 (* WRW: must see whole thing *)
299: let alignDepth = ref 0
300:
301: let useAlignDepth = true
302:
303: (** Start an align. Return true if we ahve just passed the threshhold *)
304: let enterAlign () =
305: incr alignDepth;
306: useAlignDepth && !alignDepth = !printDepth + 1
307:
308: (** Exit an align *)
309: let exitAlign () =
310: decr alignDepth
311:
312: (** See if we are at a low-enough align level (and we should be printing
313: * normally) *)
314: let shallowAlign () =
315: not useAlignDepth || !alignDepth <= !printDepth
316:
317:
318: (* Pass the current absolute column and compute the new column *)
319: let rec scan (abscol: int) (d: doc) : int =
320: match d with
321: Nil -> abscol
322: | Concat (d1, d2) -> scan (scan abscol d1) d2
323: | Text s when shallowAlign () ->
324: let sl = String.length s in
325: if debug then
326: dbgprintf "Done string: %s from %d to %d\n" s abscol (abscol + sl);
327: movingRight (abscol + sl)
328: | CText (d, s) ->
329: let abscol' = scan abscol d in
330: if shallowAlign () then begin
331: let sl = String.length s in
332: if debug then
333: dbgprintf "Done string: %s from %d to %d\n" s abscol' (abscol' + sl);
334: movingRight (abscol' + sl)
335: end else
336: abscol'
337:
338: | Align ->
339: pushAlign abscol;
340: if enterAlign () then
341: movingRight (abscol + 3) (* "..." *)
342: else
343: abscol
344:
345: | Unalign -> exitAlign (); popAlign (); abscol
346:
347: | Line when shallowAlign () -> (* A forced line break *)
348: if !activeMarkups != [] then
349: failwith "Line breaks inside markup sections";
350: newline ()
351:
352: | LeftFlush when shallowAlign () -> (* Keep cursor left-flushed *) 0
353:
354: | Break when shallowAlign () -> (* An optional line break. Always a space
355: * followed by an optional line break *)
356: if !activeMarkups != [] then
357: failwith "Line breaks inside markup sections";
358: let takenref = ref false in
359: breaks := takenref :: !breaks;
360: let topalign = List.hd !aligns in (* aligns is never empty *)
361: if !breakAllMode then begin
362: takenref := true;
363: newline ()
364: end else begin
365: (* If there was a previous break there it stays not taken, forever.
366: * So we overwrite it. *)
367: topalign.isTaken <- takenref;
368: topalign.gainBreak <- 1 + abscol - !topAlignAbsCol;
369: if debug then
370: dbgprintf "Registering a break at %d with gain %d\n"
371: (1 + abscol) topalign.gainBreak;
372: movingRight (1 + abscol)
373: end
374:
375: | Mark -> activeMarkups := abscol :: !activeMarkups;
376: abscol
377:
378: | Unmark -> begin
379: match !activeMarkups with
380: old :: rest -> activeMarkups := rest;
381: old
382: | [] -> failwith "Too many unmark"
383: end
384:
385: | _ -> (* Align level is too deep *) abscol
386:
387:
388: (** Keep a running counter of the newlines we are taking. You can read and
389: * reset this from user code, if you want *)
390: let countNewLines = ref 0
391:
392: (* The actual function that takes a document and prints it *)
393: let emitDoc
394: (emitString: string -> int -> unit) (* emit a number of copies of a
395: * string *)
396: (d: doc) =
397: let aligns: int list ref = ref [0] in (* A stack of alignment columns *)
398:
399: let wantIndent = ref false in
400: (* Use this function to take a newline *)
401: (* AB: modified it to flag wantIndent. The actual indentation is done only
402: if leftflush is not encountered *)
403: let newline () =
404: match !aligns with
405: [] -> failwith "Ran out of aligns"
406: | x :: _ ->
407: emitString "\n" 1;
408: incr countNewLines;
409: wantIndent := true;
410: x
411: in
412: (* Print indentation if wantIndent was previously flagged ; reset this flag *)
413: let indentIfNeeded () =
414: if !printIndent && !wantIndent then ignore (
415: match !aligns with
416: [] -> failwith "Ran out of aligns"
417: | x :: _ ->
418: if x > 0 then emitString " " x;
419: x);
420: wantIndent := false
421: in
422: (* A continuation passing style loop *)
423: let rec loopCont (abscol: int) (d: doc) (cont: int -> unit) : unit
424: (* the new column *) =
425: match d with
426: Nil -> cont abscol
427: | Concat (d1, d2) ->
428: loopCont abscol d1 (fun abscol' -> loopCont abscol' d2 cont)
429:
430: | Text s when shallowAlign () ->
431: let sl = String.length s in
432: indentIfNeeded ();
433: emitString s 1;
434: cont (abscol + sl)
435:
436: | CText (d, s) ->
437: loopCont abscol d
438: (fun abscol' ->
439: if shallowAlign () then
440: let sl = String.length s in
441: indentIfNeeded ();
442: emitString s 1;
443: cont (abscol' + sl)
444: else
445: cont abscol')
446:
447: | Align ->
448: aligns := abscol :: !aligns;
449: if enterAlign () then begin
450: indentIfNeeded ();
451: emitString "..." 1;
452: cont (abscol + 3)
453: end else
454: cont abscol
455:
456: | Unalign -> begin
457: match !aligns with
458: [] -> failwith "Unmatched unalign"
459: | _ :: rest ->
460: exitAlign ();
461: aligns := rest; cont abscol
462: end
463: | Line when shallowAlign () -> cont (newline ())
464: | LeftFlush when shallowAlign () -> wantIndent := false; cont (0)
465: | Break when shallowAlign () -> begin
466: match !breaks with
467: [] -> failwith "Break without a takenref"
468: | istaken :: rest ->
469: breaks := rest; (* Consume the break *)
470: if !istaken then cont (newline ())
471: else begin
472: indentIfNeeded ();
473: emitString " " 1;
474: cont (abscol + 1)
475: end
476: end
477:
478: | Mark ->
479: activeMarkups := abscol :: !activeMarkups;
480: cont abscol
481:
482: | Unmark -> begin
483: match !activeMarkups with
484: old :: rest -> activeMarkups := rest;
485: cont old
486: | [] -> failwith "Unmark without a mark"
487: end
488:
489: | _ -> (* Align is too deep *)
490: cont abscol
491: in
492:
493: loopCont 0 d (fun x -> ())
494:
495:
496: (* Print a document on a channel *)
497: let fprint (chn: out_channel) ~(width: int) doc =
498: maxCol := width;
499: breaks := [];
500: alignDepth := 0;
501: activeMarkups := [];
502: ignore (scan 0 doc);
503: breaks := List.rev !breaks;
504: alignDepth := 0;
505: ignore (emitDoc
506: (fun s nrcopies ->
507: for i = 1 to nrcopies do
508: output_string chn s
509: done) doc);
510: activeMarkups := [];
511: breaks := [] (* We must do this especially if we don't do emit (which
512: * consumes breaks) because otherwise we waste memory *)
513:
514: (* Print the document to a string *)
515: let sprint ~(width : int) doc : string =
516: maxCol := width;
517: breaks := [];
518: activeMarkups := [];
519: alignDepth := 0;
520: ignore (scan 0 doc);
521: breaks := List.rev !breaks;
522: let buf = Buffer.create 1024 in
523: let rec add_n_strings str num =
524: if num <= 0 then ()
525: else begin Buffer.add_string buf str; add_n_strings str (num - 1) end
526: in
527: alignDepth := 0;
528: emitDoc add_n_strings doc;
529: breaks := [];
530: activeMarkups := [];
531: Buffer.contents buf
532:
533:
534: (* The rest is based on printf.ml *)
535: (*
536: external format_int: string -> int -> string = "format_int"
537: external format_float: string -> float -> string = "format_float"
538: *)
539: let format_int fmt x = string_of_int x
540: let format_float fmt x = string_of_float x
541:
542: let gprintf (finish : doc -> doc)
543: (format : ('a, unit, doc) format) : 'a =
544: let format = (Obj.magic format : string) in
545:
546: (* Record the starting align depth *)
547: let startAlignDepth = !alignDepth in
548: (* Special concatenation functions *)
549: let dconcat (acc: doc) (another: doc) =
550: if !alignDepth > !printDepth then acc else acc ++ another in
551: let dctext1 (acc: doc) (str: string) =
552: if !alignDepth > !printDepth then acc else
553: CText(acc, str)
554: in
555: (* Special finish function *)
556: let dfinish dc =
557: if !alignDepth <> startAlignDepth then
558: prerr_string ("Unmatched align/unalign in " ^ format ^ "\n");
559: finish dc
560: in
561: let flen = String.length format in
562: (* Reading a format character *)
563: let fget = String.unsafe_get format in
564: (* Output a literal sequence of
565: * characters, starting at i. The
566: * character at i does not need to be
567: * checked. *)
568: let rec literal acc i =
569: let rec skipChars j =
570: if j >= flen ||
571: (match fget j with
572: '%' -> true
573: | '@' -> true
574: | '\n' -> true
575: | _ -> false) then
576: collect (dctext1 acc (String.sub format i (j-i))) j
577: else
578: skipChars (succ j)
579: in
580: skipChars (succ i)
581: (* the main collection function *)
582: and collect (acc: doc) (i: int) =
583: if i >= flen then begin
584: Obj.magic (dfinish acc)
585: end else begin
586: let c = fget i in
587: if c = '%' then begin
588: let j = skip_args (succ i) in
589: match fget j with
590: '%' -> literal acc j
591: | 's' ->
592: Obj.magic(fun s ->
593: let str =
594: if j <= i+1 then
595: s
596: else
597: let sl = String.length s in
598: let p =
599: try
600: int_of_string (String.sub format (i+1) (j-i-1))
601: with _ ->
602: invalid_arg "fprintf: bad %s format" in
603: if p > 0 && sl < p then
604: (String.make (p - sl) ' ') ^ s
605: else if p < 0 && sl < -p then
606: s ^ (String.make (-p - sl) ' ')
607: else
608: s
609: in
610: collect (breakString acc str) (succ j))
611: | 'c' ->
612: Obj.magic(fun c ->
613: collect (dctext1 acc (String.make 1 c)) (succ j))
614: | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
615: Obj.magic(fun n ->
616: collect (dctext1 acc
617: (format_int (String.sub format i
618: (j-i+1)) n))
619: (succ j))
620: (* L, l, and n are the Int64, Int32, and Nativeint modifiers to the integer
621: formats d,i,o,x,X,u. For example, %Lo means print an Int64 in octal.*)
622: | 'L' ->
623: if j != i + 1 then (*Int64.format handles simple formats like %d.
624: * Any special flags eaten by skip_args will confuse it. *)
625: invalid_arg ("dprintf: unimplemented format "
626: ^ (String.sub format i (j-i+1)));
627: let j' = succ j in (* eat the d,i,x etc. *)
628: let format_spec = "% " in
629: String.set format_spec 1 (fget j'); (* format_spec = "%x", etc. *)
630: Obj.magic(fun n ->
631: collect (dctext1 acc
632: (Int64.format format_spec n))
633: (succ j'))
634: | 'l' ->
635: if j != i + 1 then invalid_arg ("dprintf: unimplemented format "
636: ^ (String.sub format i (j-i+1)));
637: let j' = succ j in (* eat the d,i,x etc. *)
638: let format_spec = "% " in
639: String.set format_spec 1 (fget j'); (* format_spec = "%x", etc. *)
640: Obj.magic(fun n ->
641: collect (dctext1 acc
642: (Int32.format format_spec n))
643: (succ j'))
644: | 'n' ->
645: if j != i + 1 then invalid_arg ("dprintf: unimplemented format "
646: ^ (String.sub format i (j-i+1)));
647: let j' = succ j in (* eat the d,i,x etc. *)
648: let format_spec = "% " in
649: String.set format_spec 1 (fget j'); (* format_spec = "%x", etc. *)
650: Obj.magic(fun n ->
651: collect (dctext1 acc
652: (Nativeint.format format_spec n))
653: (succ j'))
654: | 'f' | 'e' | 'E' | 'g' | 'G' ->
655: Obj.magic(fun f ->
656: collect (dctext1 acc
657: (format_float (String.sub format i (j-i+1)) f))
658: (succ j))
659: | 'b' ->
660: Obj.magic(fun b ->
661: collect (dctext1 acc (string_of_bool b)) (succ j))
662: | 'a' ->
663: Obj.magic(fun pprinter arg ->
664: collect (dconcat acc (pprinter () arg)) (succ j))
665: | 't' ->
666: Obj.magic(fun pprinter ->
667: collect (dconcat acc (pprinter ())) (succ j))
668: | c ->
669: invalid_arg ("dprintf: unknown format %s" ^ String.make 1 c)
670:
671: end else if c = '@' then begin
672: if i + 1 < flen then begin
673: match fget (succ i) with
674:
675: (* Now the special format characters *)
676: '[' -> (* align *)
677: let newacc =
678: if !alignDepth > !printDepth then
679: acc
680: else if !alignDepth = !printDepth then
681: CText(acc, "...")
682: else
683: acc ++ align
684: in
685: incr alignDepth;
686: collect newacc (i + 2)
687:
688: | ']' -> (* unalign *)
689: decr alignDepth;
690: let newacc =
691: if !alignDepth >= !printDepth then
692: acc
693: else
694: acc ++ unalign
695: in
696: collect newacc (i + 2)
697: | '!' -> (* hard-line break *)
698: collect (dconcat acc line) (i + 2)
699: | '?' -> (* soft line break *)
700: collect (dconcat acc (break)) (i + 2)
701: | '<' ->
702: collect (dconcat acc mark) (i +1)
703: | '>' ->
704: collect (dconcat acc unmark) (i +1)
705: | '^' -> (* left-flushed *)
706: collect (dconcat acc (leftflush)) (i + 2)
707: | '@' ->
708: collect (dctext1 acc "@") (i + 2)
709: | c ->
710: invalid_arg ("dprintf: unknown format @" ^ String.make 1 c)
711: end else
712: invalid_arg "dprintf: incomplete format @"
713: end else if c = '\n' then begin
714: collect (dconcat acc line) (i + 1)
715: end else
716: literal acc i
717: end
718:
719: and skip_args j =
720: match String.unsafe_get format j with
721: '0' .. '9' | ' ' | '.' | '-' -> skip_args (succ j)
722: | c -> j
723:
724: in
725: collect Nil 0
726:
727: let withPrintDepth dp thunk =
728: let opd = !printDepth in
729: printDepth := dp;
730: thunk ();
731: printDepth := opd
732:
733:
734:
735: let flushOften = ref false
736:
737: let dprintf format = gprintf (fun x -> x) format
738: let fprintf chn format =
739: let f d = fprint chn 80 d; d in
740: (* weimeric hack begins -- flush output to streams *)
741: let res = gprintf f format in
742: (* save the value we would have returned, flush the channel and then
743: * return it -- this allows us to see debug input near infinite loops
744: * *)
745: if !flushOften then flush chn;
746: res
747: (* weimeric hack ends *)
748:
749: let printf format = fprintf stdout format
750: let eprintf format = fprintf stderr format
751:
752:
753:
754: (******************************************************************************)
755: let getAlgoName = function
756: George -> "George"
757: | Aman -> "Aman"
758: | Gap -> "Gap"
759:
760: let getAboutString () : string =
761: "(Flx_cil_pretty: ALGO=" ^ (getAlgoName algo) ^ ")"
762:
763:
Start ocaml section to src/flx_cil_pretty.mli[1
/1
]
1: # 22004 "./lpsrc/flx_cil.ipk"
2: (** Flx_cil_utility functions for pretty-printing. The major features provided by
3: this module are
4: - An [fprintf]-style interface with support for user-defined printers
5: - The printout is fit to a width by selecting some of the optional newlines
6: - Constructs for alignment and indentation
7: - Print ellipsis starting at a certain nesting depth
8: - Constructs for printing lists and arrays
9:
10: Flx_cil_pretty-printing occurs in two stages:
11: - Construct a {!Flx_cil_pretty.doc} object that encodes all of the elements to be
12: printed
13: along with alignment specifiers and optional and mandatory newlines
14: - Format the {!Flx_cil_pretty.doc} to a certain width and emit it as a string, to an
15: output stream or pass it to a user-defined function
16:
17: The formatting algorithm is not optimal but it does a pretty good job while
18: still operating in linear time. The original version was based on a pretty
19: printer by Philip Wadler which turned out to not scale to large jobs.
20: *)
21:
22: (** API *)
23:
24: (** The type of unformated documents. Elements of this type can be
25: * constructed in two ways. Either with a number of constructor shown below,
26: * or using the {!Flx_cil_pretty.dprintf} function with a [printf]-like interface.
27: * The {!Flx_cil_pretty.dprintf} method is slightly slower so we do not use it for
28: * large jobs such as the output routines for a compiler. But we use it for
29: * small jobs such as logging and error messages. *)
30: type doc
31:
32:
33:
34: (** Constructors for the doc type. *)
35:
36:
37:
38:
39: (** Constructs an empty document *)
40: val nil : doc
41:
42:
43: (** Concatenates two documents. This is an infix operator that associates to
44: the left. *)
45: val (++) : doc -> doc -> doc
46:
47:
48: (** A document that prints the given string *)
49: val text : string -> doc
50:
51:
52: (** A document that prints an integer in decimal form *)
53: val num : int -> doc
54:
55:
56: (** A document that prints a real number *)
57: val real : float -> doc
58:
59: (** A document that prints a character. This is just like {!Flx_cil_pretty.text}
60: with a one-character string. *)
61: val chr : char -> doc
62:
63:
64: (** A document that consists of a mandatory newline. This is just like [(text
65: "\n")]. The new line will be indented to the current indentation level,
66: unless you use {!Flx_cil_pretty.leftflush} right after this. *)
67: val line : doc
68:
69: (** Use after a {!Flx_cil_pretty.line} to prevent the indentation. Whatever follows
70: * next will be flushed left. Indentation resumes on the next line. *)
71: val leftflush : doc
72:
73:
74: (** A document that consists of either a space or a line break. Also called
75: an optional line break. Such a break will be
76: taken only if necessary to fit the document in a given width. If the break
77: is not taken a space is printed instead. *)
78: val break: doc
79:
80: (** Mark the current column as the current indentation level. Does not print
81: anything. All taken line breaks will align to this column. The previous
82: alignment level is saved on a stack. *)
83: val align: doc
84:
85: (** Reverts to the last saved indentation level. *)
86: val unalign: doc
87:
88:
89: (** Mark the beginning of a markup section. The width of a markup section is
90: * considered 0 for the purpose of computing identation *)
91: val mark: doc
92:
93: (** The end of a markup section *)
94: val unmark: doc
95:
96: (************* Now some syntactic sugar *****************)
97: (** Syntactic sugar *)
98:
99: (** Indents the document. Same as [((text " ") ++ align ++ doc ++ unalign)],
100: with the specified number of spaces. *)
101: val indent: int -> doc -> doc
102:
103: (** Prints a document as markup. The marked document cannot contain line
104: * breaks or alignment constructs. *)
105: val markup: doc -> doc
106:
107: (** Formats a sequence. [sep] is a separator, [doit] is a function that
108: * converts an element to a document. *)
109: val seq: sep:doc -> doit:('a ->doc) -> elements:'a list -> doc
110:
111:
112: (** An alternative function for printing a list. The [unit] argument is there
113: * to make this function more easily usable with the {!Flx_cil_pretty.dprintf}
114: * interface. *)
115: val docList: doc -> ('a -> doc) -> unit -> 'a list -> doc
116:
117: (** sm: Yet another list printer. This one accepts the same kind of
118: * printing function that {!Flx_cil_pretty.dprintf} does, and itself works
119: * in the dprintf context. Also accepts
120: * a string as the separator since that's by far the most common. *)
121: val d_list: string -> (unit -> 'a -> doc) -> unit -> 'a list -> doc
122:
123: (** Formats an array. A separator and a function that prints an array
124: element *)
125: val docArray: doc -> (int -> 'a -> doc) -> unit -> 'a array -> doc
126:
127: (** Prints an ['a option] with [None] or [Some] *)
128: val docOpt: (unit -> 'a -> doc) -> unit -> 'a option -> doc
129:
130:
131: (** A function that is useful with the [printf]-like interface *)
132: val insert: unit -> doc -> doc
133:
134: val dprintf: ('a, unit, doc) format -> 'a
135: (** This function provides an alternative method for constructing
136: [doc] objects. The first argument for this function is a format string
137: argument (of type [('a, unit, doc) format]; if you insist on
138: understanding what that means see the module [Printf]). The format string
139: is like that for the [printf] function in C, except that it understands a
140: few more formatting controls, all starting with the @ character.
141:
142: The following special formatting characters are understood (these do not
143: correspond to arguments of the function):
144: - @\[ Inserts an {!Flx_cil_pretty.align}. Every format string must have matching
145: {!Flx_cil_pretty.align} and {!Flx_cil_pretty.unalign}.
146: - @\] Inserts an {!Flx_cil_pretty.unalign}.
147: - @! Inserts a {!Flx_cil_pretty.line}. Just like "\n"
148: - @? Inserts a {!Flx_cil_pretty.break}.
149: - @< Inserts a {!Flx_cil_pretty.mark}.
150: - @< Inserts a {!Flx_cil_pretty.unmark}.
151: - @^ Inserts a {!Flx_cil_pretty.leftflush}
152: Should be used immediately after @! or "\n".
153: - @@ : inserts a @ character
154:
155: In addition to the usual [printf] % formatting characters the following two
156: new characters are supported:
157: - %t Corresponds to an argument of type [unit -> doc]. This argument is
158: invoked to produce a document
159: - %a Corresponds to {b two} arguments. The first of type [unit -> 'a -> doc]
160: and the second of type ['a]. (The extra [unit] is do to the
161: peculiarities of the built-in support for format strings in Ocaml. It
162: turns out that it is not a major problem.) Here is an example of how
163: you use this:
164:
165: {v dprintf "Name=%s, SSN=%7d, Children=\@\[%a\@\]\n"
166: pers.name pers.ssn (docList (chr ',' ++ break) text)
167: pers.children v}
168:
169: The result of [dprintf] is a {!Flx_cil_pretty.doc}. You can format the document and
170: emit it using the functions {!Flx_cil_pretty.fprint} and {!Flx_cil_pretty.sprint}.
171:
172: *)
173:
174: (** Format the document to the given width and emit it to the given channel *)
175: val fprint: out_channel -> width:int -> doc -> unit
176:
177: (** Format the document to the given width and emit it as a string *)
178: val sprint: width:int -> doc -> string
179:
180: (** Like {!Flx_cil_pretty.dprintf} followed by {!Flx_cil_pretty.fprint} *)
181: val fprintf: out_channel -> ('a, unit, doc) format -> 'a
182:
183: (** Like {!Flx_cil_pretty.fprintf} applied to [stdout] *)
184: val printf: ('a, unit, doc) format -> 'a
185:
186: (** Like {!Flx_cil_pretty.fprintf} applied to [stderr] *)
187: val eprintf: ('a, unit, doc) format -> 'a
188:
189: (** Like {!Flx_cil_pretty.dprintf} but more general. It also takes a function that is
190: * invoked on the constructed document but before any formatting is done. *)
191: val gprintf: (doc -> doc) -> ('a, unit, doc) format -> 'a
192:
193: (* sm: arg! why can't I write this function?! *)
194: (* * Like {!Flx_cil_pretty.dprintf} but yielding a string with no newlines *)
195: (*val sprintf: (doc, unit, doc) format -> string*)
196:
197: (* sm: different tack.. *)
198: (* doesn't work either. well f it anyway *)
199: (*val failwithf: ('a, unit, doc) format -> 'a*)
200:
201:
202: (** Invokes a thunk, with printDepth temporarily set to the specified value *)
203: val withPrintDepth : int -> (unit -> unit) -> unit
204:
205: (** The following variables can be used to control the operation of the printer *)
206:
207: (** Specifies the nesting depth of the [align]/[unalign] pairs at which
208: everything is replaced with ellipsis *)
209: val printDepth : int ref
210:
211: val printIndent : bool ref (** If false then does not indent *)
212:
213:
214: (** If set to [true] then optional breaks are taken only when the document
215: has exceeded the given width. This means that the printout will looked
216: more ragged but it will be faster *)
217: val fastMode : bool ref
218:
219: val flushOften : bool ref (** If true the it flushes after every print *)
220:
221:
222: (** Keep a running count of the taken newlines. You can read and write this
223: * from the client code if you want *)
224: val countNewLines : int ref
Start ocaml section to src/flx_cil_stats.ml[1
/1
]
1: # 22229 "./lpsrc/flx_cil.ipk"
2: (* The following functions are implemented in perfcount.c *)
3:
4: (* Returns true is we have the performance counters *)
5: external has_performance_counters: unit -> bool = "has_performance_counters"
6:
7: (* Returns number of seconds since the first read *)
8: external read_pentium_perfcount : unit -> float = "read_pentium_perfcount"
9:
10:
11:
12: (* Whether to use the performance counters (on Pentium only) *)
13:
14: (* The performance counters are disabled by default. *)
15: let do_use_performance_counters = ref false
16:
17: (* A hierarchy of timings *)
18:
19: type t = { name : string;
20: mutable time : float; (* In seconds *)
21: mutable sub : t list}
22:
23: (* Create the top level *)
24: let top = { name = "TOTAL";
25: time = 0.0;
26: sub = []; }
27:
28: (* The stack of current path through
29: * the hierarchy. The first is the
30: * leaf. *)
31: let current : t list ref = ref [top]
32:
33: exception NoPerfCount
34: let reset (perfcount: bool) =
35: top.sub <- [];
36: if perfcount then begin
37: if not (has_performance_counters ()) then begin
38: raise NoPerfCount
39: end
40: end;
41: do_use_performance_counters := perfcount
42:
43:
44:
45: let print chn msg =
46: (* Total up *)
47: top.time <- List.fold_left (fun sum f -> sum +. f.time) 0.0 top.sub;
48: let rec prTree ind node =
49: if !do_use_performance_counters then
50: (Printf.fprintf chn "%s%-20s %8.5f s\n"
51: (String.make ind ' ') node.name node.time)
52: else
53: (Printf.fprintf chn "%s%-20s %6.3f s\n"
54: (String.make ind ' ') node.name node.time);
55:
56: List.iter (prTree (ind + 2)) node.sub
57: in
58: Printf.fprintf chn "%s" msg;
59: List.iter (prTree 0) [ top ];
60: Printf.fprintf chn "Timing used %s\n"
61: (if !do_use_performance_counters then "performance counters" else "Unix.time");
62: ()
63:
64:
65:
66: (* Get the current time, in seconds *)
67: let get_current_time () : float =
68: if !do_use_performance_counters then
69: read_pentium_perfcount ()
70: else
71: (Unix.times ()).Unix.tms_utime
72:
73: let repeattime limit str f arg =
74: (* Find the right stat *)
75: let stat : t =
76: let curr = match !current with h :: _ -> h | _ -> assert false in
77: let rec loop = function
78: h :: _ when h.name = str -> h
79: | _ :: rest -> loop rest
80: | [] ->
81: let nw = {name = str; time = 0.0; sub = []} in
82: curr.sub <- nw :: curr.sub;
83: nw
84: in
85: loop curr.sub
86: in
87: let oldcurrent = !current in
88: current := stat :: oldcurrent;
89: let start = get_current_time () in
90: let rec loop count =
91: let res = f arg in
92: let diff = get_current_time () -. start in
93: if diff < limit then
94: loop (count + 1)
95: else begin
96: stat.time <- stat.time +. (diff /. float(count));
97: current := oldcurrent; (* Pop the current stat *)
98: res (* Return the function result *)
99: end
100: in
101: loop 1
102:
103:
104: let time str f arg = repeattime 0.0 str f arg
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
Start ocaml section to src/flx_cil_stats.mli[1
/1
]
1: # 22349 "./lpsrc/flx_cil.ipk"
2: (** Flx_cil_utilities for maintaining timing statistics *)
3:
4: (** Resets all the timings. Invoke with "true" if you want to switch to using
5: * the hardware performance counters from now on. You get an exception if
6: * there are not performance counters available *)
7: val reset: bool -> unit
8: exception NoPerfCount
9:
10: (** Flx_cil_check if we have performance counters *)
11: val has_performance_counters: unit -> bool
12:
13: (** Time a function and associate the time with the given string. If some
14: timing information is already associated with that string, then accumulate
15: the times. If this function is invoked within another timed function then
16: you can have a hierarchy of timings *)
17: val time : string -> ('a -> 'b) -> 'a -> 'b
18:
19: (** repeattime is like time but runs the function several times until the total
20: running time is greater or equal to the first argument. The total time is
21: then divided by the number of times the function was run. *)
22: val repeattime : float -> string -> ('a -> 'b) -> 'a -> 'b
23:
24: (** Print the current stats preceeded by a message *)
25: val print : out_channel -> string -> unit
26:
27:
28:
29:
30:
31:
Start ocaml section to src/flx_cil_trace.ml[1
/1
]
1: # 22381 "./lpsrc/flx_cil.ipk"
2: (* Flx_cil_trace module implementation
3: * see trace.mli
4: *)
5:
6: open Flx_cil_pretty;;
7:
8:
9: (* --------- traceSubsystems --------- *)
10: (* this is the list of tags (usually subsystem names) for which
11: * trace output will appear *)
12: let traceSubsystems : string list ref = ref [];;
13:
14:
15: let traceAddSys (subsys : string) : unit =
16: (* (ignore (printf "traceAddSys %s\n" subsys)); *)
17: traceSubsystems := subsys :: !traceSubsystems
18: ;;
19:
20:
21: let traceActive (subsys : string) : bool =
22: (* (List.mem elt list) returns true if something in list equals ('=') elt *)
23: (List.mem subsys !traceSubsystems)
24: ;;
25:
26:
27: let rec parseString (str : string) (delim : char) : string list =
28: begin
29: if (not (String.contains str delim)) then
30: if ((String.length str) = 0) then
31: []
32: else
33: [str]
34:
35: else
36: let d = ((String.index str delim) + 1) in
37: if (d = 1) then
38: (* leading delims are eaten *)
39: (parseString (String.sub str d ((String.length str) - d)) delim)
40: else
41: (String.sub str 0 (d-1)) ::
42: (parseString (String.sub str d ((String.length str) - d)) delim)
43: end;;
44:
45: let traceAddMulti (systems : string) : unit =
46: begin
47: let syslist = (parseString systems ',') in
48: (List.iter traceAddSys syslist)
49: end;;
50:
51:
52:
53: (* --------- traceIndent --------- *)
54: let traceIndentLevel : int ref = ref 0;;
55:
56:
57: let traceIndent (sys : string) : unit =
58: if (traceActive sys) then
59: traceIndentLevel := !traceIndentLevel + 2
60: ;;
61:
62: let traceOutdent (sys : string) : unit =
63: if ((traceActive sys) &&
64: (!traceIndentLevel >= 2)) then
65: traceIndentLevel := !traceIndentLevel - 2
66: ;;
67:
68:
69: (* --------- trace --------- *)
70: (* return a tag to prepend to a trace output
71: * e.g. " %%% mysys: "
72: *)
73: let traceTag (sys : string) : Flx_cil_pretty.doc =
74: (* return string of 'i' spaces *)
75: let rec ind (i : int) : string =
76: if (i <= 0) then
77: ""
78: else
79: " " ^ (ind (i-1))
80:
81: in
82: (text ((ind !traceIndentLevel) ^ "%%% " ^ sys ^ ": "))
83: ;;
84:
85:
86: (* this is the trace function; its first argument is a string
87: * tag, and subsequent arguments are like printf formatting
88: * strings ("%a" and whatnot) *)
89: let trace
90: (subsys : string) (* subsystem identifier for enabling tracing *)
91: (d : Flx_cil_pretty.doc) (* something made by 'dprintf' *)
92: : unit = (* no return value *)
93: (* (ignore (printf "trace %s\n" subsys)); *)
94:
95: (* see if the subsystem's tracing is turned on *)
96: if (traceActive subsys) then
97: begin
98: (fprint stderr 80 (* print it *)
99: ((traceTag subsys) ++ d)); (* with prepended subsys tag *)
100: (* mb: flush after every message; useful if the program hangs in an
101: infinite loop... *)
102: (flush stderr)
103: end
104: else
105: () (* eat it *)
106: ;;
107:
108:
109: let tracei (sys : string) (d : Flx_cil_pretty.doc) : unit =
110: (* trace before indent *)
111: (trace sys d);
112: (traceIndent sys)
113: ;;
114:
115: let traceu (sys : string) (d : Flx_cil_pretty.doc) : unit =
116: (* trace after outdent *)
117: (* no -- I changed my mind -- I want trace *then* outdent *)
118: (trace sys d);
119: (traceOutdent sys)
120: ;;
121:
122:
123:
124:
125: (* -------------------------- trash --------------------- *)
126: (* TRASH START
127:
128: (* sm: more experimenting *)
129: (trace "no" (dprintf "no %d\n" 5));
130: (trace "yes" (dprintf "yes %d\n" 6));
131: (trace "maybe" (dprintf "maybe %d\n" 7));
132:
133: TRASH END *)
Start ocaml section to src/flx_cil_trace.mli[1
/1
]
1: # 22515 "./lpsrc/flx_cil.ipk"
2: (* Flx_cil_trace module
3: * Scott McPeak, 5/4/00
4: *
5: * The idea is to pepper the source with debugging printfs,
6: * and be able to select which ones to actually display at
7: * runtime.
8: *
9: * It is built on top of the Flx_cil_pretty module for printing data
10: * structures.
11: *
12: * To a first approximation, this is needed to compensate for
13: * the lack of a debugger that does what I want...
14: *)
15:
16:
17: (* this is the list of tags (usually subsystem names) for which
18: * trace output will appear *)
19: val traceSubsystems : string list ref
20:
21: (* interface to add a new subsystem to trace (slightly more
22: * convenient than direclty changing 'tracingSubsystems') *)
23: val traceAddSys : string -> unit
24:
25: (* query whether a particular subsystem is being traced *)
26: val traceActive : string -> bool
27:
28: (* add several systems, separated by commas *)
29: val traceAddMulti : string -> unit
30:
31:
32: (* current indentation level for tracing *)
33: val traceIndentLevel : int ref
34:
35: (* bump up or down the indentation level, if the given subsys
36: * is being traced *)
37: val traceIndent : string -> unit
38: val traceOutdent : string -> unit
39:
40:
41: (* this is the trace function; its first argument is a string
42: * tag, and second argument is a 'doc' (which is what 'dprintf'
43: * returns).
44: *
45: * so a sample usage might be
46: * (trace "mysubsys" (dprintf "something neat happened %d times\n" counter))
47: *)
48: val trace : string -> Flx_cil_pretty.doc -> unit
49:
50:
51: (* special flavors that indent/outdent as well. the indent version
52: * indents *after* printing, while the outdent version outdents
53: * *before* printing. thus, a sequence like
54: *
55: * (tracei "foo" (dprintf "beginning razzle-dazzle\n"))
56: * ..razzle..
57: * ..dazzle..
58: * (traceu "foo" (dprintf "done with razzle-dazzle\n"))
59: *
60: * will do the right thing
61: *
62: * update -- I changed my mind! I decided I prefer it like this
63: * %%% sys: (myfunc args)
64: * %%% ...inner stuff...
65: * %%% sys: myfunc returning 56
66: *
67: * so now they both print before in/outdenting
68: *)
69: val tracei : string -> Flx_cil_pretty.doc -> unit
70: val traceu : string -> Flx_cil_pretty.doc -> unit
71:
72:
Start ocaml section to src/flx_cil_util.mli[1
/1
]
1: # 22588 "./lpsrc/flx_cil.ipk"
2: (** A bunch of generally useful functions *)
3:
4: exception GotSignal of int
5:
6: val withTimeout : float -> (* Seconds for timeout *)
7: (int -> 'b) -> (* What to do if we have a timeout. The
8: * argument passed is the signal number
9: * received. *)
10: ('a -> 'b) -> (* The function to run *)
11: 'a -> (* And its argument *)
12: 'b
13:
14: val docHash : ('a -> 'b -> Flx_cil_pretty.doc) -> unit ->
15: (('a, 'b) Hashtbl.t) -> Flx_cil_pretty.doc
16:
17:
18: val hash_to_list: ('a, 'b) Hashtbl.t -> ('a * 'b) list
19:
20: val keys: ('a, 'b) Hashtbl.t -> 'a list
21:
22:
23: (** Copy a hash table into another *)
24: val hash_copy_into: ('a, 'b) Hashtbl.t -> ('a, 'b) Hashtbl.t -> unit
25:
26: (** First, a few utility functions I wish were in the standard prelude *)
27:
28: val anticompare: 'a -> 'a -> int
29:
30: val list_drop : int -> 'a list -> 'a list
31: val list_span: ('a -> bool) -> ('a list) -> 'a list * 'a list
32: val list_insert_by: ('a -> 'a -> int) -> 'a -> 'a list -> 'a list
33: val list_head_default: 'a -> 'a list -> 'a
34: val list_iter3 : ('a -> 'b -> 'c -> unit) ->
35: 'a list -> 'b list -> 'c list -> unit
36: val get_some_option_list : 'a option list -> 'a list
37:
38: (** Iterate over a list passing the index as you go *)
39: val list_iteri: (int -> 'a -> unit) -> 'a list -> unit
40: val list_mapi: (int -> 'a -> 'b) -> 'a list -> 'b list
41:
42: (** Like fold_left but pass the index into the list as well *)
43: val list_fold_lefti: ('acc -> int -> 'a -> 'acc) -> 'acc -> 'a list -> 'acc
44:
45: val int_range_list : int -> int -> int list
46:
47: (* Create a list of length l *)
48: val list_init : int -> (int -> 'a) -> 'a list
49:
50:
51: (** mapNoCopy is like map but avoid copying the list if the function does not
52: * change the elements *)
53:
54: val mapNoCopy: ('a -> 'a) -> 'a list -> 'a list
55:
56: val mapNoCopyList: ('a -> 'a list) -> 'a list -> 'a list
57:
58: val filterNoCopy: ('a -> bool) -> 'a list -> 'a list
59:
60: (** Growable arrays *)
61: type 'a growArrayFill =
62: Elem of 'a
63: | Susp of (int -> 'a)
64:
65: type 'a growArray = {
66: gaFill: 'a growArrayFill;
67: (** Stuff to use to fill in the array as it grows *)
68:
69: mutable gaMaxInitIndex: int;
70: (** Maximum index that was written to. -1 if no writes have
71: * been made. *)
72:
73: mutable gaData: 'a array;
74: }
75:
76: val newGrowArray: int -> 'a growArrayFill -> 'a growArray
77: (** [newGrowArray initsz fillhow] *)
78:
79: val getReg: 'a growArray -> int -> 'a
80: val setReg: 'a growArray -> int -> 'a -> unit
81: val copyGrowArray: 'a growArray -> 'a growArray
82: val deepCopyGrowArray: 'a growArray -> ('a -> 'a) -> 'a growArray
83:
84:
85: val growArray_iteri: (int -> 'a -> unit) -> 'a growArray -> unit
86: (** Iterate over the initialized elements of the array *)
87:
88: val growArray_foldl: ('acc -> 'a -> 'acc) -> 'acc ->'a growArray -> 'acc
89: (** Fold left over the initialized elements of the array *)
90:
91: (** hasPrefix prefix str returns true with str starts with prefix *)
92: val hasPrefix: string -> string -> bool
93:
94:
95: (** Given a ref cell, produce a thunk that later restores it to its current value *)
96: val restoreRef: ?deepCopy:('a -> 'a) -> 'a ref -> unit -> unit
97:
98: (** Given a hash table, produce a thunk that later restores it to its current value *)
99: val restoreHash: ?deepCopy:('b -> 'b) -> ('a, 'b) Hashtbl.t -> unit -> unit
100:
101: (** Given an array, produce a thunk that later restores it to its current value *)
102: val restoreArray: ?deepCopy:('a -> 'a) -> 'a array -> unit -> unit
103:
104:
105: (** Given a list of thunks, produce a thunk that runs them all *)
106: val runThunks: (unit -> unit) list -> unit -> unit
107:
108:
109: val memoize: ('a, 'b) Hashtbl.t ->
110: 'a ->
111: ('a -> 'b) -> 'b
112:
113: (** Just another name for memoize *)
114: val findOrAdd: ('a, 'b) Hashtbl.t ->
115: 'a ->
116: ('a -> 'b) -> 'b
117:
118: val tryFinally:
119: ('a -> 'b) -> (* The function to run *)
120: ('b option -> unit) -> (* Something to run at the end. The None case is
121: * used when an exception is thrown *)
122: 'a -> 'b
123:
124:
125: (** The state information that the UI must display is viewed abstractly as a
126: * set of registers. *)
127: type registerInfo = {
128: rName: string; (** The name of the register *)
129: rGroup: string; (** The name of the group to which this register belongs.
130: * The special group Engine.machineRegisterGroup
131: * contains the machine registers, which are displayed in
132: * a special window. *)
133: rVal: Flx_cil_pretty.doc; (** The value to be displayed about a register *)
134: rOneLineVal: Flx_cil_pretty.doc option (** The value to be displayed on one line *)
135: }
136:
137:
138: (** Get the value of an option. Raises Failure if None *)
139: val valOf : 'a option -> 'a
140:
141: (**
142: * An accumulating for loop.
143: *
144: * Initialize the accumulator with init. The current index and accumulator
145: * from the previous iteration is passed to f.
146: *)
147: val fold_for : init:'a -> lo:int -> hi:int -> (int -> 'a -> 'a) -> 'a
148:
149: (************************************************************************)
150:
151: module type STACK = sig
152: type 'a t
153: (** The type of stacks containing elements of type ['a]. *)
154:
155: exception Empty
156: (** Raised when Stack.pop or Stack.top is applied to an empty stack. *)
157:
158: val create : unit -> 'a t
159:
160:
161: val push : 'a -> 'a t -> unit
162: (** [push x s] adds the element [x] at the top of stack [s]. *)
163:
164: val pop : 'a t -> 'a
165: (** [pop s] removes and returns the topmost element in stack [s],
166: or raises [Empty] if the stack is empty. *)
167:
168: val top : 'a t -> 'a
169: (** [top s] returns the topmost element in stack [s],
170: or raises [Empty] if the stack is empty. *)
171:
172: val clear : 'a t -> unit
173: (** Discard all elements from a stack. *)
174:
175: val copy : 'a t -> 'a t
176: (** Return a copy of the given stack. *)
177:
178: val is_empty : 'a t -> bool
179: (** Return [true] if the given stack is empty, [false] otherwise. *)
180:
181: val length : 'a t -> int
182: (** Return the number of elements in a stack. *)
183:
184: val iter : ('a -> unit) -> 'a t -> unit
185: (** [iter f s] applies [f] in turn to all elements of [s],
186: from the element at the top of the stack to the element at the
187: bottom of the stack. The stack itself is unchanged. *)
188: end
189:
190: module Stack : STACK
191:
192: (************************************************************************
193: Configuration
194: ************************************************************************)
195: (** The configuration data can be of several types **)
196: type configData =
197: ConfInt of int
198: | ConfBool of bool
199: | ConfFloat of float
200: | ConfString of string
201: | ConfList of configData list
202:
203:
204: (** Load the configuration from a file *)
205: val loadConfiguration: string -> unit
206:
207: (** Save the configuration in a file. Overwrites the previous values *)
208: val saveConfiguration: string -> unit
209:
210:
211: (** Clear all configuration data *)
212: val clearConfiguration: unit -> unit
213:
214: (** Set a configuration element, with a key. Overwrites the previous values *)
215: val setConfiguration: string -> configData -> unit
216:
217: (** Find a configuration elements, given a key. Raises Not_found if it canont
218: * find it *)
219: val findConfiguration: string -> configData
220:
221: (** Like findConfiguration but extracts the integer *)
222: val findConfigurationInt: string -> int
223:
224: (** Looks for an integer configuration element, and if it is found, it uses
225: * the given function. Otherwise, does nothing *)
226: val useConfigurationInt: string -> (int -> unit) -> unit
227:
228:
229: val findConfigurationBool: string -> bool
230: val useConfigurationBool: string -> (bool -> unit) -> unit
231:
232: val findConfigurationString: string -> string
233: val useConfigurationString: string -> (string -> unit) -> unit
234:
235: val findConfigurationList: string -> configData list
236: val useConfigurationList: string -> (configData list -> unit) -> unit
237:
238:
239: (************************************************************************)
240:
241: (** Symbols are integers that are uniquely associated with names *)
242: type symbol = int
243:
244: (** Get the name of a symbol *)
245: val symbolName: symbol -> string
246:
247: (** Register a symbol name and get the symbol for it *)
248: val registerSymbolName: string -> symbol
249:
250: (** Register a number of consecutive symbol ids. The naming function will be
251: * invoked with indices from 0 to the counter - 1. Returns the id of the
252: * first symbol created *)
253: val registerSymbolRange: int -> (int -> string) -> symbol
254:
Start ocaml section to src/flx_cil_util.ml[1
/1
]
1: # 22843 "./lpsrc/flx_cil.ipk"
2: (** Flx_cil_utility functions for Coolaid *)
3: module E = Flx_cil_errormsg
4: module H = Hashtbl
5: module IH = Flx_cil_inthash
6:
7: open Flx_cil_pretty
8:
9: exception GotSignal of int
10:
11: let withTimeout (secs: float) (* Seconds for timeout *)
12: (handler: int -> 'b) (* What to do if we have a timeout. The
13: * argument passed is the signal number
14: * received. *)
15: (f: 'a -> 'b) (* The function to run *)
16: (arg: 'a) (* And its argument *)
17: : 'b =
18: let oldHandler =
19: Sys.signal Sys.sigalrm
20: (Sys.Signal_handle
21: (fun i ->
22: ignore (E.log "Got signal %d\n" i);
23: raise (GotSignal i)))
24: in
25: let reset_sigalrm () =
26: ignore (Unix.setitimer Unix.ITIMER_REAL { Unix.it_value = 0.0;
27: Unix.it_interval = 0.0;});
28: Sys.set_signal Sys.sigalrm oldHandler;
29: in
30: ignore (Unix.setitimer Unix.ITIMER_REAL
31: { Unix.it_value = secs;
32: Unix.it_interval = 0.0;});
33: (* ignore (Unix.alarm 2); *)
34: try
35: let res = f arg in
36: reset_sigalrm ();
37: res
38: with exc -> begin
39: reset_sigalrm ();
40: ignore (E.log "Got an exception\n");
41: match exc with
42: GotSignal i ->
43: handler i
44: | _ -> raise exc
45: end
46:
47: (** Print a hash table *)
48: let docHash (one: 'a -> 'b -> doc) () (h: ('a, 'b) H.t) =
49: let theDoc = ref nil in
50: (H.fold
51: (fun key data acc -> acc ++ one key data)
52: h
53: align) ++ unalign
54:
55:
56:
57: let hash_to_list (h: ('a, 'b) H.t) : ('a * 'b) list =
58: H.fold
59: (fun key data acc -> (key, data) :: acc)
60: h
61: []
62:
63: let keys (h: ('a, 'b) H.t) : 'a list =
64: H.fold
65: (fun key data acc -> key :: acc)
66: h
67: []
68:
69: let hash_copy_into (hfrom: ('a, 'b) H.t) (hto: ('a, 'b) H.t) : unit =
70: H.clear hto;
71: H.iter (H.add hto) hfrom
72:
73: let anticompare a b = compare b a
74: ;;
75:
76:
77: let rec list_drop (n : int) (xs : 'a list) : 'a list =
78: if n < 0 then invalid_arg "Flx_cil_util.list_drop";
79: if n = 0 then
80: xs
81: else begin
82: match xs with
83: | [] -> invalid_arg "Flx_cil_util.list_drop"
84: | y::ys -> list_drop (n-1) ys
85: end
86:
87:
88: let rec list_span (p : 'a -> bool) (xs : 'a list) : 'a list * 'a list =
89: begin match xs with
90: | [] -> ([],[])
91: | x::xs' ->
92: if p x then
93: let (ys,zs) = list_span p xs' in (x::ys,zs)
94: else ([],xs)
95: end
96: ;;
97:
98: let rec list_rev_append revxs ys =
99: begin match revxs with
100: | [] -> ys
101: | x::xs -> list_rev_append xs (x::ys)
102: end
103: ;;
104: let list_insert_by (cmp : 'a -> 'a -> int)
105: (x : 'a) (xs : 'a list) : 'a list =
106: let rec helper revhs ts =
107: begin match ts with
108: | [] -> List.rev (x::revhs)
109: | t::ts' ->
110: if cmp x t >= 0 then helper (t::revhs) ts'
111: else list_rev_append (x::revhs) ts
112: end
113: in
114: helper [] xs
115: ;;
116:
117: let list_head_default (d : 'a) (xs : 'a list) : 'a =
118: begin match xs with
119: | [] -> d
120: | x::_ -> x
121: end
122: ;;
123:
124: let rec list_iter3 f xs ys zs =
125: begin match xs, ys, zs with
126: | [], [], [] -> ()
127: | x::xs, y::ys, z::zs -> f x y z; list_iter3 f xs ys zs
128: | _ -> invalid_arg "Flx_cil_util.list_iter3"
129: end
130: ;;
131:
132: let rec get_some_option_list (xs : 'a option list) : 'a list =
133: begin match xs with
134: | [] -> []
135: | None::xs -> get_some_option_list xs
136: | Some x::xs -> x :: get_some_option_list xs
137: end
138: ;;
139:
140: let list_iteri (f: int -> 'a -> unit) (l: 'a list) : unit =
141: let rec loop (i: int) (l: 'a list) : unit =
142: match l with
143: [] -> ()
144: | h :: t -> f i h; loop (i + 1) t
145: in
146: loop 0 l
147:
148: let list_mapi (f: int -> 'a -> 'b) (l: 'a list) : 'b list =
149: let rec loop (i: int) (l: 'a list) : 'b list =
150: match l with
151: [] -> []
152: | h :: t ->
153: let headres = f i h in
154: headres :: loop (i + 1) t
155: in
156: loop 0 l
157:
158: let list_fold_lefti (f: 'acc -> int -> 'a -> 'acc) (start: 'acc)
159: (l: 'a list) : 'acc =
160: let rec loop (i, acc) l =
161: match l with
162: [] -> acc
163: | h :: t -> loop (i + 1, f acc i h) t
164: in
165: loop (0, start) l
166:
167:
168: let list_init (len : int) (init_fun : int -> 'a) : 'a list =
169: let rec loop n acc =
170: if n < 0 then acc
171: else loop (n-1) ((init_fun n)::acc)
172: in
173: loop (len - 1) []
174: ;;
175:
176:
177: (** Generates the range of integers starting with a and ending with b *)
178: let int_range_list (a: int) (b: int) =
179: list_init (b - a + 1) (fun i -> a + i)
180:
181:
182: (** Some handling of registers *)
183: type 'a growArrayFill =
184: Elem of 'a
185: | Susp of (int -> 'a)
186:
187: type 'a growArray = {
188: gaFill: 'a growArrayFill;
189: (** Stuff to use to fill in the array as it grows *)
190:
191: mutable gaMaxInitIndex: int;
192: (** Maximum index that was written to. -1 if no writes have
193: * been made. *)
194:
195: mutable gaData: 'a array;
196: }
197:
198: let growTheArray (ga: 'a growArray) (len: int)
199: (toidx: int) (why: string) : unit =
200: if toidx >= len then begin
201: (* Grow the array by 50% *)
202: let newlen = toidx + 1 + len / 2 in
203: (*
204: ignore (E.log "growing an array to idx=%d (%s)\n" toidx why);
205: *)
206: let data' = begin match ga.gaFill with
207: Elem x ->
208:
209: let data'' = Array.create newlen x in
210: Array.blit ga.gaData 0 data'' 0 len;
211: data''
212: | Susp f -> Array.init newlen
213: (fun i -> if i < len then ga.gaData.(i) else f i)
214: end
215: in
216: ga.gaData <- data'
217: end
218:
219: let getReg (ga: 'a growArray) (r: int) : 'a =
220: let len = Array.length ga.gaData in
221: if r >= len then
222: growTheArray ga len r "get";
223:
224: ga.gaData.(r)
225:
226: let setReg (ga: 'a growArray) (r: int) (what: 'a) : unit =
227: let len = Array.length ga.gaData in
228: if r >= len then
229: growTheArray ga len r "set";
230: if r > ga.gaMaxInitIndex then ga.gaMaxInitIndex <- r;
231: ga.gaData.(r) <- what
232:
233: let newGrowArray (initsz: int) (fill: 'a growArrayFill) : 'a growArray =
234: { gaFill = fill;
235: gaMaxInitIndex = -1;
236: gaData = begin match fill with
237: Elem x -> Array.create initsz x
238: | Susp f -> Array.init initsz f
239: end; }
240:
241: let copyGrowArray (ga: 'a growArray) : 'a growArray =
242: { ga with gaData = Array.copy ga.gaData }
243:
244: let deepCopyGrowArray (ga: 'a growArray) (copy: 'a -> 'a): 'a growArray =
245: { ga with gaData = Array.map copy ga.gaData }
246:
247:
248:
249: (** Iterate over the initialized elements of the array *)
250: let growArray_iteri (f: int -> 'a -> unit) (ga: 'a growArray) =
251: for i = 0 to ga.gaMaxInitIndex do
252: f i ga.gaData.(i)
253: done
254:
255:
256: (** Fold left over the initialized elements of the array *)
257: let growArray_foldl (f: 'acc -> 'a -> 'acc)
258: (acc: 'acc) (ga: 'a growArray) : 'acc =
259: let rec loop (acc: 'acc) (idx: int) : 'acc =
260: if idx > ga.gaMaxInitIndex then
261: acc
262: else
263: loop (f acc ga.gaData.(idx)) (idx + 1)
264: in
265: loop acc 0
266:
267:
268:
269:
270: let hasPrefix (prefix: string) (what: string) : bool =
271: let pl = String.length prefix in
272: try String.sub what 0 pl = prefix
273: with Invalid_argument _ -> false
274:
275:
276:
277: let restoreRef ?(deepCopy=(fun x -> x)) (r: 'a ref) : (unit -> unit) =
278: let old = deepCopy !r in
279: (fun () -> r := old)
280:
281: let restoreHash ?deepCopy (h: ('a, 'b) H.t) : (unit -> unit) =
282: let old =
283: match deepCopy with
284: None -> H.copy h
285: | Some f ->
286: let old = H.create 13 in
287: H.iter (fun k d -> H.add old k (f d)) h;
288: old
289: in
290: (fun () -> hash_copy_into old h)
291:
292: let restoreArray ?deepCopy (a: 'a array) : (unit -> unit) =
293: let old = Array.copy a in
294: (match deepCopy with
295: None -> ()
296: | Some f -> Array.iteri (fun i v -> old.(i) <- f v) old);
297: (fun () -> Array.blit old 0 a 0 (Array.length a))
298:
299: let runThunks (l: (unit -> unit) list) : (unit -> unit) =
300: fun () -> List.iter (fun f -> f ()) l
301:
302:
303:
304: (* Memoize *)
305: let memoize (h: ('a, 'b) Hashtbl.t)
306: (arg: 'a)
307: (f: 'a -> 'b) : 'b =
308: try
309: Hashtbl.find h arg
310: with Not_found -> begin
311: let res = f arg in
312: Hashtbl.add h arg res;
313: res
314: end
315:
316: (* Just another name for memoize *)
317: let findOrAdd h arg f = memoize h arg f
318:
319: (* A tryFinally function *)
320: let tryFinally
321: (main: 'a -> 'b) (* The function to run *)
322: (final: 'b option -> unit) (* Something to run at the end *)
323: (arg: 'a) : 'b =
324: try
325: let res: 'b = main arg in
326: final (Some res);
327: res
328: with e -> begin
329: final None;
330: raise e
331: end
332:
333:
334:
335:
336: (** The state information that the GUI must display is viewed abstractly as a
337: * set of registers. *)
338: type registerInfo = {
339: rName: string; (** The name of the register *)
340: rGroup: string; (** The name of the group to which this register belongs.
341: * The special group Engine.machineRegisterGroup
342: * contains the machine registers. *)
343: rVal: Flx_cil_pretty.doc; (** The value to be displayed about a register *)
344: rOneLineVal: Flx_cil_pretty.doc option (** The value to be displayed on one line *)
345: }
346:
347:
348:
349: let valOf : 'a option -> 'a = function
350: None -> raise (Failure "Flx_cil_util.valOf")
351: | Some x -> x
352:
353: (**
354: * An accumulating for loop.
355: *
356: * Initialize the accumulator with init. The current index and accumulator
357: * from the previous iteration is passed to f.
358: *)
359: let fold_for ~(init: 'a) ~(lo: int) ~(hi: int) (f: int -> 'a -> 'a) =
360: let rec forloop i acc =
361: if i > hi then acc
362: else forloop (i+1) (f i acc)
363: in
364: forloop lo init
365:
366: (************************************************************************)
367:
368: module type STACK = sig
369: type 'a t
370: (** The type of stacks containing elements of type ['a]. *)
371:
372: exception Empty
373: (** Raised when Stack.pop or Stack.top is applied to an empty stack. *)
374:
375: val create : unit -> 'a t
376: (** Return a new stack, initially empty. *)
377:
378: val push : 'a -> 'a t -> unit
379: (** [push x s] adds the element [x] at the top of stack [s]. *)
380:
381: val pop : 'a t -> 'a
382: (** [pop s] removes and returns the topmost element in stack [s],
383: or raises [Empty] if the stack is empty. *)
384:
385: val top : 'a t -> 'a
386: (** [top s] returns the topmost element in stack [s],
387: or raises [Empty] if the stack is empty. *)
388:
389: val clear : 'a t -> unit
390: (** Discard all elements from a stack. *)
391:
392: val copy : 'a t -> 'a t
393: (** Return a copy of the given stack. *)
394:
395: val is_empty : 'a t -> bool
396: (** Return [true] if the given stack is empty, [false] otherwise. *)
397:
398: val length : 'a t -> int
399: (** Return the number of elements in a stack. *)
400:
401: val iter : ('a -> unit) -> 'a t -> unit
402: (** [iter f s] applies [f] in turn to all elements of [s],
403: from the element at the top of the stack to the element at the
404: bottom of the stack. The stack itself is unchanged. *)
405: end
406:
407: module Stack = struct
408:
409: type 'a t = { mutable length : int;
410: stack : 'a Stack.t; }
411:
412: exception Empty
413:
414: let create () = { length = 0;
415: stack = Stack.create(); }
416:
417: let push x s =
418: s.length <- s.length + 1;
419: Stack.push x s.stack
420:
421: let pop s =
422: s.length <- s.length - 1;
423: Stack.pop s.stack
424:
425: let top s =
426: Stack.top s.stack
427:
428: let clear s =
429: s.length <- 0;
430: Stack.clear s.stack
431:
432: let copy s = { length = s.length;
433: stack = Stack.copy s.stack; }
434:
435: let is_empty s =
436: Stack.is_empty s.stack
437:
438: let length s = s.length
439:
440: let iter f s =
441: Stack.iter f s.stack
442:
443: end
444:
445: (************************************************************************)
446:
447: let absoluteFilename (fname: string) =
448: if Filename.is_relative fname then
449: Filename.concat (Sys.getcwd ()) fname
450: else
451: fname
452:
453:
454: (* mapNoCopy is like map but avoid copying the list if the function does not
455: * change the elements. *)
456: let rec mapNoCopy (f: 'a -> 'a) = function
457: [] -> []
458: | (i :: resti) as li ->
459: let i' = f i in
460: let resti' = mapNoCopy f resti in
461: if i' != i || resti' != resti then i' :: resti' else li
462:
463: let rec mapNoCopyList (f: 'a -> 'a list) = function
464: [] -> []
465: | (i :: resti) as li ->
466: let il' = f i in
467: let resti' = mapNoCopyList f resti in
468: match il' with
469: [i'] when i' == i && resti' == resti -> li
470: | _ -> il' @ resti'
471:
472:
473: (* Use a filter function that does not rewrite the list unless necessary *)
474: let rec filterNoCopy (f: 'a -> bool) (l: 'a list) : 'a list =
475: match l with
476: [] -> []
477: | h :: rest when not (f h) -> filterNoCopy f rest
478: | h :: rest ->
479: let rest' = filterNoCopy f rest in
480: if rest == rest' then l else h :: rest'
481:
482:
483: (************************************************************************
484:
485: Configuration
486:
487: ************************************************************************)
488: (** The configuration data can be of several types **)
489: type configData =
490: ConfInt of int
491: | ConfBool of bool
492: | ConfFloat of float
493: | ConfString of string
494: | ConfList of configData list
495:
496:
497: (* Store here window configuration file *)
498: let configurationData: (string, configData) H.t = H.create 13
499:
500: let clearConfiguration () = H.clear configurationData
501:
502: let setConfiguration (key: string) (c: configData) =
503: H.replace configurationData key c
504:
505: let findConfiguration (key: string) : configData =
506: H.find configurationData key
507:
508: let findConfigurationInt (key: string) : int =
509: match findConfiguration key with
510: ConfInt i -> i
511: | _ ->
512: ignore (E.warn "Configuration %s is not an integer" key);
513: raise Not_found
514:
515: let useConfigurationInt (key: string) (f: int -> unit) =
516: try f (findConfigurationInt key)
517: with Not_found -> ()
518:
519: let findConfigurationString (key: string) : string =
520: match findConfiguration key with
521: ConfString s -> s
522: | _ ->
523: ignore (E.warn "Configuration %s is not a string" key);
524: raise Not_found
525:
526: let useConfigurationString (key: string) (f: string -> unit) =
527: try f (findConfigurationString key)
528: with Not_found -> ()
529:
530:
531: let findConfigurationBool (key: string) : bool =
532: match findConfiguration key with
533: ConfBool b -> b
534: | _ ->
535: ignore (E.warn "Configuration %s is not a boolean" key);
536: raise Not_found
537:
538: let useConfigurationBool (key: string) (f: bool -> unit) =
539: try f (findConfigurationBool key)
540: with Not_found -> ()
541:
542: let findConfigurationList (key: string) : configData list =
543: match findConfiguration key with
544: ConfList l -> l
545: | _ ->
546: ignore (E.warn "Configuration %s is not a list" key);
547: raise Not_found
548:
549: let useConfigurationList (key: string) (f: configData list -> unit) =
550: try f (findConfigurationList key)
551: with Not_found -> ()
552:
553:
554: let saveConfiguration (fname: string) =
555: (** Convert configuration data to a string, for saving externally *)
556: let configToString (c: configData) : string =
557: let buff = Buffer.create 80 in
558: let rec loop (c: configData) : unit =
559: match c with
560: ConfInt i ->
561: Buffer.add_char buff 'i';
562: Buffer.add_string buff (string_of_int i);
563: Buffer.add_char buff ';'
564:
565: | ConfBool b ->
566: Buffer.add_char buff 'b';
567: Buffer.add_string buff (string_of_bool b);
568: Buffer.add_char buff ';'
569:
570: | ConfFloat f ->
571: Buffer.add_char buff 'f';
572: Buffer.add_string buff (string_of_float f);
573: Buffer.add_char buff ';'
574:
575: | ConfString s ->
576: if String.contains s '"' then
577: E.s (E.unimp "Guilib: configuration string contains quotes");
578: Buffer.add_char buff '"';
579: Buffer.add_string buff s;
580: Buffer.add_char buff '"'; (* '"' *)
581:
582: | ConfList l ->
583: Buffer.add_char buff '[';
584: List.iter loop l;
585: Buffer.add_char buff ']'
586: in
587: loop c;
588: Buffer.contents buff
589: in
590: try
591: let oc = open_out fname in
592: ignore (E.log "Saving configuration to %s\n" (absoluteFilename fname));
593: H.iter (fun k c ->
594: output_string oc (k ^ "\n");
595: output_string oc ((configToString c) ^ "\n"))
596: configurationData;
597: close_out oc
598: with _ ->
599: ignore (E.warn "Cannot open configuration file %s\n" fname)
600:
601:
602: (** Make some regular expressions early *)
603: let intRegexp = Str.regexp "i\\([0-9]+\\);"
604: let floatRegexp = Str.regexp "f\\([0-9]+\\.[0-9]+\\);"
605: let boolRegexp = Str.regexp "b\\(\\(true\\)\\|\\(false\\)\\);"
606: let stringRegexp = Str.regexp "\"\\([^\"]*\\)\""
607:
608: let loadConfiguration (fname: string) : unit =
609: H.clear configurationData;
610:
611: let stringToConfig (s: string) : configData =
612: let idx = ref 0 in (** the current index *)
613: let l = String.length s in
614:
615: let rec getOne () : configData =
616: if !idx >= l then raise Not_found;
617:
618: if Str.string_match intRegexp s !idx then begin
619: idx := Str.match_end ();
620: ConfInt (int_of_string (Str.matched_group 1 s))
621: end else if Str.string_match floatRegexp s !idx then begin
622: idx := Str.match_end ();
623: ConfFloat (float_of_string (Str.matched_group 1 s))
624: end else if Str.string_match boolRegexp s !idx then begin
625: idx := Str.match_end ();
626: ConfBool (bool_of_string (Str.matched_group 1 s))
627: end else if Str.string_match stringRegexp s !idx then begin
628: idx := Str.match_end ();
629: ConfString (Str.matched_group 1 s)
630: end else if String.get s !idx = '[' then begin
631: (* We are starting a list *)
632: incr idx;
633: let rec loop (acc: configData list) : configData list =
634: if !idx >= l then begin
635: ignore (E.warn "Non-terminated list in configuration %s" s);
636: raise Not_found
637: end;
638: if String.get s !idx = ']' then begin
639: incr idx;
640: List.rev acc
641: end else
642: loop (getOne () :: acc)
643: in
644: ConfList (loop [])
645: end else begin
646: ignore (E.warn "Bad configuration element in a list: %s\n"
647: (String.sub s !idx (l - !idx)));
648: raise Not_found
649: end
650: in
651: getOne ()
652: in
653: (try
654: let ic = open_in fname in
655: ignore (E.log "Loading configuration from %s\n" (absoluteFilename fname));
656: (try
657: while true do
658: let k = input_line ic in
659: let s = input_line ic in
660: try
661: let c = stringToConfig s in
662: setConfiguration k c
663: with Not_found -> ()
664: done
665: with End_of_file -> ());
666: close_in ic;
667: with _ -> () (* no file, ignore *));
668:
669: ()
670:
671:
672:
673: (************************************************************************)
674:
675: (*********************************************************************)
676: type symbol = int
677:
678: (**{ Registering symbol names} *)
679: let registeredSymbolNames: (string, symbol) H.t = H.create 113
680: let symbolNames: string IH.t = IH.create 113
681: let nextSymbolId = ref 0
682:
683: let registerSymbolName (n: string) : symbol =
684: try H.find registeredSymbolNames n
685: with Not_found -> begin
686: let id = !nextSymbolId in
687: incr nextSymbolId;
688: H.add registeredSymbolNames n id;
689: IH.add symbolNames id n;
690: id
691: end
692:
693: (** Register a range of symbols. The mkname function will be invoked for
694: * indices starting at 0 *)
695: let registerSymbolRange (count: int) (mkname: int -> string) : symbol =
696: if count < 0 then E.s (E.bug "registerSymbolRange: invalid counter");
697: let first = !nextSymbolId in
698: for i = 0 to count - 1 do
699: ignore (registerSymbolName (mkname i))
700: done;
701: first
702:
703: let symbolName (id: symbol) : string =
704: try IH.find symbolNames id
705: with Not_found ->
706: ignore (E.warn "Cannot find the name of symbol %d" id);
707: "pseudo" ^ string_of_int id
708:
709:
Start ocaml section to src/flxcc.ml[1
/1
]
1: # 69 "./lpsrc/flx_flxcc.pak"
2: open List
3: open Flx_util
4: open Flx_types
5: open Flx_version
6: open Flx_mtypes1
7: open Flx_cil_cabs
8: open Flx_cil_cil
9: ;;
10:
11: let force_open_in place f =
12: try
13: open_in f
14: with
15: | _ -> failwith ("[" ^ place ^ "] Can't open " ^ f ^ " for input")
16:
17: let force_open_out place f =
18: try
19: open_out f
20: with
21: | _ -> failwith ("[" ^ place ^ "] Can't open " ^ f ^ " for output")
22:
23: type stab_t = {
24: stab_cfile: string;
25: stab_flxfile: string;
26: stab_flxinclude: string;
27: stab_module: string;
28:
29: aliases: (string,string) Hashtbl.t;
30: struct_aliases: (string,string) Hashtbl.t;
31: abstract_types: (string,string) Hashtbl.t;
32: incomplete_types: (string,string) Hashtbl.t;
33: mutable xtyps: (string,string) Hashtbl.t;
34: mutable udt: (string,unit) Hashtbl.t;
35: mutable ict: (string,string) Hashtbl.t;
36: used_types: (string,unit) Hashtbl.t;
37: variables : (string,string) Hashtbl.t;
38: functions: (string * typsig list * string,string * string) Hashtbl.t;
39: fields: (string,string * string) Hashtbl.t;
40: cstructs : (string,(string * string) list) Hashtbl.t;
41: procedures: (string * typsig list * string,string * string) Hashtbl.t;
42: callback_types: (string,typ * int) Hashtbl.t;
43: callback_clients: (string,typ * string * int * int) Hashtbl.t;
44: enums: (string,string) Hashtbl.t;
45: registry: (typsig, string * string) Hashtbl.t;
46: mutable includes: StringSet.t;
47: counter: int ref
48: }
49: ;;
50:
51: let isprefix p s =
52: let pn = String.length p in
53: String.length s >= pn &&
54: String.sub s 0 pn = p
55: ;;
56:
57: exception Next
58: ;;
59: type control_t = {
60: mutable control_filename: string;
61: mutable flxg_command: string;
62: mutable prein_filename: string;
63: mutable preout_filename: string;
64: mutable log_filename: string;
65: mutable language: Flx_cil_cabs.lang_t;
66: mutable preprocessor: string;
67: mutable raw_includes: StringSet.t;
68: mutable raw_include_dirs : StringSet.t;
69: mutable include_path: string list;
70: mutable noincludes: string list;
71: mutable merge_files: (string * string) list;
72: mutable rev_merge_files: (string,string list) Hashtbl.t;
73: mutable outdir: string;
74: mutable repl_prefix: (string * string) list;
75: stabs : (string,stab_t) Hashtbl.t;
76: all_types : (string,string) Hashtbl.t;
77: incomplete_types_cache: (string,string * string list) Hashtbl.t;
78: mutable files: StringSet.t;
79: replacements : (string,string) Hashtbl.t;
80: nontype_replacements : (string,string) Hashtbl.t;
81: rejects: (string,unit) Hashtbl.t;
82: mutable root_includes: string list;
83: mutable root_rec_includes: string list;
84: mutable root_excludes : string list;
85: }
86: ;;
87:
88: let control = {
89: control_filename = Sys.argv.(1);
90: flxg_command = "";
91: prein_filename = Sys.argv.(1) ^ ".h";
92: preout_filename = Sys.argv.(1) ^ ".i";
93: log_filename = Sys.argv.(1) ^ ".log";
94: language = `C;
95: preprocessor ="cpp ";
96: noincludes = [];
97: raw_includes = StringSet.empty;
98: raw_include_dirs = StringSet.empty;
99: include_path = [];
100: merge_files = [];
101: rev_merge_files = Hashtbl.create 97;
102: outdir = "flxcc_out";
103: repl_prefix = [];
104: stabs = Hashtbl.create 97;
105: all_types = Hashtbl.create 97;
106: incomplete_types_cache = Hashtbl.create 97;
107: files = StringSet.empty;
108: replacements = Hashtbl.create 97;
109: nontype_replacements = Hashtbl.create 97;
110: rejects = Hashtbl.create 97;
111: root_rec_includes = [];
112: root_includes = [];
113: root_excludes = [];
114: }
115: ;;
116:
117: (* map the name of a #include file which is
118: intended to be a physical part of another
119: into that filename.
120:
121: The mapping is used to prevent
122: a Felix include file or module being
123: created for definitions in this file,
124: but it should *only* be used when a file
125: is uniquely included by another
126:
127: When we're scanning for includes,
128: we need all the physical (unmapped)
129: filenames as inputs to find the transitive
130: closure. Once that is done, the transitive
131: closure itself must be mapped to avoid
132: references to non-existent Felix modules.
133: *)
134:
135: let rec glob dir recurse level =
136: if not (mem dir control.root_excludes) then
137: let spaces = String.make level ' ' in
138: try
139: let f = Unix.opendir dir in
140: control.raw_include_dirs <- StringSet.add dir control.raw_include_dirs;
141: begin
142: try
143: while true do let m = Unix.readdir f in
144: let path = Filename.concat dir m in
145: let st =
146: try Unix.lstat path
147: with _ -> failwith ("Can't lstat " ^ path)
148: in
149: match st.Unix.st_kind with
150: | Unix.S_REG ->
151: if not (mem path control.root_excludes)
152: then begin
153: control.raw_includes <- StringSet.add path control.raw_includes;
154: control.files <- StringSet.add path control.files
155: end
156:
157: | Unix.S_DIR ->
158: if recurse then
159: if not (isprefix "." m) then
160: begin
161: glob path recurse (level + 1)
162: end
163:
164: | _ -> ()
165: done
166: with End_of_file -> Unix.closedir f
167: end
168: with Unix.Unix_error _ ->
169: failwith ("Can't find directory " ^ dir)
170: ;;
171:
172: let pattern = ref "*.h"
173: ;;
174:
175: let rec parse_control_file filename =
176: let f = force_open_in "parse_control_file" filename
177: in
178: let rec aux () =
179: try
180: let line = input_line f in
181: let n = String.length line in
182: let i = ref 0 in
183: try
184: (* skip white *)
185: while !i < n && line.[!i]=' ' do incr i done;
186: if !i = n then raise Next;
187:
188: (* detect C++ style comment *)
189: if isprefix "//" (String.sub line !i (n - !i))
190: then raise Next
191: ;
192: let j = !i in
193: while !i < n && line.[!i]<>' ' do incr i done;
194: let keyword = String.sub line j (!i-j) in
195:
196: match keyword with
197: | "#include" ->
198: while !i < n && line.[!i]=' ' do incr i done;
199: if !i = n then failwith "outdir statement requires filename";
200: let j = !i in
201: while !i < n && line.[!i]<>' ' do incr i done;
202: let fn = String.sub line j (!i-j) in
203: parse_control_file fn;
204: raise Next
205:
206: | "outdir" ->
207: while !i < n && line.[!i]=' ' do incr i done;
208: if !i = n then failwith "outdir statement requires filename";
209: let j = !i in
210: while !i < n && line.[!i]<>' ' do incr i done;
211: control.outdir <- String.sub line j (!i-j);
212: raise Next
213:
214: | "prein" ->
215: while !i < n && line.[!i]=' ' do incr i done;
216: if !i = n then failwith "prein statement requires filename";
217: let j = !i in
218: while !i < n && line.[!i]<>' ' do incr i done;
219: control.prein_filename <- String.sub line j (!i-j);
220: raise Next
221:
222: | "preout" ->
223: while !i < n && line.[!i]=' ' do incr i done;
224: if !i = n then failwith "preout statement requires filename";
225: let j = !i in
226: while !i < n && line.[!i]<>' ' do incr i done;
227: control.preout_filename <- String.sub line j (!i-j);
228: raise Next
229:
230: | "language" ->
231: while !i < n && line.[!i]=' ' do incr i done;
232: if !i = n then failwith "preout statement requires filename";
233: let j = !i in
234: while !i < n && line.[!i]<>' ' do incr i done;
235: let x = String.sub line j (!i-j) in
236: control.language <-
237: (
238: match x with
239: | "C" | "c" -> `C
240: | "C++" | "c++" | "cxx" -> `Cxx
241: | _ -> failwith ("Unknown language " ^ x ^", must be C or C++")
242: )
243: ;
244: raise Next
245:
246: | "flx_compiler" ->
247: while !i < n && line.[!i]=' ' do incr i done;
248: let j = !i in
249: while !i < n do incr i done;
250: control.flxg_command <- String.sub line j (!i-j);
251: raise Next
252:
253: | "preprocessor" ->
254: while !i < n && line.[!i]=' ' do incr i done;
255: if !i = n then failwith "preprocessor statement requires arguments";
256: let j = !i in
257: while !i < n do incr i done;
258: control.preprocessor <- String.sub line j (!i-j);
259: raise Next
260:
261: | "noheader" ->
262: while !i < n && line.[!i]=' ' do incr i done;
263: if !i = n then failwith "noinclude statement requires filename";
264: let j = !i in
265: while !i < n && line.[!i]<>' ' do incr i done;
266: let fn = String.sub line j (!i-j) in
267: control.noincludes <- fn :: control.noincludes;
268: raise Next
269:
270: | "incdir" ->
271: while !i < n && line.[!i]=' ' do incr i done;
272: if !i = n then failwith "incdir statement requires filename";
273: let j = !i in
274: while !i < n && line.[!i]<>' ' do incr i done;
275: let fn = String.sub line j (!i-j) in
276: control.root_includes <- fn :: control.root_includes;
277: raise Next
278:
279: | "incfile" ->
280: while !i < n && line.[!i]=' ' do incr i done;
281: if !i = n then failwith "incfile statement requires filename";
282: let j = !i in
283: while !i < n && line.[!i]<>' ' do incr i done;
284: let fn = String.sub line j (!i-j) in
285: control.raw_includes <- StringSet.add fn control.raw_includes;
286: raise Next
287:
288: | "recincdir" ->
289: while !i < n && line.[!i]=' ' do incr i done;
290: if !i = n then failwith "incdir statement requires filename";
291: let j = !i in
292: while !i < n && line.[!i]<>' ' do incr i done;
293: let fn = String.sub line j (!i-j) in
294: control.root_rec_includes <- fn :: control.root_rec_includes;
295: raise Next
296:
297: | "path" ->
298: while !i < n && line.[!i]=' ' do incr i done;
299: if !i = n then failwith "path statement requires filename";
300: let j = !i in
301: while !i < n && line.[!i]<>' ' do incr i done;
302: let fn = String.sub line j (!i-j) in
303: control.include_path <- control.include_path @ [fn];
304: raise Next
305:
306: | "exclude" ->
307: while !i < n && line.[!i]=' ' do incr i done;
308: if !i = n then failwith "exclude statement requires filename";
309: let j = !i in
310: while !i < n && line.[!i]<>' ' do incr i done;
311: let fn = String.sub line j (!i-j) in
312: control.root_excludes<- fn :: control.root_excludes;
313: raise Next
314:
315: | "prefix" ->
316: while !i < n && line.[!i]=' ' do incr i done;
317: if !i = n then failwith "prefix statement requires filename";
318: let j = !i in
319: while !i < n && line.[!i]<>' ' do incr i done;
320: let fn1 = String.sub line j (!i-j) in
321:
322: while !i < n && line.[!i]=' ' do incr i done;
323: let fn2 =
324: if !i = n then ""
325: else begin
326: let j = !i in
327: while !i < n && line.[!i]<>' ' do incr i done;
328: String.sub line j (!i-j)
329: end
330: in
331: control.repl_prefix <- (fn1, fn2) :: control.repl_prefix;
332: raise Next
333:
334: | "merge" ->
335: while !i < n && line.[!i]=' ' do incr i done;
336: if !i = n then failwith "merge statement requires filename";
337: let j = !i in
338: while !i < n && line.[!i]<>' ' do incr i done;
339: let fn1 = String.sub line j (!i-j) in
340:
341: while !i < n && line.[!i]=' ' do incr i done;
342: if !i = n then failwith "merge statement requires 2 filenames";
343: let j = !i in
344: while !i < n && line.[!i]<>' ' do incr i done;
345: let fn2 = String.sub line j (!i-j) in
346: control.merge_files <- (fn1,fn2) :: control.merge_files;
347: let x =
348: try Hashtbl.find control.rev_merge_files fn2
349: with Not_found -> []
350: in Hashtbl.replace control.rev_merge_files fn2 (fn1::x)
351: ;
352: raise Next
353:
354: | "rename" ->
355: while !i < n && line.[!i]=' ' do incr i done;
356: if !i = n then failwith "rename statement requires name";
357: let j = !i in
358: while !i < n && line.[!i]<>' ' do incr i done;
359: let fn1 = String.sub line j (!i-j) in
360:
361: while !i < n && line.[!i]=' ' do incr i done;
362: if !i = n then failwith "rename statement requires 2 names";
363: let j = !i in
364: while !i < n && line.[!i]<>' ' do incr i done;
365: let fn2 = String.sub line j (!i-j) in
366: Hashtbl.add control.replacements fn1 fn2;
367: raise Next
368:
369: | "rename_nontype" ->
370: while !i < n && line.[!i]=' ' do incr i done;
371: if !i = n then failwith "rename_nontype statement requires name";
372: let j = !i in
373: while !i < n && line.[!i]<>' ' do incr i done;
374: let fn1 = String.sub line j (!i-j) in
375:
376: while !i < n && line.[!i]=' ' do incr i done;
377: if !i = n then failwith "rename_nontype statement requires 2 names";
378: let j = !i in
379: while !i < n && line.[!i]<>' ' do incr i done;
380: let fn2 = String.sub line j (!i-j) in
381: Hashtbl.add control.nontype_replacements fn1 fn2;
382: raise Next
383:
384: | "ignore" ->
385: while !i < n && line.[!i]=' ' do incr i done;
386: if !i = n then failwith "ignore statement requires name";
387: let j = !i in
388: while !i < n && line.[!i]<>' ' do incr i done;
389: let fn = String.sub line j (!i-j) in
390: Hashtbl.add control.rejects fn ();
391: raise Next
392:
393: | _ -> failwith ("Unknown keyword " ^keyword^ " in control file")
394:
395: with Next -> aux()
396: with End_of_file -> ()
397: in
398: aux ();
399: close_in f
400: ;;
401: parse_control_file control.control_filename
402: ;;
403:
404: iter
405: (fun s -> glob s false 0)
406: control.root_includes
407: ;;
408:
409: iter
410: (fun s -> glob s true 0)
411: control.root_rec_includes
412: ;;
413:
414: let autocreate x =
415: try open_out x
416: with | _ ->
417: let rec mkpath x =
418: let d = Filename.dirname x in
419: if d <> "" then begin
420: try Unix.mkdir d 0o777
421: with _ ->
422: mkpath d;
423: try Unix.mkdir d 0o777
424: with _ -> failwith ("[autocreate] Can't create (p=0777) directory " ^ d)
425: end
426: in
427: mkpath x;
428: force_open_out "autocreate" x
429:
430: ;;
431:
432: let f = autocreate control.prein_filename in
433: StringSet.iter
434: (fun s ->
435: output_string f ("#include \"" ^ s ^ "\"\n")
436: )
437: control.raw_includes
438: ;
439: close_out f
440: ;;
441:
442: let precmd =
443: let path = ref "" in
444: (*
445: StringSet.iter
446: (fun s -> path := !path ^ "-I" ^ s ^ " ")
447: control.raw_include_dirs
448: ;
449: *)
450: path :=
451: (
452: String.concat " "
453: (
454: map
455: (fun s-> "-I"^s^" ")
456: control.include_path
457: )
458: ) ^ " " ^ !path
459: ;
460:
461: control.preprocessor ^ " " ^
462: !path ^ " " ^
463: control.prein_filename ^
464: " >" ^control.preout_filename
465: ;;
466:
467: print_endline "PREPROCESSOR COMMAND:";
468: print_endline precmd
469: ;;
470:
471: Unix.system precmd
472: ;;
473:
474: let format_time tm =
475: si (tm.Unix.tm_year + 1900) ^ "/" ^
476: si (tm.Unix.tm_mon + 1) ^ "/" ^
477: si tm.Unix.tm_mday ^ " " ^
478: si tm.Unix.tm_hour ^ ":" ^
479: si tm.Unix.tm_min ^ ":" ^
480: si tm.Unix.tm_sec
481: ;;
482:
483: let compile_start = Unix.time ()
484: let compile_start_gm = Unix.gmtime compile_start
485: let compile_start_local = Unix.localtime compile_start
486: let compile_start_gm_string = format_time compile_start_gm ^ " UTC"
487: let compile_start_local_string = format_time compile_start_local ^ " (local)"
488: ;;
489:
490: Flx_cil_cil.initCIL()
491: ;;
492:
493: let lexbuf = Flx_cil_clexer.init control.preout_filename control.language;;
494: let cabs = Flx_cil_cparser.file Flx_cil_clexer.initial lexbuf
495: ;;
496: Flx_cil_clexer.finish()
497: ;;
498:
499: (*
500: Flx_cil_cprint.print_defs cabs;;
501: *)
502:
503: let ns (s,_,_,_) = s
504: ;;
505: let is_def = function | Some _ -> "complete" | None -> "incomplete"
506: ;;
507: let type_of_se = function
508: | SpecType ts ->
509: begin match ts with
510: | Tnamed s -> print_endline ("type " ^ s)
511: | Tstruct (s,fglo,_) ->
512: print_endline ("struct " ^ s ^ " " ^ is_def fglo)
513: | Tunion (s,fglo,_) ->
514: print_endline ("union " ^ s ^ " " ^ is_def fglo)
515: | Tenum (s,fglo,_) ->
516: print_endline ("enum " ^ s ^ " " ^ is_def fglo)
517: | _ -> ()
518: end
519: | _ -> ()
520:
521: let types_in sp = List.iter type_of_se sp
522: ;;
523:
524: let cil = Flx_cil_cabs2cil.convFile (control.preout_filename, cabs)
525: ;;
526:
527:
528: (*
529: dumpFile defaultCilPrinter stdout cil ;;
530: *)
531:
532: let {fileName=f; globals=gs} = cil
533: ;;
534:
535: (* files not corresponding to a module *)
536: let excludes : string list ref = ref
537: [
538: ]
539: ;;
540:
541: let rpltname s =
542: try Hashtbl.find control.replacements s
543: with Not_found -> s
544:
545: let rplname s =
546: try Hashtbl.find control.nontype_replacements s
547: with Not_found ->
548: try Hashtbl.find control.replacements s
549: with Not_found -> s
550:
551: let soi = function
552: | IBool -> "bool"
553: | IChar -> "char"
554: | ISChar -> "tiny"
555: | IUChar -> "utiny"
556: | IInt -> "int"
557: | IUInt -> "uint"
558: | IShort -> "short"
559: | IUShort -> "ushort"
560: | ILong -> "long"
561: | IULong -> "ulong"
562: | ILongLong -> "vlong"
563: | IULongLong -> "uvlong"
564:
565: let sof = function
566: | FFloat -> "float"
567: | FDouble -> "double"
568: | FLongDouble -> "ldouble"
569:
570: | IFloat -> "imaginary"
571: | IDouble -> "dimaginary"
572: | ILongDouble -> "limaginary"
573:
574: | CFloat -> "complex"
575: | CDouble -> "dcomplex"
576: | CLongDouble -> "lcomplex"
577:
578: let cvqual a =
579: let const = ref false
580: and volatile = ref false
581: in
582: List.iter
583: (fun (Attr (s,_)) ->
584: if s = "const" then const := true
585: else if s = "volatile" then volatile := true
586: )
587: a
588: ;
589: if !const && !volatile then "cv"
590: else if !const then "c"
591: else if !volatile then "v"
592: else ""
593:
594: let attrof = function
595: | TVoid a
596: | TInt (_,a)
597: | TFloat (_,a)
598: | TPtr (_,a)
599: | TArray (_,_,a)
600: | TFun (_,_,_,a)
601: | TNamed (_,a)
602: | TComp (_,a)
603: | TEnum (_,a)
604: | TBuiltin_va_list a
605: -> a
606:
607: let strexp n = "0" (* cheat *)
608: ;;
609:
610: let remove_pnames t = match t with
611: | TPtr (TFun (t,Some ps,b,a),a') ->
612: let ps = map (fun (_,t,a)->"",t,a) ps in
613: TPtr (TFun (t,Some ps,b,a),a')
614: | _ -> t
615:
616: (* strip multiple spaces and newlines out *)
617: let reformatc s =
618: let s' = ref "" in
619: let n = String.length s in
620: for i=0 to n - 1 do
621: let
622: ch = s.[i] and
623: ch2 = if i < n-2 then s.[i+1] else '\000'
624: in
625: if
626: ch = ' ' &&
627: (ch2=' ' ||ch2=',' || ch2=';' || ch2=')' || ch2='\n')
628: then ()
629: else if ch='\n' then s' := !s' ^ " "
630: else s' := !s' ^ String.make 1 ch
631: done;
632: let n = ref (String.length !s' - 1) in
633: while !n >= 0 && !s'.[!n]=' ' do decr n done;
634: String.sub !s' 0 (!n+1)
635:
636: let choose_alias stab s =
637: let ss = ref [] in
638: begin try
639: let s' = Hashtbl.find stab.aliases s in
640: ss := s' :: !ss
641: with Not_found -> ()
642: end
643: ;
644:
645: begin try
646: let s' = Hashtbl.find stab.struct_aliases s in
647: ss := s' :: !ss
648: with Not_found -> ()
649: end
650: ;
651:
652: (* just pick the shortest name *)
653: let s = s :: !ss in
654: let s = map (fun x -> String.length x,x) s in
655: let s = sort compare s in
656: let _,p = hd s in
657: p
658:
659: let prefered_alias stab s = choose_alias stab s
660:
661:
662: let rec sot stab t = match t with
663: | TVoid a -> "void_t"
664: | TInt (ik,a) -> soi ik
665: | TFloat (fk,a) -> sof fk
666: | TPtr (TVoid a',a) -> (cvqual a')^"address"
667: | TPtr (TFun _,a) ->
668: let t' = typeSig t in
669: begin try
670: fst (Hashtbl.find stab.registry t')
671: with
672: Not_found ->
673: let name = stab.stab_module ^"_cft_" ^ si !(stab.counter) in
674: incr stab.counter;
675: let sr = locUnknown in
676: let t = remove_pnames t in
677: let si = {tname=name;ttype=t;treferenced=true } in
678: let gt = GType (si,sr) in
679: let d = defaultCilPrinter#pGlobal () gt in
680: let s = Flx_cil_pretty.sprint 65 d in
681: let s = reformatc s in
682: Hashtbl.add stab.registry t' (name,s);
683: name
684: end
685:
686: | TPtr (t',a) -> cvqual (attrof t') ^ "ptr[" ^ sot stab t'^ "]"
687: | TArray (t',Some n,a)->
688: cvqual (attrof t') ^ "ptr[" ^ sot stab t'^ "]"
689:
690: | TArray (t',None,a)->
691: cvqual (attrof t') ^ "ptr[" ^ sot stab t' ^ "]"
692:
693: | TFun (t',Some ps,false,a) ->
694: let ret = sot stab t'
695: and args =
696: if length ps = 0 then "1"
697: else String.concat " * " (List.map (soa stab) ps)
698: in args ^ " -> " ^ ret
699:
700: | TFun (t',None,false,a) ->
701: let ret = sot stab t'
702: and args = "1"
703: in args ^ " -> " ^ ret
704:
705: | TFun (t',_,_,a) -> "CANT HANDLE THIS FUN"
706:
707: | TNamed (ti,a) ->
708: let name = ptname ti in
709: let name = prefered_alias stab name in
710: Hashtbl.add stab.used_types name ();
711: rpltname name
712:
713: | TComp (ci,a) ->
714: let name = pci ci in
715: let name = prefered_alias stab name in
716: Hashtbl.add stab.used_types name ();
717: rpltname name
718:
719: | TEnum (ei,a) -> "int"
720: | TBuiltin_va_list a -> "__builtin_va_list"
721:
722: and ptname {tname=tname} = tname
723: and ciname {cname=cname} = cname
724: and einame {ename=ename} = ename
725: and viname {vname=vname} = vname
726:
727: and pci ci = match ci with
728: {cname=cname; cstruct=cstruct} ->
729: (if cstruct then "_struct_" else "_union_") ^ cname
730:
731: and pcci ci = match ci with
732: {cname=cname; cstruct=cstruct} ->
733: (if cstruct then "struct " else " union ") ^ cname
734:
735: and pei ei = match ei with
736: {ename=ename} -> "_enum_" ^ ename
737:
738: and pcei ei = match ei with
739: {ename=ename} -> "enum " ^ ename
740:
741: and ptdef registry ti:string = match ti with
742: {ttype=tt} -> sot registry tt
743:
744: and pcomp pi = match pi with
745: {cname=name} -> name
746:
747: and soa stab (name,t,a) = sot stab t
748:
749: and sov registry vi = match vi with
750: {vname=vname; vtype=vtype} ->
751: "const " ^ vname ^ ": " ^ sot registry vtype
752:
753: let pe x = print_endline x
754: ;;
755:
756: let achk x =
757: let a = "__anon" in
758: let n = String.length a in
759: String.length x > n &&
760: a = String.sub x 0 n
761:
762: let isanon = function
763: | GType ({tname=tname},_) -> achk tname
764: | GCompTag ({cname=cname},_) -> achk cname
765: | GCompTagDecl ({cname=cname},_) -> achk cname
766: | GEnumTag ({ename=ename},_) -> achk ename
767: | GEnumTagDecl ({ename=ename},_) -> achk ename
768: | GVarDecl ({vname=vname},_) -> false
769: | GVar ({vname=vname},_,_) -> false
770: | GFun (fd,sr) -> false
771: | GAsm _ -> true
772: | GPragma _ -> true
773: | GText _ -> true
774:
775: (* pure name *)
776: let flx_name' = function
777: | GType ({tname=tname},_) -> Some tname
778: | GCompTag (ci,sr) -> Some (pci ci)
779: | GCompTagDecl (ci,_) -> Some (pci ci)
780: | GEnumTag ({ename=ename},_) -> Some ename
781: | GEnumTagDecl ({ename=ename},_) -> Some ename
782: | GVarDecl ({vname=vname},_) -> Some vname
783: | GVar ({vname=vname},_,_) -> Some vname
784: | GFun ({svar={vname=vname}},sr) -> Some vname
785: | GAsm _ -> None
786: | GPragma _ -> None
787: | GText _ -> None
788:
789: (* name with replacement *)
790: let flx_name x = match flx_name' x with
791: | Some x -> Some (rplname x)
792: | None -> None
793:
794: (* type name with replacement *)
795: let flx_tname x = match flx_name' x with
796: | Some x -> rpltname x
797: | None -> "error!!"
798:
799: let c_name = function
800: | GType ({tname=tname},_) -> Some tname
801: | GCompTag (ci,sr) -> Some (pcci ci)
802: | GCompTagDecl (ci,_) -> Some (pcci ci)
803: | GEnumTag (ei,_) -> Some "int"
804: | GEnumTagDecl (ei,_) -> Some "int"
805: | GVarDecl ({vname=vname},_) -> Some vname
806: | GVar ({vname=vname},_,_) -> Some vname
807: | GFun ({svar={vname=vname}},sr) -> Some vname
808: | GAsm _ -> None
809: | GPragma _ -> None
810: | GText _ -> None
811: ;;
812:
813: let rec isanont t = match t with
814: | TVoid _
815: | TInt _
816: | TFloat _ -> false
817: | TPtr (t,_) -> isanont t
818: | TArray (t,_,_) -> isanont t
819: | TFun (t,Some ps,_,_) ->
820: fold_left (fun b (_,t,_)-> b || isanont t ) (isanont t) ps
821:
822: | TFun (t,None,_,_) -> isanont t
823: | TNamed ({tname=tname},_) -> achk tname
824: | TComp ({cname=cname},_) -> achk cname
825: | TEnum _ -> false
826: | TBuiltin_va_list _ -> false
827:
828: (* got to be a named non function type *)
829: let is_cstruct_field t = match t with
830: | TVoid _
831: | TInt _
832: | TFloat _
833: | TNamed _
834: | TPtr _
835: | TArray _
836: | TComp _
837: | TEnum _
838: -> true
839:
840: | TFun _
841: | TBuiltin_va_list _
842: -> false
843:
844: let ispublic s =
845: String.length s < 2 || String.sub s 0 2 <> "__"
846:
847: let can_gen_ctype cstruct cfields = cstruct &&
848: fold_left
849: (fun t {fname=fname; ftype=ftype} ->
850: t && not (isanont ftype) && ispublic fname &&
851: is_cstruct_field ftype
852: )
853: true cfields
854:
855: let chop_extension f =
856: let b = Filename.basename f in
857: let d = Filename.dirname f in
858: let b = try Filename.chop_extension b with _ -> b in
859: if d = "." then b else Filename.concat d b
860:
861: let replace_prefix x ls =
862: let x = ref x in
863: iter
864: (fun (a,b) ->
865: if isprefix a !x then
866: let n = String.length a in
867: let m = String.length !x in
868: x := b ^ String.sub !x n (m-n)
869: )
870: ls
871: ;
872: !x
873: let map_filename f =
874: let f = replace_prefix f control.merge_files in
875: f
876:
877: let flxinclude_of_cfile cfilename =
878: let x = map_filename cfilename in
879: let x = replace_prefix x control.repl_prefix in
880: let x = chop_extension x ^ "_lib" in
881: let x = if isprefix "/" x then String.sub x 1 (String.length x - 1) else x in
882: let x = if isprefix "." x then String.sub x 1 (String.length x - 1) else x in
883: x
884:
885: let flxfile_of_cfile cfilename =
886: let base = flxinclude_of_cfile cfilename in
887: Filename.concat (control.outdir) (base ^ ".flx")
888:
889: let srepl s c1 c2 =
890: for i = 0 to String.length s - 1 do
891: if s.[i]=c1 then s.[i] <- c2
892: done
893: ;;
894:
895: let module_of_cfilename s =
896: let module_of_filename fname =
897: let x = String.copy fname in
898: let fixup x =
899: srepl x '.' '_';
900: srepl x ' ' '_';
901: srepl x '/' '_';
902: srepl x '-' '_';
903: srepl x '+' '_';
904: srepl x ':' '_';
905: in
906: let mname =
907: try
908: let x = (chop_extension x) in
909: let x =
910: let m = String.length x in
911: if m>0 && x.[0] = '/' then String.sub x 1 (m-1) else x
912: in
913: fixup x;
914: x ^ "_h"
915: with Invalid_argument _ ->
916: print_endline ("Weird (C++??) filename " ^ fname ^ " without extension");
917: fixup x;
918: x
919: in rplname mname (* apply user renaming to modules too *)
920: in
921: let s = map_filename s in
922: let s = replace_prefix s control.repl_prefix in
923: module_of_filename s
924:
925: ;;
926:
927: let mk_stab cfile =
928: {
929: stab_cfile = cfile;
930: stab_flxfile = flxfile_of_cfile cfile;
931: stab_flxinclude = flxinclude_of_cfile cfile;
932: stab_module = module_of_cfilename cfile;
933:
934: aliases= Hashtbl.create 97;
935: struct_aliases= Hashtbl.create 97;
936: abstract_types= Hashtbl.create 97;
937: incomplete_types= Hashtbl.create 97;
938: used_types= Hashtbl.create 97;
939: variables= Hashtbl.create 97;
940: functions= Hashtbl.create 97;
941: fields= Hashtbl.create 97;
942: cstructs = Hashtbl.create 97;
943: procedures= Hashtbl.create 97;
944: callback_types = Hashtbl.create 97;
945: callback_clients = Hashtbl.create 97;
946: enums= Hashtbl.create 97;
947: registry= Hashtbl.create 97;
948: includes = StringSet.empty;
949: xtyps = Hashtbl.create 97;
950: ict = Hashtbl.create 97;
951: udt = Hashtbl.create 97;
952: counter = ref 1
953: }
954: ;;
955:
956: let getstab s =
957: let lfn = map_filename s in
958: try Hashtbl.find control.stabs lfn
959: with Not_found ->
960: let x = mk_stab s in
961: Hashtbl.add control.stabs lfn x;
962: x
963:
964: let getreg {file=s} = getstab s
965:
966: let oplist = [
967: "+","add";
968: "-","sub";
969: "*","mul";
970: "/","div";
971: "%","mod";
972:
973: "<","lt";
974: ">","gt";
975: "<=","le";
976: ">=","ge";
977: "==","eq";
978: "!=","ne";
979:
980: "=","_set";
981:
982: "||","lor";
983: "&&","land";
984: "!","lnot";
985:
986: "^","bxor";
987: "|","bor";
988: "&","band";
989: "~","compl";
990:
991: "+=","pluseq";
992: "-=","minuseq";
993: "*=","muleq";
994: "/=","diveq";
995: "%=","modeq";
996: "^=","careteq";
997: "|=","vbareq";
998: "&=","ampereq";
999: "~=","tildeeq";
1000: "<<=","leftshifteq";
1001: ">>=","rightshifteq";
1002:
1003: "++","incr";
1004: "--","decr";
1005: "[]","subscript";
1006: ]
1007: ;;
1008: let operators = Hashtbl.create 97
1009: ;;
1010: List.iter
1011: (fun (k,v)-> Hashtbl.add operators ("operator"^k) v)
1012: oplist
1013: ;;
1014:
1015: let fixsym k =
1016: try (* hackery .. won't work with qualified names *)
1017: Hashtbl.find operators k
1018: with Not_found ->
1019: let k = String.copy k in
1020: srepl k ':' '_';
1021: k
1022:
1023: let rpl {file=s} which =
1024: let stab = getstab s in
1025: match which with
1026: | `aliases (k,v) ->
1027: let k = fixsym k in
1028: Hashtbl.replace stab.aliases k v;
1029: Hashtbl.replace control.all_types k s
1030:
1031: | `struct_aliases(k,v) ->
1032: let k = fixsym k in
1033: Hashtbl.replace stab.struct_aliases k v;
1034: Hashtbl.replace control.all_types k s
1035:
1036: | `abstract_types (k,v) ->
1037: let k = fixsym k in
1038: Hashtbl.replace stab.abstract_types k v;
1039: Hashtbl.replace control.all_types k s
1040:
1041: | `incomplete_types (k,v) ->
1042: let k = fixsym k in
1043: Hashtbl.replace stab.incomplete_types k v
1044:
1045: | `variables(k,v) ->
1046: let k = fixsym k in
1047: Hashtbl.replace stab.variables k v
1048:
1049: | `functions((k,ts,cv),v) ->
1050: let k = fixsym k in
1051: Hashtbl.replace stab.functions (k,ts,cv) v
1052:
1053: | `fields(k,v) ->
1054: let k = fixsym k in
1055: Hashtbl.replace stab.fields k v
1056:
1057: | `cstruct (k,v) ->
1058: let k = fixsym k in
1059: Hashtbl.replace control.all_types k k;
1060: Hashtbl.replace stab.cstructs k v
1061:
1062: | `procedures((k,ts,cv),v) ->
1063: let k = fixsym k in
1064: Hashtbl.replace stab.procedures (k,ts,cv) v
1065:
1066: | `enums(k,v) ->
1067: let k = fixsym k in
1068: Hashtbl.replace stab.enums k v
1069:
1070: | `callback_type (s,(t,i)) ->
1071: Hashtbl.replace stab.callback_types s (t,i)
1072:
1073: | `callback_client (s,(t,cbt,i,j)) ->
1074: Hashtbl.replace stab.callback_clients s (t,cbt,i,j)
1075:
1076: ;;
1077:
1078: let add_file fname =
1079: control.files <- StringSet.add fname control.files
1080: ;;
1081:
1082: let add_loc {file=fname} =
1083: add_file fname
1084: ;;
1085:
1086: (* find all the void* in an argument list *)
1087: let find_voidps ps =
1088: let voids = ref [] in
1089: let i = ref 0 in
1090: List.iter
1091: (fun (_,t,_) ->
1092: (match unrollType t with
1093: | TPtr (TVoid _,[]) -> voids := !i :: !voids
1094: | _ -> ()
1095: );
1096: incr i
1097: )
1098: ps
1099: ;
1100: !voids
1101:
1102: (* check if a function pointer is a callback, by
1103: seeing if it contains exactly one void * argument
1104: *)
1105: let is_callbackp t =
1106: match t with
1107: | TPtr (TFun (_,Some ps,false,_),_) ->
1108: List.length (find_voidps ps) = 1
1109: | _ -> false
1110:
1111: (* Find all the arguments which are callbacks *)
1112: let find_callbackps ps =
1113: let callbacks = ref [] in
1114: let i = ref 0 in
1115: List.iter
1116: (fun (_,t,_) ->
1117: if is_callbackp t
1118: then callbacks := !i :: !callbacks
1119: ;
1120: incr i
1121: )
1122: ps
1123: ;
1124: !callbacks
1125:
1126: (* get the indices in an argument list of the callback
1127: and client data pointer, and the index of the client
1128: data pointer in the callback type as well, return None
1129: if they can't be uniquely identified
1130: *)
1131:
1132: let get_callback_data ps =
1133: let callbacks = find_callbackps ps in
1134: let voids = find_voidps ps in
1135: match callbacks, voids with
1136: | [cbc_i], [cbc_adri] ->
1137: begin match List.nth ps cbc_i with
1138: | _,TPtr (TFun (_,Some ps,false,_),_),_ ->
1139: begin match find_voidps ps with
1140: | [cbi] -> Some (cbc_i,cbc_adri,cbi)
1141: | _ -> assert false
1142: end
1143: | _ -> assert false
1144: end
1145: | _ -> None
1146:
1147: let check_callback t = match t with
1148: | TFun (_,Some ps,false,_) ->
1149: begin match get_callback_data ps with
1150: | Some (cbc_i, cbc_adri,cbi) ->
1151: let _,cbt,_ = List.nth ps cbc_i in
1152: Some (cbc_i, cbc_adri,cbi, cbt)
1153: | None -> None
1154: end
1155: | TFun _ -> None
1156: | _ -> failwith "Check for callbacks in non-function"
1157:
1158: let handle_callback_maybe ft registry key key' fname loc =
1159: match check_callback ft with
1160: | None -> ()
1161: | Some (cbc_i, cbc_adri, cbi, cbt) ->
1162: (*
1163: print_endline
1164: (
1165: "Found callback client " ^ fname ^
1166: "\n callback index = " ^ string_of_int cbc_i ^
1167: "\n client data index = " ^ string_of_int cbc_adri ^
1168: "\n callback type = " ^ sot registry cbt ^
1169: "\n callback type client data index = " ^ string_of_int cbi
1170: )
1171: ;
1172: *)
1173: let s = sot registry cbt in
1174: rpl loc (`callback_type (s,(cbt,cbi)));
1175: rpl loc (`callback_client (fname,(ft,s,cbc_i,cbc_adri)))
1176:
1177: let ptr key a =
1178: cvqual a ^ "ptr[" ^ key ^ "]"
1179:
1180: let handle_global_fun ft registry key key' fname loc =
1181: handle_callback_maybe ft registry key key' fname loc;
1182: match ft with
1183: | TFun (TVoid _,Some ps,false,a) ->
1184: let tsig = map (fun (_,t,a) -> typeSig t) ps in
1185: let args =
1186: if length ps = 0 then "1"
1187: else String.concat " * " (List.map (soa registry) ps)
1188: in
1189: let cv = cvqual a in
1190: let ct = if key = key' then "" else key'^"($a);" in
1191: rpl loc (`procedures ((key,tsig,cv), (args,ct)))
1192:
1193: | TFun (TVoid _,None,false,a) ->
1194: let args = "1" in
1195: let cv = cvqual a in
1196: rpl loc (`procedures ((key,[],cv), (args,key'^"();")))
1197:
1198: | TFun (TVoid _,Some _,true,a) ->
1199: let cv = cvqual a in
1200: let ct = if key = key' then "" else key'^"($a);" in
1201: rpl loc (`procedures ((key^"[t]",[],cv), ("t",ct)))
1202:
1203: | TFun (ret,Some ps,false,a) ->
1204: let ftb =
1205: let ret = sot (getreg loc) ret
1206: and args = List.map (soa registry) ps
1207: and ct = if key = key' then "" else key'^"($a)"
1208: in
1209: (
1210: (
1211: if length ps = 0
1212: then "1"
1213: else String.concat " * " args
1214: )
1215: ^
1216: " -> " ^ ret,ct
1217: )
1218: in
1219: let tsig = map (fun (_,t,a) -> typeSig t) ps in
1220: let cv = cvqual a in
1221: rpl loc (`functions ((key,tsig,cv), ftb))
1222:
1223: | TFun (ret,None,false,a) ->
1224: let ret = sot (getreg loc) ret in
1225: let ftb = "1 -> " ^ ret,key'^"()" in
1226: let cv = cvqual a in
1227: rpl loc (`functions ((key,[],cv), ftb))
1228:
1229: | TFun (ret,Some _,true,a) ->
1230: let ftb =
1231: let ret = sot (getreg loc) ret in
1232: "t -> " ^ ret,key'^"($a)"
1233: in
1234: let cv = cvqual a in
1235: rpl loc (`functions ((key^"[t]",[],cv), ftb))
1236:
1237: | _ -> assert false
1238:
1239: let handle_method ft registry key fname loc =
1240: match ft with
1241: (* procedures *)
1242: | (TVoid _,Some ps,false,a) ->
1243: let key = ptr (fixsym key) a in
1244: let args =
1245: if length ps = 0 then key
1246: else String.concat " * " (key :: (List.map (soa registry) ps))
1247: in
1248: let tsig = map (fun (_,t,a) -> typeSig t) ps in
1249: let cv = cvqual a in
1250: rpl loc (`procedures ((fname,tsig,cv), (args,"$1->"^fname^"($b);")))
1251:
1252: (* no type arg = void *)
1253: | (TVoid _,None,false,a) ->
1254: let key = ptr key a in
1255: let args = key in
1256: let cv = cvqual a in
1257: rpl loc (`procedures ((fname,[],cv), (args,"$1->"^fname^"();")))
1258:
1259: (* variadic *)
1260: | (TVoid _,Some t,true,a) ->
1261: let key = ptr key a in
1262: let cv = cvqual a in
1263: rpl loc (`procedures ((fname^"[t]",[],cv), ("t","$1->"^fname^"($b);")))
1264:
1265: (* functions *)
1266: | (ret,Some ps,false,a) ->
1267: let key = ptr key a in
1268: let ftb =
1269: let ret = sot (getreg loc) ret
1270: and args = List.map (soa registry) ps
1271: in
1272: (
1273: (
1274: if length ps = 0
1275: then key
1276: else String.concat " * " (key :: args)
1277: )
1278: ^
1279: " -> " ^ ret,"$1->"^fname^"($a)"
1280: )
1281: in
1282: let tsig = map (fun (_,t,a) -> typeSig t) ps in
1283: let cv = cvqual a in
1284: rpl loc (`functions ((fname,tsig,cv), ftb))
1285:
1286: (* no type arg = void *)
1287: | (ret,None,false,a) ->
1288: let key = ptr key a in
1289: let ret = sot (getreg loc) ret in
1290: let ftb = key ^ " -> " ^ ret,"$1->"^fname^"()" in
1291: let cv = cvqual a in
1292: rpl loc (`functions ((fname,[],cv), ftb))
1293:
1294: (* variadic *)
1295: | (ret,Some _,true,a) ->
1296: let key = ptr key a in
1297: let ftb =
1298: let ret = sot (getreg loc) ret in
1299: "t -> " ^ ret,"$1->"^fname^"($b)"
1300: in
1301: let cv = cvqual a in
1302: rpl loc (`functions ((fname^"[t]",[],cv), ftb))
1303:
1304: (* can't be both variadic and have no arguments *)
1305: | (_,None,true,_) -> assert false
1306:
1307: let handle_field registry key fname ftype loc =
1308: match ftype with
1309: | TFun (a,b,c,d) -> handle_method (a,b,c,d) registry key fname loc
1310:
1311: | _ ->
1312: let t = key ^ " -> " ^ sot registry ftype in
1313: rpl loc (`fields (("get_"^fname), (t,"$1->"^fname)))
1314:
1315: let gen_cstruct registry loc key cname cfields =
1316: let flds = ref [] in
1317: iter
1318: (fun {fname=fname; ftype=ftype} ->
1319: let t = sot registry ftype in
1320: flds := (rplname fname,t) :: !flds
1321: )
1322: cfields
1323: ;
1324: let flds = rev !flds in
1325: rpl loc (`cstruct (cname, flds));
1326: if key <> cname then
1327: rpl loc (`aliases (key, cname))
1328:
1329: let handle_global g = let loc = get_globalLoc g in
1330: add_loc loc;
1331: let type_name = flx_tname g in
1332: match isanon g,flx_name g,flx_name' g with
1333: | _,None,_
1334: | true,_,_ ->
1335: begin match g with
1336:
1337: (* enum { .. }; *)
1338: | GEnumTag (ei,_) ->
1339: begin match ei with { eitems=eitems } ->
1340: iter
1341: (fun (s,_,_) ->
1342: if ispublic s then rpl loc (`enums (rplname s,s))
1343: )
1344: eitems
1345: end
1346: | _ -> ()
1347: end
1348:
1349: | _,Some _,None -> assert false
1350: | false,Some key,Some key' ->
1351: if not (Hashtbl.mem control.rejects key) then
1352: match g with
1353: | GType (ti,loc) ->
1354: let registry = getreg loc in
1355: begin
1356: match ti with {ttype=ttype} ->
1357: match ttype with
1358: | TComp (ci,_) ->
1359: let anon= achk (ciname ci) in
1360: (*
1361: begin match ci with { cname=cname; cfields=cfields } ->
1362: iter
1363: (fun {fname=fname; ftype=ftype} ->
1364: if not (isanont ftype) && ispublic fname then
1365: handle_field registry key fname ftype loc
1366: )
1367: cfields
1368: end
1369: ;
1370: *)
1371: if anon then
1372: rpl loc (`abstract_types (type_name, key'))
1373: else
1374: let v = ptdef registry ti in
1375: rpl loc (`struct_aliases (type_name, v))
1376:
1377: | TEnum (ei,_) ->
1378: begin match ei with { eitems=eitems } ->
1379: iter
1380: (fun (s,_,_) -> if ispublic s then rpl loc (`enums (rplname s,s)))
1381: eitems
1382: end
1383: ;
1384: if achk (einame ei) then
1385: rpl loc (`abstract_types (type_name, key'))
1386: else
1387: rpl loc (`aliases (type_name, (ptdef registry ti)))
1388:
1389: | TFun (_,_,true,_) ->
1390: (* HACK: varargs function typedef *)
1391: rpl loc (`abstract_types (type_name, key'))
1392:
1393: | t ->
1394: if isanont t then
1395: rpl loc (`abstract_types (type_name, key'))
1396: else
1397: let v = ptdef registry ti in
1398: rpl loc (`aliases (type_name, v))
1399: end
1400:
1401: | GCompTag (ci,loc) ->
1402: let registry = getreg loc in
1403: begin match ci with {
1404: cname=cname;
1405: cfields=cfields;
1406: cstruct=cstruct
1407: } ->
1408: if can_gen_ctype cstruct cfields then
1409: gen_cstruct registry loc type_name cname cfields
1410: else begin
1411: rpl loc (`abstract_types (type_name, (pcci ci)));
1412: iter
1413: (fun {fname=fname; ftype=ftype} ->
1414: if not (isanont ftype) && ispublic fname then
1415: handle_field registry type_name fname ftype loc
1416: )
1417: cfields
1418: end
1419: end
1420:
1421:
1422: | GCompTagDecl (ci,loc) ->
1423: rpl loc (`incomplete_types (type_name, (pcci ci)))
1424:
1425: | GEnumTag (ei,loc) ->
1426: rpl loc (`aliases (type_name, "int"));
1427: begin match ei with { eitems=eitems } ->
1428: iter
1429: (fun (s,_,_) -> if ispublic s then rpl loc (`enums (rplname s,s)))
1430: eitems
1431: end
1432:
1433: | GEnumTagDecl (ci,loc) -> rpl loc (`aliases (type_name, "int"))
1434:
1435: | GVar (vi,_,loc)
1436: | GFun ({svar=vi},loc)
1437: | GVarDecl (vi,loc) ->
1438: let registry = getreg loc in
1439: let vname, vtype=
1440: match vi with {vname=vname; vtype=vtype}->vname,vtype
1441: in
1442: if ispublic vname then
1443: begin match vtype with
1444: | TFun _ -> handle_global_fun vtype registry key key' vname loc
1445: | _ ->
1446: rpl loc (`variables (key, (sot (getreg loc) vtype)))
1447: end
1448:
1449: | GAsm _ -> print_endline "GASM"
1450: | GPragma _ -> print_endline "PRAGMA"
1451: | GText _ -> print_endline "TEXT"
1452: ;;
1453:
1454: List.iter handle_global gs
1455: ;;
1456:
1457: let is_nonempty h =
1458: try
1459: Hashtbl.iter (fun _ -> raise Not_found) h;
1460: false
1461: with Not_found -> true
1462: ;;
1463:
1464: exception Found of string
1465:
1466: let pathname_of f =
1467: try
1468: iter
1469: (fun s ->
1470: let x = Filename.concat s f in
1471: if Sys.file_exists x then raise (Found x)
1472: )
1473: control.include_path;
1474: raise Not_found
1475: with Found s -> s
1476: ;;
1477:
1478: let rec find_includes' includes fname =
1479: if not (StringSet.mem fname !includes) then
1480: let f = force_open_in "find_includes'" fname in
1481: includes := StringSet.add fname !includes;
1482: begin try
1483: let rec aux () =
1484: let line = input_line f in
1485: let n = String.length line in
1486: let i = ref 0 in
1487:
1488: try
1489: (* skip white *)
1490: while !i < n && line.[!i]=' ' do incr i done;
1491: if !i = n then raise Next;
1492:
1493: (* check # *)
1494: if line.[!i]<>'#' then raise Next;
1495: incr i;
1496:
1497: (* skip white *)
1498: while !i < n && line.[!i]=' ' do incr i done;
1499: if !i = n then raise Next;
1500:
1501: (* check include *)
1502: if !i+String.length "include" > n then raise Next;
1503: let li = String.length "include" in
1504: if (String.sub line !i li) <> "include" then raise Next;
1505: i := !i + li;
1506:
1507: (* skip white *)
1508: while !i < n && line.[!i]=' ' do incr i done;
1509:
1510: (* check < or '"' *)
1511: if line.[!i]<>'"' && line.[!i]<>'<' then raise Next;
1512: incr i;
1513:
1514: (* skip to > or '"' *)
1515: let j = !i in
1516: while !i < n && line.[!i]<>'>' && line.[!i]<>'"' do incr i done;
1517:
1518: (* extract filename *)
1519: let filename = String.sub line j (!i-j) in
1520:
1521:
1522: (* lookup full path name *)
1523: let filename =
1524: if not (Filename.is_relative filename) then filename else
1525: try pathname_of filename
1526: with Not_found ->
1527: (*
1528: print_endline
1529: (
1530: "[include_file'] Can't resolve " ^ filename ^
1531: " included from " ^ fname
1532: );
1533: *)
1534: raise Next
1535: in
1536: add_file filename;
1537:
1538: (* if not already known, put transitive closure in set *)
1539: if StringSet.mem filename !includes then raise Next;
1540: includes := StringSet.add filename !includes;
1541: find_includes' includes filename;
1542:
1543: (* next line *)
1544: raise Next
1545: with Next -> aux ()
1546: in
1547: aux()
1548: with End_of_file -> close_in f
1549: end
1550: ;;
1551:
1552: let find_includes fname =
1553: let includes = ref StringSet.empty in
1554: find_includes' includes fname;
1555: let extras =
1556: try Hashtbl.find control.rev_merge_files fname
1557: with Not_found -> []
1558: in
1559: iter (find_includes' includes) extras
1560: ;
1561: stringset_map map_filename !includes
1562: ;;
1563:
1564: let global_includes = ref StringSet.empty
1565: ;;
1566:
1567: Hashtbl.iter
1568: begin
1569: fun fname stab ->
1570: let includes = ref (find_includes stab.stab_cfile) in
1571: let ict = Hashtbl.create 97 in
1572: let xtyps = Hashtbl.create 97 in
1573: Hashtbl.iter
1574: (fun k v ->
1575: if not (Hashtbl.mem stab.abstract_types k) then
1576: try
1577: let file = Hashtbl.find control.all_types k in
1578: includes := StringSet.add file !includes;
1579: Hashtbl.add xtyps k file;
1580:
1581: with Not_found ->
1582: Hashtbl.add ict k v;
1583: let v',ms =
1584: try Hashtbl.find control.incomplete_types_cache k
1585: with Not_found -> v,[]
1586: in
1587: if v'<>v then
1588: failwith ("Inconsistent type " ^k^"->"^ v ^ " <> " ^ v')
1589: ;
1590: Hashtbl.replace control.incomplete_types_cache k (v,stab.stab_module::ms)
1591: else
1592: ()
1593: )
1594: stab.incomplete_types
1595: ;
1596:
1597: let udt = Hashtbl.create 97 in
1598: Hashtbl.iter
1599: (fun k v ->
1600: let k = rplname k in
1601: if not (Hashtbl.mem control.rejects k) then
1602: try
1603: let file = Hashtbl.find control.all_types k in
1604: includes := StringSet.add file !includes;
1605: with Not_found ->
1606: if not (Hashtbl.mem control.incomplete_types_cache k) then
1607: Hashtbl.add udt k v
1608: )
1609: stab.used_types
1610: ;
1611: stab.includes <- !includes;
1612: global_includes := StringSet.union !global_includes !includes;
1613: stab.udt <- udt;
1614: stab.ict <- ict;
1615: stab.xtyps <- xtyps
1616: end
1617: control.stabs
1618: ;;
1619:
1620: (* closure for stabs .. *)
1621: StringSet.iter
1622: (fun s -> ignore(getstab s))
1623: !global_includes
1624: ;;
1625:
1626: StringSet.iter
1627: (fun s ->
1628: let filename =
1629: if not (Filename.is_relative s) then s else
1630: try pathname_of s
1631: with Not_found ->
1632: print_endline ( "Can't resolve primary file " ^ s);
1633: print_endline ("in path: ");
1634: iter
1635: (fun s -> print_endline s)
1636: control.include_path
1637: ;
1638: print_endline "Try adding path statement to control file";
1639: failwith ("Filename resolution error")
1640: in
1641: ignore(getstab filename)
1642: )
1643: control.raw_includes
1644: ;;
1645:
1646: let rec find_macros fname =
1647: let macros = ref [] in
1648: begin
1649: try
1650: let f = open_in fname in
1651: begin
1652: try
1653: let rec aux () =
1654: let line = input_line f in
1655: let n = String.length line in
1656: let i = ref 0 in
1657:
1658: try
1659: (* skip white *)
1660: while !i < n && line.[!i]=' ' do incr i done;
1661: if !i = n then raise Next;
1662:
1663: (* check # *)
1664: if line.[!i]<>'#' then raise Next;
1665: incr i;
1666:
1667: (* skip white *)
1668: while !i < n && line.[!i]=' ' do incr i done;
1669: if !i = n then raise Next;
1670:
1671: (* check include *)
1672: let li = String.length "define" in
1673: if !i+li > n then raise Next;
1674: if (String.sub line !i li) <> "define" then raise Next;
1675: i := !i + li;
1676:
1677: (* skip white *)
1678: while !i < n && line.[!i]=' ' do incr i done;
1679: let m = String.sub line !i (n - !i) in
1680: macros := m :: !macros;
1681:
1682: (* next line *)
1683: raise Next
1684: with Next -> aux ()
1685: in
1686: aux()
1687: with End_of_file -> close_in f
1688: end
1689: with _ -> ()
1690: end
1691: ;
1692: !macros
1693: ;;
1694: exception Equal
1695: exception Not_equal
1696: ;;
1697: let fnames = ref [];;
1698: Hashtbl.iter
1699: (fun f _ -> fnames := f :: !fnames)
1700: control.stabs
1701: ;;
1702: let fnames = List.sort compare !fnames
1703: ;;
1704: iter begin
1705: fun fname ->
1706: let stab = Hashtbl.find control.stabs fname in
1707: let outname = stab.stab_flxfile in
1708: let mode, outf =
1709: if Sys.file_exists outname then
1710: `tmp, force_open_out "generate_file" "tmp.tmp"
1711: else
1712: `orig,autocreate outname
1713: in
1714: let pe s = output_string outf (s ^ "\n") in
1715:
1716: pe ("//Module : " ^ stab.stab_module);
1717: pe ("//Timestamp : " ^ compile_start_gm_string);
1718: pe ("//Timestamp : " ^ compile_start_local_string);
1719: pe ("//Raw Header : " ^ fname);
1720: pe ("//Preprocessor : " ^ control.preprocessor);
1721: pe ("//Input file: " ^ control.preout_filename);
1722: pe ("//Flxcc Control : " ^ control.control_filename);
1723: pe ("//Felix Version : " ^ !version_data.version_string);
1724: pe ("include 'std';");
1725: pe "";
1726: let macros = find_macros fname in
1727: iter
1728: (fun s-> pe ("//#define " ^ s))
1729: macros
1730: ;
1731: if not (mem fname control.noincludes) then
1732: pe ("header '#include \"" ^ fname^"\"';")
1733: else
1734: pe ("//NOT INCLUDED: \"" ^ fname^"\"")
1735: ;
1736:
1737:
1738: begin
1739: try
1740: Hashtbl.iter
1741: (fun k v->
1742: match Hashtbl.find control.incomplete_types_cache k with
1743: | (_,[_]) -> ()
1744: | _ ->
1745: pe ("include \"_incomplete_types_cache\";");
1746: raise Not_found
1747: )
1748: stab.ict
1749: with Not_found -> ()
1750: end
1751: ;
1752:
1753:
1754: let include_depends =
1755: let x = stringset_map map_filename stab.includes in
1756: let x = stringset_map flxinclude_of_cfile x in
1757: StringSet.remove stab.stab_flxinclude x
1758: in
1759: let module_depends =
1760: let x = stringset_map map_filename stab.includes in
1761: let x = stringset_map (fun s -> module_of_cfilename s) x in
1762: StringSet.remove stab.stab_module x
1763: in
1764:
1765: if StringSet.cardinal include_depends > 0 then
1766: begin
1767: pe "";
1768: pe "//INCLUDES";
1769: StringSet.iter
1770: (fun incname ->
1771: pe ("include \"" ^ incname^ "\";")
1772: )
1773: include_depends
1774: end
1775: ;
1776:
1777: pe "";
1778: pe ("module " ^ stab.stab_module ^ "\n{");
1779: begin
1780: let pe s = output_string outf (" " ^ s ^ "\n") in
1781: pe "open C_hack;";
1782: if StringSet.cardinal module_depends > 0 then
1783: begin
1784: StringSet.iter
1785: (fun modulename' ->
1786: pe ("open " ^ modulename' ^";")
1787: )
1788: module_depends
1789: end
1790: ;
1791:
1792: if is_nonempty stab.abstract_types then
1793: begin
1794: pe "";
1795: pe "//ABSTRACT TYPES";
1796: Hashtbl.iter
1797: (fun k v->
1798: pe ("type " ^ k ^ " = '" ^ v ^ "';")
1799: )
1800: stab.abstract_types
1801: end
1802: ;
1803:
1804: if is_nonempty stab.cstructs then
1805: begin
1806: pe "";
1807: pe "//CSTRUCTS ";
1808: Hashtbl.iter
1809: (fun k flds ->
1810: pe ("cstruct " ^ k ^ " {");
1811: iter (fun (fld,typ) ->
1812: pe (" " ^ fld ^": " ^ typ^ ";")
1813: )
1814: flds
1815: ;
1816: pe ("}")
1817: )
1818: stab.cstructs
1819: end
1820: ;
1821:
1822: if is_nonempty stab.registry then
1823: begin
1824: pe "";
1825: pe "//C FUNCTION POINTER TYPES";
1826: Hashtbl.iter
1827: (fun _ (name,tdef)->
1828: pe ("header '''" ^ tdef ^ "''';");
1829: pe ("type " ^ name ^ " = '" ^ name ^ "';")
1830: )
1831: stab.registry
1832: end
1833: ;
1834:
1835: if is_nonempty stab.xtyps then
1836: begin
1837: pe "";
1838: pe "//EXTERNALLY COMPLETED TYPES";
1839: Hashtbl.iter
1840: (fun k v->
1841: let m = module_of_cfilename v in
1842: pe ("//type " ^ k ^ " defined in "^m^"='" ^ v ^ "';")
1843: )
1844: stab.xtyps
1845: end
1846: ;
1847:
1848: if is_nonempty stab.ict then
1849: begin
1850: pe "";
1851: pe "//PURE INCOMPLETE TYPES";
1852: Hashtbl.iter
1853: (fun k v->
1854: match Hashtbl.find control.incomplete_types_cache k with
1855: | (_,[_]) ->
1856: pe ("type " ^ k ^ " = '" ^ v ^ "'; //local")
1857: | (_,ls) ->
1858: pe ("typedef " ^ k ^ " = _incomplete_types::" ^ k ^ ";//shared");
1859: iter (fun s->pe ("//shared by: " ^ s)) ls
1860: )
1861: stab.ict
1862: end
1863: ;
1864:
1865: if is_nonempty stab.udt then
1866: begin
1867: pe "";
1868: pe "//TYPES WE CAN'T FIND";
1869: Hashtbl.iter
1870: (fun k _ ->
1871: pe ("//type " ^ k ^ " ??")
1872: )
1873: stab.udt
1874: end
1875: ;
1876:
1877: if is_nonempty stab.struct_aliases then
1878: begin
1879: pe "";
1880: pe "//STRUCT or UNION TAG ALIASES";
1881: Hashtbl.iter
1882: (fun k v->
1883: (* va_list is already defined in the standard library *)
1884: if k <> "va_list" then
1885: (* hack to fiddle typedef X {} X *)
1886: if not (Hashtbl.mem stab.cstructs k) then
1887: pe ("typedef " ^ k ^ " = " ^ v ^ ";")
1888: )
1889: stab.struct_aliases
1890: end
1891: ;
1892:
1893: if is_nonempty stab.aliases then
1894: begin
1895: pe "";
1896: pe "//TYPE ALIASES";
1897: Hashtbl.iter
1898: (fun k v->
1899: (* va_list is already defined in the standard library *)
1900: if k <> "va_list" then
1901: pe ("typedef " ^ k ^ " = " ^ v ^ ";")
1902: )
1903: stab.aliases
1904: end
1905: ;
1906:
1907: if is_nonempty stab.variables then
1908: begin
1909: pe "";
1910: pe "//VARIABLES";
1911: Hashtbl.iter
1912: (fun k v->
1913: pe ("const " ^ k ^ ": " ^v^ " = '" ^ k ^ "';")
1914: )
1915: stab.variables
1916: end
1917: ;
1918:
1919: if is_nonempty stab.enums then
1920: begin
1921: pe "";
1922: pe "//ENUMERATION CONSTANTS";
1923: Hashtbl.iter
1924: (fun k v ->
1925: pe ("const " ^ k ^ ": int = '" ^ v ^ "';")
1926: )
1927: stab.enums
1928: end
1929: ;
1930:
1931: if is_nonempty stab.procedures then
1932: begin
1933: pe "";
1934: pe "//PROCEDURES";
1935: let ps = ref [] in
1936: Hashtbl.iter
1937: (fun (k,_,_) v -> ps := (k,v):: !ps)
1938: stab.procedures
1939: ;
1940: let ps = sort compare !ps in
1941: iter
1942: (fun (k, (v,b)) ->
1943: if b = "" then
1944: pe ("proc " ^ k ^ ": " ^v^ ";")
1945: else
1946: pe ("proc " ^ k ^ ": " ^v^ " = '"^b^"';")
1947: )
1948: ps
1949: end
1950: ;
1951:
1952: if is_nonempty stab.functions then
1953: begin
1954: pe "";
1955: pe "//FUNCTIONS";
1956: let ps = ref [] in
1957: Hashtbl.iter
1958: (fun (k,_,_) v -> ps := (k,v):: !ps)
1959: stab.functions
1960: ;
1961: let ps = sort compare !ps in
1962: iter
1963: (fun (k, (v,b))->
1964: if b = "" then
1965: pe ("fun " ^ k ^ ": " ^v^ ";")
1966: else
1967: pe ("fun " ^ k ^ ": " ^v^ " = '" ^ b ^ "';")
1968: )
1969: ps
1970: end
1971: ;
1972:
1973: if is_nonempty stab.callback_types then
1974: begin
1975: let sot t = sot stab t in
1976: let soa a = soa stab a in
1977: pe "";
1978: pe "//CALLBACK TYPE WRAPPERS";
1979: Hashtbl.iter
1980: (fun tname (t, cbi)->
1981: pe ("//callback type " ^ tname ^ ", client data at " ^ string_of_int cbi);
1982: let ccbt = "_ccbt_" ^ tname in
1983: let fcbt = "_fcbt_" ^ tname in
1984: let fcbat = "_fcbat_" ^ tname in
1985: let fcbw = "_fcbw_" ^ tname in
1986: match t with
1987: | TPtr (TFun (ret,Some ps, false,a),_) ->
1988: (* fix arg names *)
1989: let i = ref 0 in
1990: let ps =
1991: map
1992: (fun (_,t,a) ->
1993: incr i;
1994: let pn = "a"^ string_of_int !i in
1995: pn,t,a
1996: )
1997: ps
1998: in
1999: let t' = TFun (ret,Some ps, false,a) in
2000: (* get the non-client data arguments *)
2001: let ps' = ref [] in
2002: let i = ref 0 in
2003: iter
2004: (fun x -> if cbi = !i then () else ps' := x :: !ps'; incr i)
2005: ps
2006: ;
2007: let ps' = rev !ps' in
2008: (* make a typedef for the felix callback type
2009: mainly as documentation [since the client will
2010: declare a function of this type, the actual
2011: typedef isn't that useful]
2012: *)
2013:
2014: begin match ret with
2015: | TVoid _ ->
2016: let args =
2017: if length ps' = 0 then "1"
2018: else String.concat " * " (List.map soa ps')
2019: in
2020: pe ("typedef " ^ fcbat ^ " = " ^ args ^ "; ");
2021: pe ("export type (" ^ fcbat ^ ") as \""^fcbat^"\";");
2022: pe ("typedef " ^ fcbt ^ " = " ^ args ^ " -> void; ");
2023: pe ("export type (" ^ fcbt ^ ") as \""^fcbt^"\";");
2024: let sr = {line=0;file="";byte=0} in
2025: let vi =
2026: {
2027: vname=fcbw; vtype=t'; vattr=[]; vglob=true;
2028: vinline=false; vdecl=sr; vid=0; vaddrof=false;
2029: vreferenced=true; vstorage=NoStorage
2030: }
2031: in
2032: let g = GVarDecl (vi,sr) in
2033: let d = defaultCilPrinter#pGlobal () g in
2034: let s = Flx_cil_pretty.sprint 65 d in
2035: let s = reformatc s in
2036: pe ("header '''" ^ s ^ "''';\n");
2037: pe ("const "^fcbw^": " ^ tname ^ " = \"" ^ fcbw ^ "\";");
2038:
2039: (* hack: elide trailing semicolon *)
2040: let s = String.sub s 0 (String.length s - 1) in
2041: pe ("body '''\n " ^ s ^ "{");
2042: let oargs = ref [] in
2043: iter
2044: (fun i -> if i <> cbi then
2045: oargs := ("a" ^ string_of_int (i+1)) :: !oargs
2046: )
2047: (nlist (length ps))
2048: ;
2049: pe (
2050: " con_t *p = (("^fcbt^")a" ^ string_of_int (cbi+1) ^
2051: ")->call(" ^
2052: if List.length !oargs > 1 then
2053: "0, " ^fcbat^"(" ^ String.concat ", " (rev !oargs)^"));"
2054: else
2055: String.concat ", " ("0" :: rev !oargs)^");"
2056: );
2057: pe (" while(p) p=p->resume();");
2058: pe ("}''';\n");
2059:
2060: | _ ->
2061: let args =
2062: if length ps' = 0 then "1"
2063: else String.concat " * " (List.map soa ps')
2064: in
2065: let args =
2066: if length ps' = 0 then "1"
2067: else String.concat " * " (List.map soa ps')
2068: in
2069: pe ("typedef " ^ fcbat ^ " = "^ args ^ ";");
2070: pe ("export type (" ^ fcbat ^ ") as \""^fcbat^"\";");
2071: pe ("typedef " ^ fcbt ^ " = "^ args ^ " -> "^sot ret^"; ");
2072: pe ("export type (" ^ fcbt ^ ") as \""^fcbt^"\";");
2073: let sr = {line=0;file="";byte=0} in
2074: let vi =
2075: {
2076: vname=fcbw; vtype=t'; vattr=[]; vglob=true;
2077: vinline=false; vdecl=sr; vid=0; vaddrof=false;
2078: vreferenced=true; vstorage=NoStorage
2079: }
2080: in
2081: let g = GVarDecl (vi,sr) in
2082: let d = defaultCilPrinter#pGlobal () g in
2083: let s = Flx_cil_pretty.sprint 65 d in
2084: let s = reformatc s in
2085: pe ("header '''" ^ s ^ "''';\n");
2086: pe ("const "^fcbw^": " ^ tname ^ " = \"" ^ fcbw ^ "\";");
2087:
2088: (* hack: elide trailing semicolon *)
2089: let s = String.sub s 0 (String.length s - 1) in
2090: pe ("body '''\n " ^ s ^ "{");
2091: let oargs = ref [] in
2092: iter
2093: (fun i -> if i <> cbi then
2094: oargs := ("a" ^ string_of_int (i+1)) :: !oargs
2095: )
2096: (nlist (length ps))
2097: ;
2098: pe (
2099: " return (("^fcbt^")a" ^ string_of_int (cbi+1) ^
2100: ")->apply(" ^
2101: if List.length !oargs > 1 then
2102: fcbat^"(" ^
2103: String.concat ", " (rev !oargs)^"));"
2104: else
2105: String.concat ", " (rev !oargs)^");"
2106: );
2107: pe ("}''';\n");
2108:
2109: end
2110: ;
2111: | _ -> assert false
2112: )
2113: stab.callback_types
2114: end
2115: ;
2116:
2117: if is_nonempty stab.callback_clients then
2118: begin
2119: let sot t = sot stab t in
2120: let soa a = soa stab a in
2121: pe "";
2122: pe "//CALLBACK CLIENT WRAPPERS";
2123: Hashtbl.iter
2124: (fun fname (t, cbt, cbi,adri)->
2125: pe ("//callback client " ^ fname ^ ", client data at " ^ string_of_int cbi ^ ", callback at " ^ string_of_int adri);
2126: match t with
2127: | TFun (ret,Some ps, false,a) ->
2128: (* fix arg names *)
2129: let i = ref 0 in
2130: let args = ref [] in
2131: iter
2132: (fun (_,t,a) ->
2133: if !i <> adri then begin
2134: let pn = "a"^ string_of_int (!i+1) in
2135: let t =
2136: if !i = cbi then "_fcbt_" ^ sot t
2137: else sot t
2138: in
2139: args := (pn,t) :: !args
2140: end
2141: ;
2142: incr i
2143: )
2144: ps
2145: ;
2146: let args = rev !args in
2147: let params =
2148: catmap ", "
2149: (fun (n,t) -> n ^ ": " ^ t)
2150: args
2151: in
2152: let call_args = ref [] in
2153: let i = ref 0 in
2154: for j = 0 to length ps - 1 do
2155: call_args :=
2156: begin
2157: if j = adri then
2158: ("C_hack::cast[address]a"^ string_of_int (cbi+1))
2159: else if j = cbi then
2160: ("_fcbw_" ^ cbt)
2161: else begin
2162: while !i=cbi || !i=adri do incr i done;
2163: let a = "a"^ string_of_int (!i+1) in
2164: incr i;
2165: a
2166: end
2167: end
2168: ::
2169: !call_args
2170: done
2171: ;
2172: begin match ret with
2173: | TVoid _ ->
2174: pe ("proc wrapper_" ^ fname ^ "(" ^ params ^ ") {");
2175: pe (" " ^fname^"(" ^ String.concat ", " (rev !call_args) ^ ");");
2176: pe ("}")
2177:
2178: | ret ->
2179: let ret = sot ret in
2180: pe ("fun wrapper_" ^ fname ^ "(" ^ params ^ "): "^ret^"= {");
2181: pe (" return " ^fname^"(" ^ String.concat ", " (rev !call_args) ^ ");");
2182: pe ("}")
2183:
2184: end
2185:
2186: | _ -> assert false
2187: )
2188: stab.callback_clients
2189: end
2190: ;
2191:
2192: if is_nonempty stab.fields then
2193: begin
2194: pe "";
2195: pe "//STRUCT and UNION FIELDS";
2196: Hashtbl.iter
2197: (fun k (v,b)->
2198: pe ("fun " ^ k ^ ": " ^v^ " = '" ^ b ^ "';")
2199: )
2200: stab.fields
2201: end
2202: end
2203: ;
2204: pe "}";
2205: close_out outf
2206: ;
2207: match mode with
2208: | `orig -> print_endline ("New file " ^ outname); ()
2209: | `tmp ->
2210: let f1 = force_open_in "new_file" "tmp.tmp" in
2211: let f2 = force_open_in "changed_file" outname in
2212: for i = 1 to 6 do (* skip timestamps when comparing *)
2213: ignore(input_line f1);
2214: ignore(input_line f2)
2215: done
2216: ;
2217: try
2218: while true do
2219: let in1 = try Some (input_line f1) with End_of_file -> None in
2220: let in2 = try Some (input_line f2) with End_of_file -> None in
2221: match in1,in2 with
2222: | None, None -> raise Equal
2223: | Some i, Some j when i = j -> ()
2224: | _ -> raise Not_equal
2225: done
2226: with
2227: | Not_equal ->
2228: begin
2229: print_endline ("Changed file .. " ^ outname);
2230: close_in f1; close_in f2;
2231: let f1 = force_open_in "changed_file" "tmp.tmp" in
2232: let f2 = force_open_out "change_file" outname in
2233: try while true do output_string f2 ((input_line f1) ^ "\n")
2234: done with End_of_file ->
2235: close_in f1; close_out f2
2236: end
2237:
2238: | Equal ->
2239: print_endline ("Unchanged file .. " ^ outname);
2240: close_in f2;
2241: close_in f1
2242: end
2243: fnames
2244: ;;
2245:
2246: if is_nonempty control.incomplete_types_cache then
2247: let outname =
2248: Filename.concat (control.outdir)
2249: ("_incomplete_types_cache.flx")
2250: in
2251: let outf = autocreate outname in
2252: let print_endline s = output_string outf (s ^ "\n") in
2253: print_endline "//incomplete type cache";
2254: print_endline "module _incomplete_types {";
2255: Hashtbl.iter
2256: (fun k (v,m) ->
2257: match m with
2258: | [_] -> ()
2259: | _ ->
2260: print_endline ("incomplete type " ^ k ^ " = '" ^v^ "';");
2261: List.iter
2262: (fun s -> print_endline (" // used by " ^ s)
2263: )
2264: m
2265: )
2266: control.incomplete_types_cache
2267: ;
2268: print_endline "}";
2269: close_out outf
2270: ;;
2271:
2272: let flx f =
2273: if control.flxg_command <> "" then begin
2274: let cmd = control.flxg_command ^ " -I"^control.outdir^" -c " ^f in
2275: print_endline cmd;
2276: Unix.system(cmd)
2277: end
2278: else Unix.WEXITED 0 (* cheat *)
2279: ;;
2280:
2281: let fnames = ref []
2282: ;;
2283:
2284: let rec dflx dir =
2285: try
2286: let f = Unix.opendir dir in
2287: begin
2288: try
2289: while true do let m = Unix.readdir f in
2290: let path = Filename.concat dir m in
2291: let st =
2292: try Unix.lstat path
2293: with _ -> failwith ("Can't lstat " ^ path)
2294: in
2295: match st.Unix.st_kind with
2296: | Unix.S_REG ->
2297: if Filename.check_suffix path ".flx" then
2298: let fn = Filename.chop_suffix path ".flx" in
2299: fnames := fn :: !fnames
2300:
2301: | Unix.S_DIR ->
2302: if not (isprefix "." m) then dflx path
2303: | _ -> ()
2304: done
2305: with End_of_file -> Unix.closedir f
2306: end
2307: with Unix.Unix_error _ ->
2308: failwith ("Can't find directory " ^ dir)
2309: ;;
2310:
2311: dflx control.outdir
2312: ;;
2313:
2314: let fnames = List.sort compare !fnames
2315: ;;
2316: let faulty = ref [];;
2317: let good = ref [];;
2318:
2319: iter
2320: begin fun fn ->
2321: let result = flx fn in
2322: match result with
2323: | Unix.WEXITED 0 -> good := fn :: !good
2324: | Unix.WEXITED i ->
2325: faulty := fn :: !faulty;
2326: print_endline ("***** Failed, error " ^ string_of_int i)
2327: | Unix.WSIGNALED i
2328: | Unix.WSTOPPED i ->
2329: failwith ("SIGNAL " ^ string_of_int i)
2330: end
2331: fnames
2332: ;;
2333:
2334: let f = open_out control.log_filename in
2335: iter
2336: (fun fn ->
2337: output_string f ("FAILED : " ^ fn ^ "\n")
2338: )
2339: (rev !faulty)
2340: ;
2341: iter
2342: (fun fn ->
2343: output_string f ("SUCCEEDED: " ^ fn ^ "\n")
2344: )
2345: (rev !good)
2346: ;
2347: close_out f
2348: ;;
2349:
Start data section to config/felix.flxcc[1
/1
]
1: // Felix: language and core library wrapper control
2: //
3: // rename Felix keywords
4: rename all all_
5: rename assert assert_
6: rename axiom axiom_
7: rename body body_
8: rename call call_
9: rename case case_
10: rename caseno caseno_
11: rename class class_
12: rename comment comment_
13: rename compound compound_
14: rename const const_
15: rename cclass cclass_
16: rename cstruct cstruct_
17: rename ctor ctor_
18: rename ctypes ctypes_
19: rename def def_
20: rename do do_
21: rename done done_
22: rename elif elif_
23: rename else else_
24: rename endif endif_
25: rename endmatch endmatch_
26: rename enum enum_
27: rename expect expect_
28: rename export export_
29: rename for for_
30: rename forget forget_
31: rename fork fork_
32: rename functor functor_
33: rename fun fun_
34: rename goto goto_
35: rename header header_
36: rename ident ident_
37: rename include include_
38: rename incomplete incomplete_
39: rename inf inf_
40: rename in in_
41: rename is is_
42: rename inherit inherit_
43: rename inline inline_
44: rename jump jump_
45: rename let let_
46: rename loop loop_
47: rename lval lval_
48: rename macro macro_
49: rename module module_
50: rename NaN NaN_
51: rename new new_
52: rename noinline noinline_
53: rename nonterm nonterm_
54: rename noreturn noreturn_
55: rename not not_
56: rename obj obj_
57: rename open open_
58: rename package package_
59: rename pod pod_
60: rename private private_
61: rename proc proc_
62: rename property property_
63: rename reduce reduce_
64: rename rename rename_
65: rename requires requires_
66: rename return return_
67: rename struct struct_
68: rename then then_
69: rename todo todo_
70: rename to to_
71: rename typedef typedef_
72: rename type type_
73: rename union union_
74: rename use use_
75: rename val val_
76: rename var var_
77: rename when when_
78: rename with with_
79: rename _ __
80: rename _gc_pointer _gc_pointer_
81: rename _gc_type _gc_type_
82: rename _svc _svc_
83: rename _deref _deref_
84: rename and and_
85: rename as as_
86: rename callback callback_
87: rename code code_
88: rename if if_
89: rename isin isin_
90: rename match match_
91: rename noexpand noexpand_
92: rename of of_
93: rename or or_
94: rename parse parse_
95: rename regexp regexp_
96: rename reglex reglex_
97: rename regmatch regmatch_
98: rename the the_
99: rename typematch typematch_
100: //
101: // We need to rename any C++ keywords too
102: rename namespace namespace_
103: rename namespace namespace_
104: //
105: // remap C types to Felix standard library types
106: rename size_t size
107: rename wchar_t wchar
108:
109: // ignore definitions of Felix standard library types
110: ignore vlong
111: ignore int
112: ignore float
113: ignore char
114: ignore uvlong
115: ignore tiny
116: ignore byte
117: ignore size
118: ignore uchar
119: ignore wchar
120: ignore long
121: ignore int8
122: ignore uint16
123: ignore complex
124: ignore limaginary
125: ignore dcomplex
126: ignore uint32
127: ignore lcomplex
128: ignore int32
129: ignore int16
130: ignore ulong
131: ignore uint8
132: ignore uint64
133: ignore uint
134: ignore offset
135: ignore imaginary
136: ignore dimaginary
137: ignore cvaddress
138: ignore utiny
139: ignore short
140: ignore double
141: ignore ushort
142: ignore int64
143: ignore caddress
144: ignore vaddress
145: ignore ldouble
146: ignore address
147: ignore wchar
148:
Start data section to tmp/gnu_c_search_path.flxcc.default[1
/1
]
1: path /usr/local/include
2: path /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/include
3: path /usr/include
4:
Start data section to tmp/gnu_cxx_search_path.flxcc.default[1
/1
]
1: path /usr/include/c++/4.0.0
2: path /usr/include/c++/4.0.0/backward
3: path /usr/include/c++/3.2.2
4: path /usr/include/c++/3.2.2/backward
5: path /usr/local/include
6: path /usr/include/c++/4.0.0/i386-redhat-linux
7: path /usr/include/c++/3.2.2/i386-redhat-linux
8: path /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/include
9: path /usr/include
10:
Start data section to tmp/gnu_headers.flxcc.default[1
/1
]
1: // This file contains annotations to control
2: // use of GNU system header files, and some other
3: // essential system resources
4:
5: // Some files say:
6: //
7: // extern struct X X(..
8: //
9: // which defines a function of the same name as
10: // a struct tag -- this is OK in C, problematic
11: // in C++, and definitely out for Felix
12: //
13: // Such functions are renamed by appending a trailin underscore
14: // without changing the name of the type
15: //
16: // NOTE: this is a serious pain because Felix cstructs
17: // automatically get constructors of the same name
18: // so the client using such a name may get an overload
19: // error (or even worse, a program that has the wrong semantics)
20:
21: rename_nontype sigaltstack sigaltstack_
22: rename_nontype sigstack sigstack_
23: rename_nontype sigvec sigvec_
24: rename_nontype mallinfo mallinfo_
25: rename_nontype vtimes vtimes_
26: rename_nontype statfs statfs_
27: rename_nontype timezone timezone_
28:
29: #include config/gnu_linux_macosx_headers.flxcc
Start data section to tmp/gnu_macosx_headers.flxcc.default[1
/1
]
Start data section to tmp/gnu_linux_headers.flxcc.default[1
/1
]
1: // Some files are designed as implementation details
2: // and not intended to be used directly
3: // We therefore prevent C level #includes like
4: //
5: // header '#include <file>';
6: //
7: // from being generated
8: //
9: // This related to the merge specifications below,
10: // but the two facilities are independent
11:
12: noheader /usr/include/bits/byteswap.h
13: noheader /usr/include/bits/cmathcalls.h
14: noheader /usr/include/bits/confname.h
15: noheader /usr/include/bits/dirent.h
16: noheader /usr/include/bits/dlfcn.h
17: noheader /usr/include/bits/elfclass.h
18: noheader /usr/include/bits/endian.h
19: noheader /usr/include/bits/environments.h
20: noheader /usr/include/bits/fcntl.h
21: noheader /usr/include/bits/fenv.h
22: noheader /usr/include/bits/huge_val.h
23: noheader /usr/include/bits/in.h
24: noheader /usr/include/bits/ioctls.h
25: noheader /usr/include/bits/ioctl-types.h
26: noheader /usr/include/bits/ipc.h
27: noheader /usr/include/bits/ipctypes.h
28: noheader /usr/include/bits/locale.h
29: noheader /usr/include/bits/mathcalls.h
30: noheader /usr/include/bits/mathdef.h
31: noheader /usr/include/bits/mathinline.h
32: noheader /usr/include/bits/mman.h
33: noheader /usr/include/bits/msq.h
34: noheader /usr/include/bits/nan.h
35: noheader /usr/include/bits/netdb.h
36: noheader /usr/include/bits/poll.h
37: noheader /usr/include/bits/posix1_lim.h
38: noheader /usr/include/bits/posix2_lim.h
39: noheader /usr/include/bits/pthreadtypes.h
40: noheader /usr/include/bits/resource.h
41: noheader /usr/include/bits/sched.h
42: noheader /usr/include/bits/select.h
43: noheader /usr/include/bits/sem.h
44: noheader /usr/include/bits/setjmp.h
45: noheader /usr/include/bits/shm.h
46: //noheader /usr/include/bits/sigset.h
47: //noheader /usr/include/bits/sigaction.h
48: //noheader /usr/include/bits/sigcontext.h
49: //noheader /usr/include/bits/siginfo.h
50: //noheader /usr/include/bits/sigstack.h
51: //noheader /usr/include/bits/sigthread.h
52: noheader /usr/include/bits/sockaddr.h
53: noheader /usr/include/bits/socket.h
54: noheader /usr/include/bits/statfs.h
55: noheader /usr/include/bits/stat.h
56: noheader /usr/include/bits/statvfs.h
57: noheader /usr/include/bits/stdio.h
58: noheader /usr/include/bits/stdio_lim.h
59: noheader /usr/include/bits/string2.h
60: noheader /usr/include/bits/string.h
61: noheader /usr/include/bits/stropts.h
62: noheader /usr/include/bits/syscall.h
63: noheader /usr/include/bits/sys_errlist.h
64: noheader /usr/include/bits/termios.h
65: noheader /usr/include/bits/time.h
66: noheader /usr/include/bits/types.h
67: noheader /usr/include/bits/typesizes.h
68: noheader /usr/include/bits/uio.h
69: noheader /usr/include/bits/ustat.h
70: noheader /usr/include/bits/utmp.h
71: noheader /usr/include/bits/utmpx.h
72: noheader /usr/include/bits/utsname.h
73: noheader /usr/include/bits/waitflags.h
74: noheader /usr/include/bits/waitstatus.h
75: noheader /usr/include/bits/xopen_lim.h
76: noheader /usr/include/bits/xtitypes.h
77:
78: // Some files have aliases created by
79: // symlinks and others include details
80: // that should really be treated as if they're
81: // physically included in the file, rather than
82: // a separate module -- see above comments on
83: // the related noheader command
84: //
85: // We use merge specification to say that any
86: // text found in the first file is treated as
87: // if it were physically part of the second one
88:
89: merge /usr/include/bits/sigset.h /usr/include/signal.h
90: merge /usr/include/bits/sigaction.h /usr/include/signal.h
91: merge /usr/include/bits/sigcontext.h /usr/include/signal.h
92: merge /usr/include/bits/siginfo.h /usr/include/signal.h
93: merge /usr/include/bits/sigstack.h /usr/include/signal.h
94: merge /usr/include/bits/sigthread.h /usr/include/pthread.h
95: merge /usr/include/bits/sched.h /usr/include/sched.h
96: merge /usr/include/bits/pthreadtypes.h /usr/include/sys/types.h
97: merge /usr/include/bits/confname.h /usr/include/unistd.h
98: merge /usr/include/bits/time.h /usr/include/time.h
99:
100: merge /usr/include/bits/byteswap.h /usr/include/byteswap.h
101: merge /usr/include/bits/cmathcalls.h /usr/include/complex.h
102: merge /usr/include/bits/dirent.h /usr/include/dirent.h
103: merge /usr/include/bits/dlfcn.h /usr/include/dlfcn.h
104: merge /usr/include/bits/elfclass.h /usr/include/link.h
105: merge /usr/include/bits/endian.h /usr/include/endian.h
106: merge /usr/include/bits/errno.h /usr/include/errno.h
107: merge /usr/include/bits/environments.h /usr/include/unistd.h
108: merge /usr/include/bits/fcntl.h /usr/include/fcntl.h
109: merge /usr/include/bits/fenv.h /usr/include/fenv.h
110: merge /usr/include/bits/huge_val.h /usr/include/math.h
111: merge /usr/include/bits/in.h /usr/include/netinet/in.h
112: merge /usr/include/bits/ioctls.h /usr/include/sys/ioctl.h
113: merge /usr/include/bits/ioctl-types.h /usr/include/sys/ioctl.h
114: merge /usr/include/bits/ipc.h /usr/include/sys/ipc.h
115: merge /usr/include/bits/ipctypes.h /usr/include/sys/ipc.h
116: merge /usr/include/bits/locale.h /usr/include/locale.h
117: merge /usr/include/bits/mathcalls.h /usr/include/math.h
118: merge /usr/include/bits/mathdef.h /usr/include/math.h
119: merge /usr/include/bits/mathinline.h /usr/include/math.h
120: merge /usr/include/bits/mman.h /usr/include/sys/mman.h
121: merge /usr/include/bits/msq.h /usr/include/sys/msg.h
122: merge /usr/include/bits/nan.h /usr/include/math.h
123: merge /usr/include/bits/netdb.h /usr/include/netdb.h
124: merge /usr/include/bits/poll.h /usr/include/sys/poll.h
125: merge /usr/include/bits/posix1_lim.h /usr/include/limits.h
126: merge /usr/include/bits/posix2_lim.h /usr/include/limits.h
127: merge /usr/include/bits/resource.h /usr/include/sys/resource.h
128: merge /usr/include/bits/select.h /usr/include/sys/select.h
129: merge /usr/include/bits/sem.h /usr/include/sys/sem.h
130: merge /usr/include/bits/setjmp.h /usr/include/setjmp.h
131: merge /usr/include/bits/shm.h /usr/include/sys/shm.h
132: merge /usr/include/bits/sockaddr.h /usr/include/sys/socket.h
133: merge /usr/include/bits/socket.h /usr/include/sys/socket.h
134: merge /usr/include/bits/statfs.h /usr/include/sys/statfs.h
135: merge /usr/include/bits/stat.h /usr/include/sys/stat.h
136: merge /usr/include/bits/statvfs.h /usr/include/sys/statvfs.h
137: merge /usr/include/bits/stdio.h /usr/include/stdio.h
138: merge /usr/include/bits/stdio_lim.h /usr/include/stdio.h
139: merge /usr/include/bits/string2.h /usr/include/string.h
140: merge /usr/include/bits/string.h /usr/include/string.h
141: merge /usr/include/bits/stropts.h /usr/include/stropts.h
142: merge /usr/include/bits/syscall.h /usr/include/sys/syscall.h
143: merge /usr/include/bits/sys_errlist.h /usr/include/stdio.h
144: merge /usr/include/bits/termios.h /usr/include/termios.h
145: merge /usr/include/bits/types.h /usr/include/sys/types.h
146: merge /usr/include/bits/typesizes.h /usr/include/sys/types.h
147: merge /usr/include/bits/uio.h /usr/include/sys/uio.h
148: merge /usr/include/bits/ustat.h /usr/include/sys/ustat.h
149: merge /usr/include/bits/utmp.h /usr/include/utmp.h
150: merge /usr/include/bits/utmpx.h /usr/include/utmpx.h
151: merge /usr/include/bits/utsname.h /usr/include/sys/utsname.h
152: merge /usr/include/bits/waitflags.h /usr/include/sys/wait.h
153: merge /usr/include/bits/waitstatus.h /usr/include/sys/wait.h
154: merge /usr/include/bits/xopen_lim.h /usr/include/limits.h
155: merge /usr/include/bits/xtitypes.h /usr/include/stropts.h
156:
Start data section to tmp/c89.flxcc.default[1
/1
]
1: #include config/felix.flxcc
2: #include config/gnu_headers.flxcc
3: #include config/gnu_c_search_path.flxcc
4: flx_compiler bin/flxg -Ilib
5:
6: outdir c89
7: prefix /usr/include
8: prefix /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/include
9: preprocessor gcc -E -std=c89
10: language C
11:
12: //-pthread -D_REENTRANT -DNEED_GNOMESUPPORT_H -DGTKHTML_HAVE_GCONF -DORBIT2=1
13:
14: incfile assert.h
15: incfile ctype.h
16: incfile errno.h
17: incfile fenv.h
18: incfile float.h
19: //incfile iso646.h: c99 only
20: incfile limits.h
21: incfile locale.h
22: incfile math.h
23: incfile setjmp.h
24: incfile signal.h
25: incfile stdarg.h
26: incfile stddef.h
27: incfile stdio.h
28: incfile stdlib.h
29: incfile string.h
30: incfile time.h
31: incfile wchar.h
32: incfile wctype.h
33:
34: rename String String_
35:
Start data section to tmp/gnu89.flxcc.default[1
/1
]
1: #include config/felix.flxcc
2: #include config/gnu_headers.flxcc
3: #include config/gnu_c_search_path.flxcc
4: flx_compiler bin/flxg -Ilib
5:
6: outdir gnu89
7: prefix /usr/include
8: prefix /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/include
9: preprocessor gcc -E -std=gnu89
10: language C
11: //-pthread -D_REENTRANT -DNEED_GNOMESUPPORT_H -DGTKHTML_HAVE_GCONF -DORBIT2=1
12: flx_compiler bin/flxg -Ilib
13:
14: incfile assert.h
15: incfile ctype.h
16: incfile errno.h
17: incfile fenv.h
18: incfile float.h
19: //incfile inttypes.h: c99 only
20: //incfile iso646.h: c99 only
21: incfile limits.h
22: incfile locale.h
23: incfile math.h
24: incfile setjmp.h
25: incfile signal.h
26: incfile stdarg.h
27: //incfile stdbool.h: c99 only
28: incfile stddef.h
29: //incfile stdint.h: c99 only
30: incfile stdio.h
31: incfile stdlib.h
32: incfile string.h
33: //incfile tgmath.h: c99 only
34: incfile time.h
35: incfile wchar.h
36: incfile wctype.h
37:
38: rename String String_
39:
Start data section to tmp/c99.flxcc.default[1
/1
]
1: #include config/felix.flxcc
2: #include config/gnu_headers.flxcc
3: #include config/gnu_c_search_path.flxcc
4: flx_compiler bin/flxg -Ilib
5:
6: outdir c99
7: prefix /usr/include
8: prefix /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/include
9: preprocessor gcc -E -std=c99
10: language C
11:
12: incfile assert.h
13: incfile ctype.h
14: incfile complex.h
15: incfile errno.h
16: incfile fenv.h
17: incfile float.h
18: incfile inttypes.h
19: //incfile iso646.h: just macros
20: incfile limits.h
21: incfile locale.h
22: incfile math.h
23: incfile setjmp.h
24: incfile signal.h
25: incfile stdarg.h
26: incfile stdbool.h
27: incfile stddef.h
28: incfile stdint.h
29: incfile stdio.h
30: incfile stdlib.h
31: incfile string.h
32: incfile tgmath.h
33: incfile time.h
34: incfile wchar.h
35: incfile wctype.h
36:
37: rename String String_
38:
Start data section to tmp/gnu99.flxcc.default[1
/1
]
1: #include config/felix.flxcc
2: #include config/gnu_headers.flxcc
3: #include config/gnu_c_search_path.flxcc
4: flx_compiler bin/flxg -Ilib
5:
6: outdir gnu99
7: prefix /usr/include
8: prefix /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/include
9: preprocessor gcc -E -std=gnu99
10: language C
11: //-pthread -D_REENTRANT -DNEED_GNOMESUPPORT_H -DGTKHTML_HAVE_GCONF -DORBIT2=1
12:
13: incfile assert.h
14: incfile ctype.h
15: incfile complex.h
16: incfile errno.h
17: incfile fenv.h
18: incfile float.h
19: incfile inttypes.h
20: //incfile iso646.h: just macros
21: incfile limits.h
22: incfile locale.h
23: incfile math.h
24: incfile setjmp.h
25: incfile signal.h
26: incfile stdarg.h
27: incfile stdbool.h
28: incfile stddef.h
29: incfile stdint.h
30: incfile stdio.h
31: incfile stdlib.h
32: incfile string.h
33: incfile tgmath.h
34: incfile time.h
35: incfile wchar.h
36: incfile wctype.h
37:
38: rename String String_
39:
Start data section to tmp/cxx.flxcc.default[1
/1
]
1: #include config/felix.flxcc
2: #include config/gnu_headers.flxcc
3: #include config/gnu_cxx_search_path.flxcc
4: flx_compiler bin/flxg -Ilib
5:
6: outdir cxx
7: prefix /usr/include
8: prefix /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/include
9: preprocessor g++ -E -I/usr/include/g++-3
10: language C++
11:
12: //-pthread -D_REENTRANT -DNEED_GNOMESUPPORT_H -DGTKHTML_HAVE_GCONF -DORBIT2=1
13:
14: incfile cctype
15: incfile cerrno
16: //incfile cfenv: cfenv.h is c99, we expect this to come to C++
17: incfile cfloat
18: incfile climits
19: incfile clocale
20: incfile cmath
21: incfile csetjmp
22: incfile csignal
23: incfile cstdarg
24: incfile cstddef
25: //incfile cstdint
26: incfile cstdio
27: incfile cstdlib
28: incfile cstring
29: incfile ctime
30: incfile cwchar
31: incfile cwctype
32:
33: rename String String_
34:
Start data section to tmp/cxx_sys.flxcc.default[1
/1
]
1: #include config/felix.flxcc
2: #include config/gnu_headers.flxcc
3: #include config/gnu_cxx_search_path.flxcc
4: flx_compiler bin/flxg -Ilib
5:
6: outdir cxx_sys
7: prefix /usr/include
8: prefix /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/include
9: preprocessor g++ -E -I/usr/include/g++-3
10: language C++
11:
12: //-pthread -D_REENTRANT -DNEED_GNOMESUPPORT_H -DGTKHTML_HAVE_GCONF -DORBIT2=1
13:
14: incfile cctype
15: incfile cerrno
16: //incfile cfenv: cfenv.h is c99, we expect this to come to C++
17: incfile cfloat
18: incfile climits
19: incfile clocale
20: incfile cmath
21: incfile csetjmp
22: incfile csignal
23: incfile cstdarg
24: incfile cstddef
25: //incfile cstdint
26: incfile cstdio
27: incfile cstdlib
28: incfile cstring
29: incfile ctime
30: incfile cwchar
31: incfile cwctype
32: incdir /usr/include/sys
33:
34: rename String String_
35:
Start data section to tmp/gnucxx.flxcc.default[1
/1
]
1: #include config/felix.flxcc
2: #include config/gnu_headers.flxcc
3: #include config/gnu_cxx_search_path.flxcc
4: flx_compiler bin/flxg -Ilib
5:
6: outdir gnucxx
7: prefix /usr/include
8: prefix /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/include
9: preprocessor g++ -E -I/usr/include/g++-3
10: language C++
11:
12: //-pthread -D_REENTRANT -DNEED_GNOMESUPPORT_H -DGTKHTML_HAVE_GCONF -DORBIT2=1
13:
14: incfile cctype
15: incfile cerrno
16: incfile cfloat
17: incfile climits
18: incfile clocale
19: incfile cmath
20: incfile csetjmp
21: incfile csignal
22: incfile cstdarg
23: incfile cstddef
24: //incfile cstdint
25: incfile cstdio
26: incfile cstdlib
27: incfile cstring
28: incfile ctime
29: incfile cwchar
30: incfile cwctype
31:
32: rename String String_
33:
Start data section to tmp/usr_include.flxcc.default[1
/1
]
1: #include config/felix.flxcc
2: #include config/gnu_headers.flxcc
3: #include config/gnu_cxx_search_path.flxcc
4: flx_compiler bin/flxg -Ilib
5:
6: outdir flxcc_out
7: prefix /usr/include
8: prefix /usr/local/include
9: prefix /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/include
10: prefix /usr/lib/glib/include/ glib
11: preprocessor g++ -E
12: language C
13:
14: //-pthread -D_REENTRANT -DNEED_GNOMESUPPORT_H -DGTKHTML_HAVE_GCONF -DORBIT2=1
15:
16: path /usr/include/atk-1.0
17: path /usr/include/bonobo-activation-2.0
18: path /usr/include/eel-2
19: path /usr/include/gail-1.0
20: path /usr/include/gal-1.0
21: path /usr/include/gconf/2
22: path /usr/include/gtk-2.0
23: path /usr/lib/gtk-2.0/include
24: path /usr/include/X11
25: path /usr/include/glib-2.0
26: path /usr/lib/glib-2.0/include
27: path /usr/lib/glib/include
28: path /usr/include/gnome-vfs-2.0
29: path /usr/lib/gnome-vfs-2.0/include
30: path /usr/include/gnome-vfs-module-2.0
31: path /usr/include/gtkhtml-1.1
32: path /usr/include/gdk-pixbuf-1.0
33: path /usr/include/gnome-1.0
34: path /usr/include/freetype2
35: path /usr/lib/gnome-libs/include
36: path /usr/include/gnome-xml
37: path /usr/include/libglade-1.0
38: path /usr/include/libart-2.0
39: path /usr/include/libbonobo-2.0
40: path /usr/include/libbonoboui-2.0
41: path /usr/include/libglade-2.0
42: path /usr/include/libgnome-2.0
43: path /usr/include/libgnomecanvas-2.0
44: path /usr/include/libgnomeui-2.0
45: path /usr/include/libgsf-1
46: path /usr/include/libIDL-2.0
47: path /usr/include/metacity-1
48: path /usr/include/panel-2.0
49: path /usr/include/libpng12
50: path /usr/include/librsvg-2
51: path /usr/include/libxml2
52: path /usr/include/linc-1.0
53: path /usr/kerberos/include
54: path /usr/include/orbit-2.0
55: path /usr/include/orbit-2.0/orbit-idl
56: path /usr/include/pango-1.0
57:
58: incdir /usr/include
59: incdir /usr/include/sys
60: incdir /usr/include/gtk-2.0/gdk
61: incdir /usr/include/gtk-2.0/gdk-pixbuf
62: incdir /usr/include/gtkhtml-1.1
63: recincdir /usr/include/libIDL-2.0
64: incfile /usr/include/gtk-2.0/gtk/gtk.h
65: recincdir /usr/local/include/python2.3
66:
67: exclude /usr/include/af_vfs.h
68: exclude /usr/include/disptmpl.h
69: exclude /usr/include/bits
70: exclude /usr/include/asm
71: exclude /usr/include/linux
72: exclude /usr/include/glib-1.2
73: exclude /usr/include/orbit-1.0
74: exclude /usr/include/c++
75: exclude /usr/include/g++-3
76: exclude /usr/include/libglade-1.0
77: exclude /usr/include/gtk-1.2
78: exclude /usr/include/glib-2.0/gobject
79: exclude /usr/include/FlexLexer.h
80: exclude /usr/include/swig.h
81: exclude /usr/include/Imlib.h
82: exclude /usr/include/Imlib_private.h
83: exclude /usr/include/Imlib_types.h
84: exclude /usr/include/rle_config.h
85: exclude /usr/include/md5.h
86: exclude /usr/include/pcap-namedb.h
87: exclude /usr/include/regexp.h
88: exclude /usr/include/hmac-md5.h
89: exclude /usr/include/jmorecfg.h
90: exclude /usr/include/jconfig.h
91: exclude /usr/local/include/python2.3/pymactoolbox.h
92: exclude /usr/include/libmng.h
93: exclude /usr/include/mp.h
94: exclude /usr/include/pammap.h
95:
96: rename String String_
97:
98: rename_nontype _ns_flagdata _ns_flagdata_
99: rename_nontype usb_device usb_device_
100: rename_nontype tcpd_context tcpd_context_
101:
102: merge /usr/X11R6/include/X11 /usr/include/X11
103:
104: