2. FrontC package
The copyright following applies to this sub-package.
(*
*
* Copyright (c) 2001 by
* George C. Necula necula@cs.berkeley.edu
* Scott McPeak smcpeak@cs.berkeley.edu
* Wes Weimer weimer@cs.berkeley.edu
*
* All rights reserved. Permission to use, copy, modify and distribute
* this software for research purposes only is hereby granted,
* provided that the following conditions are met:
* 1. Redistributions of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
* 3. The name of the authors may not be used to endorse or promote products
* derived from this software without specific prior written permission.
*
* DISCLAIMER:
* THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
* IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
* OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
* IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
* OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
* ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
* THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
*)
Start ocaml section to src/flx_cil_escape.ml[1
/1
]
1: # 40 "./lpsrc/flx_frontc.ipk"
2: (** OCaml types used to represent wide characters and strings *)
3: type wchar = int64
4: type wstring = wchar list
5:
6:
7: let escape_char = function
8: | '\007' -> "\\a"
9: | '\b' -> "\\b"
10: | '\t' -> "\\t"
11: | '\n' -> "\\n"
12: | '\011' -> "\\v"
13: | '\012' -> "\\f"
14: | '\r' -> "\\r"
15: | '"' -> "\\\""
16: | '\'' -> "\\'"
17: | '\\' -> "\\\\"
18: | ' ' .. '~' as printable -> String.make 1 printable
19: | unprintable -> Printf.sprintf "\\%03o" (Char.code unprintable)
20:
21: let escape_string str =
22: let length = String.length str in
23: let buffer = Buffer.create length in
24: for index = 0 to length - 1 do
25: Buffer.add_string buffer (escape_char (String.get str index))
26: done;
27: Buffer.contents buffer
28:
29: (* a wide char represented as an int64 *)
30: let escape_wchar =
31: (* limit checks whether upper > probe *)
32: let limit upper probe = (Int64.to_float (Int64.sub upper probe)) > 0.5 in
33: let fits_byte = limit (Int64.of_int 0x100) in
34: let fits_octal_escape = limit (Int64.of_int 0o1000) in
35: let fits_universal_4 = limit (Int64.of_int 0x10000) in
36: let fits_universal_8 = limit (Int64.of_string "0x100000000") in
37: fun charcode ->
38: if fits_byte charcode then
39: escape_char (Char.chr (Int64.to_int charcode))
40: else if fits_octal_escape charcode then
41: Printf.sprintf "\\%03Lo" charcode
42: else if fits_universal_4 charcode then
43: Printf.sprintf "\\u%04Lx" charcode
44: else if fits_universal_8 charcode then
45: Printf.sprintf "\\u%04Lx" charcode
46: else
47: invalid_arg "Flx_cil_cprint.escape_string_intlist"
48:
49: (* a wide string represented as a list of int64s *)
50: let escape_wstring (str : int64 list) =
51: let length = List.length str in
52: let buffer = Buffer.create length in
53: let append charcode =
54: let addition = escape_wchar charcode in
55: Buffer.add_string buffer addition
56: in
57: List.iter append str;
58: Buffer.contents buffer
59:
Start ocaml section to src/flx_cil_escape.mli[1
/1
]
1: # 100 "./lpsrc/flx_frontc.ipk"
2: (*
3: * Character and string escaping utilities
4: *)
5:
6: (** OCaml types used to represent wide characters and strings *)
7: type wchar = int64
8: type wstring = wchar list
9:
10: (** escape various constructs in accordance with C lexical rules *)
11: val escape_char : char -> string
12: val escape_string : string -> string
13: val escape_wchar : wchar -> string
14: val escape_wstring : wstring -> string
15:
Start ocaml section to src/flx_cil_cabs.mli[1
/1
]
1: # 116 "./lpsrc/flx_frontc.ipk"
2:
3: (** This file was originally part of Hugues Casee's frontc 2.0, and has been
4: * extensively changed since.
5: **
6: ** 1.0 3.22.99 Hugues Cassé First version.
7: ** 2.0 George Necula 12/12/00: Many extensions
8: **)
9:
10: (*
11: ** Types
12: *)
13:
14: type cabsloc = {
15: lineno : int;
16: filename: string;
17: byteno: int;
18:
19: }
20:
21: type lang_t = [`C | `Cxx]
22:
23: type typeSpecifier = (* Merge all specifiers into one type *)
24: | Tvoid (* Type specifier ISO 6.7.2 *)
25: | Tbool
26: | Tchar
27: | Tshort
28: | Tint
29: | Tlong
30: | Tint64
31: | Tfloat
32: | Tdouble
33: | Tsigned
34: | Tunsigned
35: | Tcomplex
36: | Timaginary
37: | Tnamed of string
38: (* each of the following three kinds of specifiers contains a field
39: * or item list iff it corresponds to a definition (as opposed to
40: * a forward declaration or simple reference to the type); they
41: * also have a list of __attribute__s that appeared between the
42: * keyword and the type name (definitions only) *)
43: | Tstruct of string * field_group list option * attribute list
44: | Tunion of string * field_group list option * attribute list
45: | Tenum of string * enum_item list option * attribute list
46: | TtypeofE of expression (* GCC __typeof__ *)
47: | TtypeofT of specifier * decl_type (* GCC __typeof__ *)
48:
49: and storage =
50: NO_STORAGE | AUTO | STATIC | EXTERN | REGISTER
51:
52: and funspec =
53: INLINE | VIRTUAL | EXPLICIT
54:
55: and cvspec =
56: CV_CONST | CV_VOLATILE | CV_RESTRICT
57:
58: (* Type specifier elements. These appear at the start of a declaration *)
59: (* Everywhere they appear in this file, they appear as a 'spec_elem list', *)
60: (* which is not interpreted by cabs -- rather, this "word soup" is passed *)
61: (* on to the compiler. Thus, we can represent e.g. 'int long float x' even *)
62: (* though the compiler will of course choke. *)
63: and spec_elem =
64: SpecTypedef
65: | SpecCV of cvspec (* const/volatile *)
66: | SpecAttr of attribute (* __attribute__ *)
67: | SpecStorage of storage
68: | SpecInline
69: | SpecType of typeSpecifier
70: | SpecPattern of string (* specifier pattern variable *)
71:
72: (* decided to go ahead and replace 'spec_elem list' with specifier *)
73: and specifier = spec_elem list
74:
75:
76: (* Declarator type. They modify the base type given in the specifier. Keep
77: * them in the order as they are printed (this means that the top level
78: * constructor for ARRAY and PTR is the inner-level in the meaning of the
79: * declared type) *)
80: and decl_type =
81: | JUSTBASE (* Prints the declared name *)
82: | PARENTYPE of attribute list * decl_type * attribute list
83: (* Prints "(attrs1 decl attrs2)".
84: * attrs2 are attributes of the
85: * declared identifier and it is as
86: * if they appeared at the very end
87: * of the declarator. attrs1 can
88: * contain attributes for the
89: * identifier or attributes for the
90: * enclosing type. *)
91: | ARRAY of decl_type * attribute list * expression
92: (* Prints "decl [ attrs exp ]".
93: * decl is never a PTR. *)
94: | PTR of attribute list * decl_type (* Prints "* attrs decl" *)
95: | PROTO of decl_type * single_name list * bool
96: (* Prints "decl (args[, ...])".
97: * decl is never a PTR.*)
98:
99: (* The base type and the storage are common to all names. Each name might
100: * contain type or storage modifiers *)
101: (* e.g.: int x, y; *)
102: and name_group = specifier * name list
103:
104: (* The optional expression is the bitfield *)
105: and field_group = specifier * (name * expression option) list
106:
107: (* like name_group, except the declared variables are allowed to have initializers *)
108: (* e.g.: int x=1, y=2; *)
109: and init_name_group = specifier * init_name list
110:
111: (* The decl_type is in the order in which they are printed. Only the name of
112: * the declared identifier is pulled out. The attributes are those that are
113: * printed after the declarator *)
114: (* e.g: in "int *x", "*x" is the declarator; "x" will be pulled out as *)
115: (* the string, and decl_type will be PTR([], JUSTBASE) *)
116: and name = string * decl_type * attribute list * cabsloc
117:
118: (* A variable declarator ("name") with an initializer *)
119: and init_name = name * init_expression
120:
121: (* Single names are for declarations that cannot come in groups, like
122: * function parameters and functions *)
123: and single_name = specifier * name
124:
125:
126: and enum_item = string * expression * cabsloc
127:
128: (*
129: ** Declaration definition (at toplevel)
130: *)
131: and base_spec = [
132: | `Public of string
133: | `Protected of string
134: | `Private of string
135: | `Public_virtual of string
136: | `Protected_virtual of string
137: | `Private_virtual of string
138: ]
139:
140: and definition =
141: FUNDEF of single_name * block * cabsloc * cabsloc
142: | DECDEF of init_name_group * cabsloc (* global variable(s), or function prototype *)
143: | TYPEDEF of name_group * cabsloc
144: | ONLYTYPEDEF of specifier * cabsloc
145: | GLOBASM of string * cabsloc
146: | PRAGMA of expression * cabsloc
147: | LINKAGE of string * cabsloc * definition list (* extern "C" { ... } *)
148: | NAMESPACE of string * cabsloc * definition list
149: (* toplevel form transformer, from the first definition to the *)
150: (* second group of definitions *)
151: | TRANSFORMER of definition * definition list * cabsloc
152: (* expression transformer: source and destination *)
153: | EXPRTRANSFORMER of expression * expression * cabsloc
154:
155:
156: (* the string is a file name, and then the list of toplevel forms *)
157: and file = string * definition list
158:
159:
160: (*
161: ** statements
162: *)
163:
164: (* A block contains a list of local label declarations ( GCC's ({ __label__
165: * l1, l2; ... }) ) , a list of definitions and a list of statements *)
166: and block =
167: { blabels: string list;
168: battrs: attribute list;
169: bstmts: statement list
170: }
171:
172: and statement =
173: NOP of cabsloc
174: | COMPUTATION of expression * cabsloc
175: | BLOCK of block * cabsloc
176: | SEQUENCE of statement * statement * cabsloc
177: | IF of expression * statement * statement * cabsloc
178: | WHILE of expression * statement * cabsloc
179: | DOWHILE of expression * statement * cabsloc
180: | FOR of for_clause * expression * expression * statement * cabsloc
181: | BREAK of cabsloc
182: | CONTINUE of cabsloc
183: | RETURN of expression * cabsloc
184: | SWITCH of expression * statement * cabsloc
185: | CASE of expression * statement * cabsloc
186: | CASERANGE of expression * expression * statement * cabsloc
187: | DEFAULT of statement * cabsloc
188: | LABEL of string * statement * cabsloc
189: | GOTO of string * cabsloc
190: | COMPGOTO of expression * cabsloc (* GCC's "goto *exp" *)
191: | DEFINITION of definition (*definition or declaration of a variable or type*)
192:
193: | ASM of attribute list * (* typically only volatile and const *)
194: string list * (* template *)
195: (string * expression) list * (* list of constraints and expressions for
196: * outputs *)
197: (string * expression) list * (* same for inputs *)
198: string list * (* clobbered registers *)
199: cabsloc
200:
201: (** MS SEH *)
202: | TRY_EXCEPT of block * expression * block * cabsloc
203: | TRY_FINALLY of block * block * cabsloc
204:
205: and for_clause =
206: FC_EXP of expression
207: | FC_DECL of definition
208:
209: (*
210: ** Expressions
211: *)
212: and binary_operator =
213: ADD | SUB | MUL | DIV | MOD
214: | AND | OR
215: | BAND | BOR | XOR | SHL | SHR
216: | EQ | NE | LT | GT | LE | GE
217: | ASSIGN
218: | ADD_ASSIGN | SUB_ASSIGN | MUL_ASSIGN | DIV_ASSIGN | MOD_ASSIGN
219: | BAND_ASSIGN | BOR_ASSIGN | XOR_ASSIGN | SHL_ASSIGN | SHR_ASSIGN
220:
221: and unary_operator =
222: MINUS | PLUS | NOT | BNOT | MEMOF | ADDROF
223: | PREINCR | PREDECR | POSINCR | POSDECR
224:
225: and expression =
226: NOTHING
227: | UNARY of unary_operator * expression
228: | LABELADDR of string (* GCC's && Label *)
229: | BINARY of binary_operator * expression * expression
230: | QUESTION of expression * expression * expression
231:
232: (* A CAST can actually be a constructor expression *)
233: | CAST of (specifier * decl_type) * init_expression
234:
235: (* There is a special form of CALL in which the function called is
236: __builtin_va_arg and the second argument is sizeof(T). This
237: should be printed as just T *)
238: | CALL of expression * expression list
239: | COMMA of expression list
240: | CONSTANT of constant
241: | VARIABLE of string
242: | EXPR_SIZEOF of expression
243: | TYPE_SIZEOF of specifier * decl_type
244: | EXPR_ALIGNOF of expression
245: | TYPE_ALIGNOF of specifier * decl_type
246: | INDEX of expression * expression
247: | MEMBEROF of expression * string
248: | MEMBEROFPTR of expression * string
249: | GNU_BODY of block
250: | EXPR_PATTERN of string (* pattern variable, and name *)
251:
252: and constant =
253: | CONST_INT of string (* the textual representation *)
254: | CONST_FLOAT of string (* the textual representaton *)
255: | CONST_CHAR of int64 list
256: | CONST_WCHAR of int64 list
257: | CONST_STRING of string
258: | CONST_WSTRING of int64 list
259: (* ww: wstrings are stored as an int64 list at this point because
260: * we might need to feed the wide characters piece-wise into an
261: * array initializer (e.g., wchar_t foo[] = L"E\xabcd";). If that
262: * doesn't happen we will convert it to an (escaped) string before
263: * passing it to Flx_cil_cil. *)
264:
265: and init_expression =
266: | NO_INIT
267: | SINGLE_INIT of expression
268: | COMPOUND_INIT of (initwhat * init_expression) list
269:
270: and initwhat =
271: NEXT_INIT
272: | INFIELD_INIT of string * initwhat
273: | ATINDEX_INIT of expression * initwhat
274: | ATINDEXRANGE_INIT of expression * expression
275:
276:
277: (* Each attribute has a name and some
278: * optional arguments *)
279: and attribute = string * expression list
280:
Start ocaml section to src/flx_cil_cabs_helper.mli[1
/1
]
1: # 397 "./lpsrc/flx_frontc.ipk"
2: val cabslu : Flx_cil_cabs.cabsloc
3: val missingFieldDecl :
4: string * Flx_cil_cabs.decl_type * 'a list * Flx_cil_cabs.cabsloc
5: val isStatic : Flx_cil_cabs.spec_elem list -> bool
6: val isExtern : Flx_cil_cabs.spec_elem list -> bool
7: val isInline : Flx_cil_cabs.spec_elem list -> bool
8: val isTypedef : Flx_cil_cabs.spec_elem list -> bool
9: val get_definitionloc : Flx_cil_cabs.definition -> Flx_cil_cabs.cabsloc
10: val get_statementloc : Flx_cil_cabs.statement -> Flx_cil_cabs.cabsloc
11: val explodeStringToInts : string -> int64 list
12: val valueOfDigit : char -> int64
13: val d_cabsloc : unit -> Flx_cil_cabs.cabsloc -> Flx_cil_pretty.doc
14:
Start ocaml section to src/flx_cil_cabs_helper.ml[1
/1
]
1: # 412 "./lpsrc/flx_frontc.ipk"
2: open Flx_cil_cabs
3:
4: let cabslu = {lineno = -10; filename = "cabs loc unknown"; byteno = -10;}
5:
6:
7: (*********** HELPER FUNCTIONS **********)
8:
9: let missingFieldDecl = ("___missing_field_name", JUSTBASE, [], cabslu)
10:
11: let rec isStatic = function
12: [] -> false
13: | (SpecStorage STATIC) :: _ -> true
14: | _ :: rest -> isStatic rest
15:
16: let rec isExtern = function
17: [] -> false
18: | (SpecStorage EXTERN) :: _ -> true
19: | _ :: rest -> isExtern rest
20:
21: let rec isInline = function
22: [] -> false
23: | SpecInline :: _ -> true
24: | _ :: rest -> isInline rest
25:
26: let rec isTypedef = function
27: [] -> false
28: | SpecTypedef :: _ -> true
29: | _ :: rest -> isTypedef rest
30:
31:
32: let get_definitionloc (d : definition) : cabsloc =
33: match d with
34: | FUNDEF(_, _, l, _) -> l
35: | DECDEF(_, l) -> l
36: | TYPEDEF(_, l) -> l
37: | ONLYTYPEDEF(_, l) -> l
38: | GLOBASM(_, l) -> l
39: | PRAGMA(_, l) -> l
40: | TRANSFORMER(_, _, l) -> l
41: | EXPRTRANSFORMER(_, _, l) -> l
42: | LINKAGE (_, l, _) -> l
43: | NAMESPACE (_, l, _) -> l
44:
45: let get_statementloc (s : statement) : cabsloc =
46: begin
47: match s with
48: | NOP(loc) -> loc
49: | COMPUTATION(_,loc) -> loc
50: | BLOCK(_,loc) -> loc
51: | SEQUENCE(_,_,loc) -> loc
52: | IF(_,_,_,loc) -> loc
53: | WHILE(_,_,loc) -> loc
54: | DOWHILE(_,_,loc) -> loc
55: | FOR(_,_,_,_,loc) -> loc
56: | BREAK(loc) -> loc
57: | CONTINUE(loc) -> loc
58: | RETURN(_,loc) -> loc
59: | SWITCH(_,_,loc) -> loc
60: | CASE(_,_,loc) -> loc
61: | CASERANGE(_,_,_,loc) -> loc
62: | DEFAULT(_,loc) -> loc
63: | LABEL(_,_,loc) -> loc
64: | GOTO(_,loc) -> loc
65: | COMPGOTO (_, loc) -> loc
66: | DEFINITION d -> get_definitionloc d
67: | ASM(_,_,_,_,_,loc) -> loc
68: | TRY_EXCEPT(_, _, _, loc) -> loc
69: | TRY_FINALLY(_, _, loc) -> loc
70: end
71:
72:
73: let explodeStringToInts (s: string) : int64 list =
74: let rec allChars i acc =
75: if i < 0 then acc
76: else allChars (i - 1) (Int64.of_int (Char.code (String.get s i)) :: acc)
77: in
78: allChars (-1 + String.length s) []
79:
80: let valueOfDigit chr =
81: let int_value =
82: match chr with
83: '0'..'9' -> (Char.code chr) - (Char.code '0')
84: | 'a'..'z' -> (Char.code chr) - (Char.code 'a') + 10
85: | 'A'..'Z' -> (Char.code chr) - (Char.code 'A') + 10
86: | _ -> Flx_cil_errormsg.s (Flx_cil_errormsg.bug "not a digit") in
87: Int64.of_int int_value
88:
89:
90: open Flx_cil_pretty
91: let d_cabsloc () cl =
92: text cl.filename ++ text ":" ++ num cl.lineno
Start ocaml section to src/flx_cil_cabsvisit.ml[1
/1
]
1: # 505 "./lpsrc/flx_frontc.ipk"
2:
3: (* cabsvisit.ml *)
4: (* tree visitor and rewriter for cabs *)
5:
6: open Flx_cil_cabs
7: open Flx_cil_cabs_helper
8: open Flx_cil_trace
9: open Flx_cil_pretty
10: module E = Flx_cil_errormsg
11:
12: (* basic interface for a visitor object *)
13:
14: (* Different visiting actions. 'a will be instantiated with exp, instr, etc. *)
15: type 'a visitAction =
16: SkipChildren (* Do not visit the children. Return
17: * the node as it is *)
18: | ChangeTo of 'a (* Replace the expression with the
19: * given one *)
20: | DoChildren (* Continue with the children of this
21: * node. Rebuild the node on return
22: * if any of the children changes
23: * (use == test) *)
24: | ChangeDoChildrenPost of 'a * ('a -> 'a) (* First consider that the entire
25: * exp is replaced by the first
26: * paramenter. Then continue with
27: * the children. On return rebuild
28: * the node if any of the children
29: * has changed and then apply the
30: * function on the node *)
31:
32: type nameKind =
33: NVar (* Variable or function prototype
34: name *)
35: | NFun (* A function definition name *)
36: | NField (* The name of a field *)
37: | NType (* The name of a type *)
38:
39: (* All visit methods are called in preorder! (but you can use
40: * ChangeDoChildrenPost to change the order) *)
41: class type cabsVisitor = object
42: method vexpr: expression -> expression visitAction (* expressions *)
43: method vinitexpr: init_expression -> init_expression visitAction
44: method vstmt: statement -> statement list visitAction
45: method vblock: block -> block visitAction
46: method vvar: string -> string (* use of a variable
47: * names *)
48: method vdef: definition -> definition list visitAction
49: method vtypespec: typeSpecifier -> typeSpecifier visitAction
50: method vdecltype: decl_type -> decl_type visitAction
51:
52: (* For each declaration we call vname *)
53: method vname: nameKind -> specifier -> name -> name visitAction
54: method vspec: specifier -> specifier visitAction (* specifier *)
55: method vattr: attribute -> attribute list visitAction
56:
57: method vEnterScope: unit -> unit
58: method vExitScope: unit -> unit
59: end
60:
61: let visitorLocation = ref { filename = ""; lineno = -1; byteno = -1; }
62:
63: (* a default visitor which does nothing to the tree *)
64: class nopFlx_cil_cabsVisitor : cabsVisitor = object
65: method vexpr (e:expression) = DoChildren
66: method vinitexpr (e:init_expression) = DoChildren
67: method vstmt (s: statement) =
68: visitorLocation := get_statementloc s;
69: DoChildren
70: method vblock (b: block) = DoChildren
71: method vvar (s: string) = s
72: method vdef (d: definition) =
73: visitorLocation := get_definitionloc d;
74: DoChildren
75: method vtypespec (ts: typeSpecifier) = DoChildren
76: method vdecltype (dt: decl_type) = DoChildren
77: method vname k (s:specifier) (n: name) = DoChildren
78: method vspec (s:specifier) = DoChildren
79: method vattr (a: attribute) = DoChildren
80:
81: method vEnterScope () = ()
82: method vExitScope () = ()
83: end
84:
85: (* Map but try not to copy the list unless necessary *)
86: let rec mapNoCopy (f: 'a -> 'a) = function
87: [] -> []
88: | (i :: resti) as li ->
89: let i' = f i in
90: let resti' = mapNoCopy f resti in
91: if i' != i || resti' != resti then i' :: resti' else li
92:
93: let rec mapNoCopyList (f: 'a -> 'a list) = function
94: [] -> []
95: | (i :: resti) as li ->
96: let il' = f i in
97: let resti' = mapNoCopyList f resti in
98: match il' with
99: [i'] when i' == i && resti' == resti -> li
100: | _ -> il' @ resti'
101:
102: let doVisit (vis: cabsVisitor)
103: (startvisit: 'a -> 'a visitAction)
104: (children: cabsVisitor -> 'a -> 'a)
105: (node: 'a) : 'a =
106: let action = startvisit node in
107: match action with
108: SkipChildren -> node
109: | ChangeTo node' -> node'
110: | _ ->
111: let nodepre = match action with
112: ChangeDoChildrenPost (node', _) -> node'
113: | _ -> node
114: in
115: let nodepost = children vis nodepre in
116: match action with
117: ChangeDoChildrenPost (_, f) -> f nodepost
118: | _ -> nodepost
119:
120: (* A visitor for lists *)
121: let doVisitList (vis: cabsVisitor)
122: (startvisit: 'a -> 'a list visitAction)
123: (children: cabsVisitor -> 'a -> 'a)
124: (node: 'a) : 'a list =
125: let action = startvisit node in
126: match action with
127: SkipChildren -> [node]
128: | ChangeTo nodes' -> nodes'
129: | _ ->
130: let nodespre = match action with
131: ChangeDoChildrenPost (nodespre, _) -> nodespre
132: | _ -> [node]
133: in
134: let nodespost = mapNoCopy (children vis) nodespre in
135: match action with
136: ChangeDoChildrenPost (_, f) -> f nodespost
137: | _ -> nodespost
138:
139:
140: let rec visit_cabsTypeSpecifier (vis: cabsVisitor) (ts: typeSpecifier) =
141: doVisit vis vis#vtypespec childrenTypeSpecifier ts
142:
143: and childrenTypeSpecifier vis ts =
144: let childrenFieldGroup ((s, nel) as input) =
145: let s' = visit_cabsSpecifier vis s in
146: let doOneField ((n, eo) as input) =
147: let n' = visit_cabsName vis NField s' n in
148: let eo' =
149: match eo with
150: None -> None
151: | Some e -> let e' = visit_cabsExpression vis e in
152: if e' != e then Some e' else eo
153: in
154: if n' != n || eo' != eo then (n', eo') else input
155: in
156: let nel' = mapNoCopy doOneField nel in
157: if s' != s || nel' != nel then (s', nel) else input
158: in
159: match ts with
160: Tstruct (n, Some fg, extraAttrs) ->
161: (*(trace "sm" (dprintf "visiting struct %s\n" n));*)
162: let fg' = mapNoCopy childrenFieldGroup fg in
163: if fg' != fg then Tstruct( n, Some fg', extraAttrs) else ts
164: | Tunion (n, Some fg, extraAttrs) ->
165: let fg' = mapNoCopy childrenFieldGroup fg in
166: if fg' != fg then Tunion( n, Some fg', extraAttrs) else ts
167: | Tenum (n, Some ei, extraAttrs) ->
168: let doOneEnumItem ((s, e, loc) as ei) =
169: let e' = visit_cabsExpression vis e in
170: if e' != e then (s, e', loc) else ei
171: in
172: vis#vEnterScope ();
173: let ei' = mapNoCopy doOneEnumItem ei in
174: vis#vExitScope();
175: if ei' != ei then Tenum( n, Some ei', extraAttrs) else ts
176: | TtypeofE e ->
177: let e' = visit_cabsExpression vis e in
178: if e' != e then TtypeofE e' else ts
179: | TtypeofT (s, dt) ->
180: let s' = visit_cabsSpecifier vis s in
181: let dt' = visit_cabsDeclType vis false dt in
182: if s != s' || dt != dt' then TtypeofT (s', dt') else ts
183: | ts -> ts
184:
185: and childrenSpecElem (vis: cabsVisitor) (se: spec_elem) : spec_elem =
186: match se with
187: SpecTypedef | SpecInline | SpecStorage _ | SpecPattern _ -> se
188: | SpecCV _ -> se (* cop out *)
189: | SpecAttr a -> begin
190: let al' = visit_cabsAttribute vis a in
191: match al' with
192: [a''] when a'' == a -> se
193: | [a''] -> SpecAttr a''
194: | _ -> E.s (E.unimp "childrenSpecElem: visit_cabsAttribute returned a list")
195: end
196: | SpecType ts ->
197: let ts' = visit_cabsTypeSpecifier vis ts in
198: if ts' != ts then SpecType ts' else se
199:
200: and visit_cabsSpecifier (vis: cabsVisitor) (s: specifier) : specifier =
201: doVisit vis vis#vspec childrenSpec s
202: and childrenSpec vis s = mapNoCopy (childrenSpecElem vis) s
203:
204:
205: and visit_cabsDeclType vis (isfundef: bool) (dt: decl_type) : decl_type =
206: doVisit vis vis#vdecltype (childrenDeclType isfundef) dt
207: and childrenDeclType isfundef vis dt =
208: match dt with
209: JUSTBASE -> dt
210: | PARENTYPE (prea, dt1, posta) ->
211: let prea' = mapNoCopyList (visit_cabsAttribute vis) prea in
212: let dt1' = visit_cabsDeclType vis isfundef dt1 in
213: let posta'= mapNoCopyList (visit_cabsAttribute vis) posta in
214: if prea' != prea || dt1' != dt1 || posta' != posta then
215: PARENTYPE (prea', dt1', posta') else dt
216: | ARRAY (dt1, al, e) ->
217: let dt1' = visit_cabsDeclType vis isfundef dt1 in
218: let al' = mapNoCopy (childrenAttribute vis) al in
219: let e'= visit_cabsExpression vis e in
220: if dt1' != dt1 || al' != al || e' != e then ARRAY(dt1', al', e') else dt
221: | PTR (al, dt1) ->
222: let al' = mapNoCopy (childrenAttribute vis) al in
223: let dt1' = visit_cabsDeclType vis isfundef dt1 in
224: if al' != al || dt1' != dt1 then PTR(al', dt1') else dt
225: | PROTO (dt1, snl, b) ->
226: (* Do not propagate isfundef further *)
227: let dt1' = visit_cabsDeclType vis false dt1 in
228: let _ = vis#vEnterScope () in
229: let snl' = mapNoCopy (childrenSingleName vis NVar) snl in
230: (* Exit the scope only if not in a function definition *)
231: let _ = if not isfundef then vis#vExitScope () in
232: if dt1' != dt1 || snl' != snl then PROTO(dt1', snl', b) else dt
233:
234:
235: and childrenNameGroup vis (kind: nameKind) ((s, nl) as input) =
236: let s' = visit_cabsSpecifier vis s in
237: let nl' = mapNoCopy (visit_cabsName vis kind s') nl in
238: if s' != s || nl' != nl then (s', nl') else input
239:
240:
241: and childrenInitNameGroup vis ((s, inl) as input) =
242: let s' = visit_cabsSpecifier vis s in
243: let inl' = mapNoCopy (childrenInitName vis s') inl in
244: if s' != s || inl' != inl then (s', inl') else input
245:
246: and visit_cabsName vis (k: nameKind) (s: specifier)
247: (n: name) : name =
248: doVisit vis (vis#vname k s) (childrenName s k) n
249: and childrenName (s: specifier) (k: nameKind) vis (n: name) : name =
250: let (sn, dt, al, loc) = n in
251: let dt' = visit_cabsDeclType vis (k = NFun) dt in
252: let al' = mapNoCopy (childrenAttribute vis) al in
253: if dt' != dt || al' != al then (sn, dt', al', loc) else n
254:
255: and childrenInitName vis (s: specifier) (inn: init_name) : init_name =
256: let (n, ie) = inn in
257: let n' = visit_cabsName vis NVar s n in
258: let ie' = visit_cabsInitExpression vis ie in
259: if n' != n || ie' != ie then (n', ie') else inn
260:
261: and childrenSingleName vis (k: nameKind) (sn: single_name) : single_name =
262: let s, n = sn in
263: let s' = visit_cabsSpecifier vis s in
264: let n' = visit_cabsName vis k s' n in
265: if s' != s || n' != n then (s', n') else sn
266:
267: and visit_cabsDefinition vis (d: definition) : definition list =
268: doVisitList vis vis#vdef childrenDefinition d
269: and childrenDefinition vis d =
270: match d with
271: FUNDEF (sn, b, l, lend) ->
272: let sn' = childrenSingleName vis NFun sn in
273: let b' = visit_cabsBlock vis b in
274: (* End the scope that was started by childrenFunctionName *)
275: vis#vExitScope ();
276: if sn' != sn || b' != b then FUNDEF (sn', b', l, lend) else d
277:
278: | DECDEF ((s, inl), l) ->
279: let s' = visit_cabsSpecifier vis s in
280: let inl' = mapNoCopy (childrenInitName vis s') inl in
281: if s' != s || inl' != inl then DECDEF ((s', inl'), l) else d
282: | TYPEDEF (ng, l) ->
283: let ng' = childrenNameGroup vis NType ng in
284: if ng' != ng then TYPEDEF (ng', l) else d
285: | ONLYTYPEDEF (s, l) ->
286: let s' = visit_cabsSpecifier vis s in
287: if s' != s then ONLYTYPEDEF (s', l) else d
288: | GLOBASM _ -> d
289: | PRAGMA (e, l) ->
290: let e' = visit_cabsExpression vis e in
291: if e' != e then PRAGMA (e', l) else d
292: | LINKAGE (n, l, dl) ->
293: let dl' = mapNoCopyList (visit_cabsDefinition vis) dl in
294: if dl' != dl then LINKAGE (n, l, dl') else d
295:
296: | NAMESPACE (n, l, dl) ->
297: let dl' = mapNoCopyList (visit_cabsDefinition vis) dl in
298: if dl' != dl then NAMESPACE (n, l, dl') else d
299:
300: | TRANSFORMER _ -> d
301: | EXPRTRANSFORMER _ -> d
302:
303: and visit_cabsBlock vis (b: block) : block =
304: doVisit vis vis#vblock childrenBlock b
305:
306: and childrenBlock vis (b: block) : block =
307: let _ = vis#vEnterScope () in
308: let battrs' = mapNoCopyList (visit_cabsAttribute vis) b.battrs in
309: let bstmts' = mapNoCopyList (visit_cabsStatement vis) b.bstmts in
310: let _ = vis#vExitScope () in
311: if battrs' != b.battrs || bstmts' != b.bstmts then
312: { blabels = b.blabels; battrs = battrs'; bstmts = bstmts' }
313: else
314: b
315:
316: and visit_cabsStatement vis (s: statement) : statement list =
317: doVisitList vis vis#vstmt childrenStatement s
318: and childrenStatement vis s =
319: let ve e = visit_cabsExpression vis e in
320: let vs l s =
321: match visit_cabsStatement vis s with
322: [s'] -> s'
323: | sl -> BLOCK ({blabels = []; battrs = []; bstmts = sl }, l)
324: in
325: match s with
326: NOP _ -> s
327: | COMPUTATION (e, l) ->
328: let e' = ve e in
329: if e' != e then COMPUTATION (e', l) else s
330: | BLOCK (b, l) ->
331: let b' = visit_cabsBlock vis b in
332: if b' != b then BLOCK (b', l) else s
333: | SEQUENCE (s1, s2, l) ->
334: let s1' = vs l s1 in
335: let s2' = vs l s2 in
336: if s1' != s1 || s2' != s2 then SEQUENCE (s1', s2', l) else s
337: | IF (e, s1, s2, l) ->
338: let e' = ve e in
339: let s1' = vs l s1 in
340: let s2' = vs l s2 in
341: if e' != e || s1' != s1 || s2' != s2 then IF (e', s1', s2', l) else s
342: | WHILE (e, s1, l) ->
343: let e' = ve e in
344: let s1' = vs l s1 in
345: if e' != e || s1' != s1 then WHILE (e', s1', l) else s
346: | DOWHILE (e, s1, l) ->
347: let e' = ve e in
348: let s1' = vs l s1 in
349: if e' != e || s1' != s1 then DOWHILE (e', s1', l) else s
350: | FOR (fc1, e2, e3, s4, l) ->
351: let _ = vis#vEnterScope () in
352: let fc1' =
353: match fc1 with
354: FC_EXP e1 ->
355: let e1' = ve e1 in
356: if e1' != e1 then FC_EXP e1' else fc1
357: | FC_DECL d1 ->
358: let d1' =
359: match visit_cabsDefinition vis d1 with
360: [d1'] -> d1'
361: | _ -> E.s (E.unimp "visit_cabs: for can have only one definition")
362: in
363: if d1' != d1 then FC_DECL d1' else fc1
364: in
365: let e2' = ve e2 in
366: let e3' = ve e3 in
367: let s4' = vs l s4 in
368: let _ = vis#vExitScope () in
369: if fc1' != fc1 || e2' != e2 || e3' != e3 || s4' != s4
370: then FOR (fc1', e2', e3', s4', l) else s
371: | BREAK _ | CONTINUE _ | GOTO _ -> s
372: | RETURN (e, l) ->
373: let e' = ve e in
374: if e' != e then RETURN (e', l) else s
375: | SWITCH (e, s1, l) ->
376: let e' = ve e in
377: let s1' = vs l s1 in
378: if e' != e || s1' != s1 then SWITCH (e', s1', l) else s
379: | CASE (e, s1, l) ->
380: let e' = ve e in
381: let s1' = vs l s1 in
382: if e' != e || s1' != s1 then CASE (e', s1', l) else s
383: | CASERANGE (e1, e2, s3, l) ->
384: let e1' = ve e1 in
385: let e2' = ve e2 in
386: let s3' = vs l s3 in
387: if e1' != e1 || e2' != e2 || s3' != s3 then
388: CASERANGE (e1', e2', s3', l) else s
389: | DEFAULT (s1, l) ->
390: let s1' = vs l s1 in
391: if s1' != s1 then DEFAULT (s1', l) else s
392: | LABEL (n, s1, l) ->
393: let s1' = vs l s1 in
394: if s1' != s1 then LABEL (n, s1', l) else s
395: | COMPGOTO (e, l) ->
396: let e' = ve e in
397: if e' != e then COMPGOTO (e', l) else s
398: | DEFINITION d -> begin
399: match visit_cabsDefinition vis d with
400: [d'] when d' == d -> s
401: | dl -> let l = get_definitionloc d in
402: let dl' = List.map (fun d' -> DEFINITION d') dl in
403: BLOCK ({blabels = []; battrs = []; bstmts = dl' }, l)
404: end
405: | ASM (sl, b, inl, outl, clobs, l) ->
406: let childrenStringExp ((s, e) as input) =
407: let e' = ve e in
408: if e' != e then (s, e') else input
409: in
410: let inl' = mapNoCopy childrenStringExp inl in
411: let outl' = mapNoCopy childrenStringExp outl in
412: if inl' != inl || outl' != outl then
413: ASM (sl, b, inl', outl', clobs, l) else s
414: | TRY_FINALLY (b1, b2, l) ->
415: let b1' = visit_cabsBlock vis b1 in
416: let b2' = visit_cabsBlock vis b2 in
417: if b1' != b1 || b2' != b2 then TRY_FINALLY(b1', b2', l) else s
418: | TRY_EXCEPT (b1, e, b2, l) ->
419: let b1' = visit_cabsBlock vis b1 in
420: let e' = visit_cabsExpression vis e in
421: let b2' = visit_cabsBlock vis b2 in
422: if b1' != b1 || e' != e || b2' != b2 then TRY_EXCEPT(b1', e', b2', l) else s
423:
424:
425: and visit_cabsExpression vis (e: expression) : expression =
426: doVisit vis vis#vexpr childrenExpression e
427: and childrenExpression vis e =
428: let ve e = visit_cabsExpression vis e in
429: match e with
430: NOTHING | LABELADDR _ -> e
431: | UNARY (uo, e1) ->
432: let e1' = ve e1 in
433: if e1' != e1 then UNARY (uo, e1') else e
434: | BINARY (bo, e1, e2) ->
435: let e1' = ve e1 in
436: let e2' = ve e2 in
437: if e1' != e1 || e2' != e2 then BINARY (bo, e1', e2') else e
438: | QUESTION (e1, e2, e3) ->
439: let e1' = ve e1 in
440: let e2' = ve e2 in
441: let e3' = ve e3 in
442: if e1' != e1 || e2' != e2 || e3' != e3 then
443: QUESTION (e1', e2', e3') else e
444: | CAST ((s, dt), ie) ->
445: let s' = visit_cabsSpecifier vis s in
446: let dt' = visit_cabsDeclType vis false dt in
447: let ie' = visit_cabsInitExpression vis ie in
448: if s' != s || dt' != dt || ie' != ie then CAST ((s', dt'), ie') else e
449: | CALL (f, el) ->
450: let f' = ve f in
451: let el' = mapNoCopy ve el in
452: if f' != f || el' != el then CALL (f', el') else e
453: | COMMA el ->
454: let el' = mapNoCopy ve el in
455: if el' != el then COMMA (el') else e
456: | CONSTANT _ -> e
457: | VARIABLE s ->
458: let s' = vis#vvar s in
459: if s' != s then VARIABLE s' else e
460: | EXPR_SIZEOF (e1) ->
461: let e1' = ve e1 in
462: if e1' != e1 then EXPR_SIZEOF (e1') else e
463: | TYPE_SIZEOF (s, dt) ->
464: let s' = visit_cabsSpecifier vis s in
465: let dt' = visit_cabsDeclType vis false dt in
466: if s' != s || dt' != dt then TYPE_SIZEOF (s' ,dt') else e
467: | EXPR_ALIGNOF (e1) ->
468: let e1' = ve e1 in
469: if e1' != e1 then EXPR_ALIGNOF (e1') else e
470: | TYPE_ALIGNOF (s, dt) ->
471: let s' = visit_cabsSpecifier vis s in
472: let dt' = visit_cabsDeclType vis false dt in
473: if s' != s || dt' != dt then TYPE_ALIGNOF (s' ,dt') else e
474: | INDEX (e1, e2) ->
475: let e1' = ve e1 in
476: let e2' = ve e2 in
477: if e1' != e1 || e2' != e2 then INDEX (e1', e2') else e
478: | MEMBEROF (e1, n) ->
479: let e1' = ve e1 in
480: if e1' != e1 then MEMBEROF (e1', n) else e
481: | MEMBEROFPTR (e1, n) ->
482: let e1' = ve e1 in
483: if e1' != e1 then MEMBEROFPTR (e1', n) else e
484: | GNU_BODY b ->
485: let b' = visit_cabsBlock vis b in
486: if b' != b then GNU_BODY b' else e
487: | EXPR_PATTERN _ -> e
488:
489: and visit_cabsInitExpression vis (ie: init_expression) : init_expression =
490: doVisit vis vis#vinitexpr childrenInitExpression ie
491: and childrenInitExpression vis ie =
492: let rec childrenInitWhat iw =
493: match iw with
494: NEXT_INIT -> iw
495: | INFIELD_INIT (n, iw1) ->
496: let iw1' = childrenInitWhat iw1 in
497: if iw1' != iw1 then INFIELD_INIT (n, iw1') else iw
498: | ATINDEX_INIT (e, iw1) ->
499: let e' = visit_cabsExpression vis e in
500: let iw1' = childrenInitWhat iw1 in
501: if e' != e || iw1' != iw1 then ATINDEX_INIT (e', iw1') else iw
502: | ATINDEXRANGE_INIT (e1, e2) ->
503: let e1' = visit_cabsExpression vis e1 in
504: let e2' = visit_cabsExpression vis e2 in
505: if e1' != e1 || e2' != e2 then ATINDEXRANGE_INIT (e1, e2) else iw
506: in
507: match ie with
508: NO_INIT -> ie
509: | SINGLE_INIT e ->
510: let e' = visit_cabsExpression vis e in
511: if e' != e then SINGLE_INIT e' else ie
512: | COMPOUND_INIT il ->
513: let childrenOne ((iw, ie) as input) =
514: let iw' = childrenInitWhat iw in
515: let ie' = visit_cabsInitExpression vis ie in
516: if iw' != iw || ie' != ie then (iw', ie') else input
517: in
518: let il' = mapNoCopy childrenOne il in
519: if il' != il then COMPOUND_INIT il' else ie
520:
521:
522: and visit_cabsAttribute vis (a: attribute) : attribute list =
523: doVisitList vis vis#vattr childrenAttribute a
524:
525: and childrenAttribute vis ((n, el) as input) =
526: let el' = mapNoCopy (visit_cabsExpression vis) el in
527: if el' != el then (n, el') else input
528:
529: and visit_cabsAttributes vis (al: attribute list) : attribute list =
530: mapNoCopyList (visit_cabsAttribute vis) al
531:
532: let visit_cabsFile (vis: cabsVisitor) ((fname, f): file) : file =
533: (fname, mapNoCopyList (visit_cabsDefinition vis) f)
534:
535: (* end of file *)
536:
Start ocaml section to src/flx_cil_cabsvisit.mli[1
/1
]
1: # 1042 "./lpsrc/flx_frontc.ipk"
2:
3: (* cabsvisit.mli *)
4: (* interface for cabsvisit.ml *)
5:
6: (* Different visiting actions. 'a will be instantiated with exp, instr, etc. *)
7: type 'a visitAction =
8: SkipChildren (* Do not visit the children. Return
9: * the node as it is *)
10: | ChangeTo of 'a (* Replace the expression with the
11: * given one *)
12: | DoChildren (* Continue with the children of this
13: * node. Rebuild the node on return
14: * if any of the children changes
15: * (use == test) *)
16: | ChangeDoChildrenPost of 'a * ('a -> 'a) (* First consider that the entire
17: * exp is replaced by the first
18: * paramenter. Then continue with
19: * the children. On return rebuild
20: * the node if any of the children
21: * has changed and then apply the
22: * function on the node *)
23:
24: type nameKind =
25: NVar (** Variable or function prototype
26: name *)
27: | NFun (** Function definition name *)
28: | NField (** The name of a field *)
29: | NType (** The name of a type *)
30:
31:
32: (* All visit methods are called in preorder! (but you can use
33: * ChangeDoChildrenPost to change the order) *)
34: class type cabsVisitor = object
35: method vexpr: Flx_cil_cabs.expression -> Flx_cil_cabs.expression visitAction (* expressions *)
36: method vinitexpr: Flx_cil_cabs.init_expression -> Flx_cil_cabs.init_expression visitAction
37: method vstmt: Flx_cil_cabs.statement -> Flx_cil_cabs.statement list visitAction
38: method vblock: Flx_cil_cabs.block -> Flx_cil_cabs.block visitAction
39: method vvar: string -> string (* use of a variable
40: * names *)
41: method vdef: Flx_cil_cabs.definition -> Flx_cil_cabs.definition list visitAction
42: method vtypespec: Flx_cil_cabs.typeSpecifier -> Flx_cil_cabs.typeSpecifier visitAction
43: method vdecltype: Flx_cil_cabs.decl_type -> Flx_cil_cabs.decl_type visitAction
44:
45: (* For each declaration we call vname *)
46: method vname: nameKind -> Flx_cil_cabs.specifier -> Flx_cil_cabs.name -> Flx_cil_cabs.name visitAction
47: method vspec: Flx_cil_cabs.specifier -> Flx_cil_cabs.specifier visitAction (* specifier *)
48: method vattr: Flx_cil_cabs.attribute -> Flx_cil_cabs.attribute list visitAction
49:
50:
51: method vEnterScope: unit -> unit
52: method vExitScope: unit -> unit
53: end
54:
55:
56: class nopFlx_cil_cabsVisitor: cabsVisitor
57:
58:
59: val visit_cabsTypeSpecifier: cabsVisitor ->
60: Flx_cil_cabs.typeSpecifier -> Flx_cil_cabs.typeSpecifier
61: val visit_cabsSpecifier: cabsVisitor -> Flx_cil_cabs.specifier -> Flx_cil_cabs.specifier
62:
63: (** Visits a decl_type. The bool argument is saying whether we are ina
64: * function definition and thus the scope in a PROTO should extend until the
65: * end of the function *)
66: val visit_cabsDeclType: cabsVisitor -> bool -> Flx_cil_cabs.decl_type -> Flx_cil_cabs.decl_type
67: val visit_cabsDefinition: cabsVisitor -> Flx_cil_cabs.definition -> Flx_cil_cabs.definition list
68: val visit_cabsBlock: cabsVisitor -> Flx_cil_cabs.block -> Flx_cil_cabs.block
69: val visit_cabsStatement: cabsVisitor -> Flx_cil_cabs.statement -> Flx_cil_cabs.statement list
70: val visit_cabsExpression: cabsVisitor -> Flx_cil_cabs.expression -> Flx_cil_cabs.expression
71: val visit_cabsAttributes: cabsVisitor -> Flx_cil_cabs.attribute list
72: -> Flx_cil_cabs.attribute list
73: val visit_cabsName: cabsVisitor -> nameKind
74: -> Flx_cil_cabs.specifier -> Flx_cil_cabs.name -> Flx_cil_cabs.name
75: val visit_cabsFile: cabsVisitor -> Flx_cil_cabs.file -> Flx_cil_cabs.file
76:
77:
78:
79: (** Set by the visitor to the current location *)
80: val visitorLocation: Flx_cil_cabs.cabsloc ref
Start ocaml section to src/flx_cil_clexer.mli[1
/1
]
1: # 1123 "./lpsrc/flx_frontc.ipk"
2:
3:
4: (* This interface is generated manually. The corresponding .ml file is
5: * generated automatically and is placed in ../obj/clexer.ml. The reason we
6: * want this interface is to avoid confusing make with freshly generated
7: * interface files *)
8:
9:
10: val init: filename:string -> lang:Flx_cil_cabs.lang_t -> Lexing.lexbuf
11: val finish: unit -> unit
12:
13: (* This is the main parser function *)
14: val initial: Lexing.lexbuf -> Flx_cil_cparser.token
15:
16:
17: val push_context: unit -> unit (* Start a context *)
18: val add_type: string -> unit (* Add a new string as a type name *)
19: val add_identifier: string -> unit (* Add a new string as a variable name *)
20: val pop_context: unit -> unit (* Remove all names added in this context *)
21:
Start data section to src/flx_cil_clexer.mll[1
/1
]
1: (* FrontC -- lexical analyzer
2: **
3: ** 1.0 3.22.99 Hugues Cassé First version.
4: ** 2.0 George Necula 12/12/00: Many extensions
5: *)
6: {
7: open Flx_cil_cparser
8: open Flx_cil_pretty
9: exception Eof
10: exception InternalError of string
11: module E = Flx_cil_errormsg
12: module H = Hashtbl
13:
14: let currentLoc () =
15: let l, f, c = E.getPosition () in
16: { Flx_cil_cabs.lineno = l;
17: Flx_cil_cabs.filename = f;
18: Flx_cil_cabs.byteno = c; }
19:
20: (* Some debugging support for line numbers *)
21: let dbgToken (t: token) =
22: if false then begin
23: ignore (E.log "%a" insert
24: (match t with
25: IDENT (n, l) -> dprintf "IDENT(%s,%d)\n" n l.Flx_cil_cabs.lineno
26: | LBRACE l -> dprintf "LBRACE(%d)\n" l.Flx_cil_cabs.lineno
27: | RBRACE l -> dprintf "RBRACE(%d)\n" l.Flx_cil_cabs.lineno
28: | IF l -> dprintf "IF(%d)\n" l.Flx_cil_cabs.lineno
29: | SWITCH l -> dprintf "SWITCH(%d)\n" l.Flx_cil_cabs.lineno
30: | RETURN l -> dprintf "RETURN(%d)\n" l.Flx_cil_cabs.lineno
31: | _ -> nil));
32: t
33: end else
34: t
35:
36: (*
37: ** Keyword hashtable
38: *)
39:
40: let c_keywords =
41: [
42: ("_Bool", fun loc -> BOOL loc);
43: ("_Imaginary", fun loc -> IMAGINARY loc);
44: ("_Complex", fun loc -> COMPLEX loc);
45: ("auto", fun loc -> AUTO loc);
46: ("const", fun loc -> CONST loc);
47: ("__const", fun loc -> CONST loc);
48: ("__const__", fun loc -> CONST loc);
49: ("static", fun loc -> STATIC loc);
50: ("extern", fun loc -> EXTERN loc);
51: ("long", fun loc -> LONG loc);
52: ("short", fun loc -> SHORT loc);
53: ("register", fun loc -> REGISTER loc);
54: ("signed", fun loc -> SIGNED loc);
55: ("__signed", fun loc -> SIGNED loc);
56: ("unsigned", fun loc -> UNSIGNED loc);
57: ("volatile", fun loc -> VOLATILE loc);
58: ("__volatile", fun loc -> VOLATILE loc);
59: (* WW: see /usr/include/sys/cdefs.h for why __signed and __volatile
60: * are accepted GCC-isms *)
61: ("char", fun loc -> CHAR loc);
62: ("int", fun loc -> INT loc);
63: ("float", fun loc -> FLOAT loc);
64: ("double", fun loc -> DOUBLE loc);
65: ("void", fun loc -> VOID loc);
66: ("enum", fun loc -> ENUM loc);
67: ("struct", fun loc -> STRUCT loc);
68: ("typedef", fun loc -> TYPEDEF loc);
69: ("union", fun loc -> UNION loc);
70: ("break", fun loc -> BREAK loc);
71: ("continue", fun loc -> CONTINUE loc);
72: ("goto", fun loc -> GOTO loc);
73: ("return", fun loc -> dbgToken (RETURN loc));
74: ("switch", fun loc -> dbgToken (SWITCH loc));
75: ("case", fun loc -> CASE loc);
76: ("default", fun loc -> DEFAULT loc);
77: ("while", fun loc -> WHILE loc);
78: ("do", fun loc -> DO loc);
79: ("for", fun loc -> FOR loc);
80: ("if", fun loc -> dbgToken (IF loc));
81: ("else", fun _ -> ELSE);
82: (*** Implementation specific keywords ***)
83: ("__signed__", fun loc -> SIGNED loc);
84: ("__inline__", fun loc -> INLINE loc);
85: ("inline", fun loc -> INLINE loc);
86: ("__inline", fun loc -> INLINE loc);
87: ("_inline", fun loc -> INLINE loc);
88: ("__attribute__", fun loc -> ATTRIBUTE loc);
89: ("__attribute", fun loc -> ATTRIBUTE loc);
90: ("__blockattribute__", fun _ -> BLOCKATTRIBUTE);
91: ("__blockattribute", fun _ -> BLOCKATTRIBUTE);
92: ("__asm__", fun loc -> ASM loc);
93: ("asm", fun loc -> ASM loc);
94: ("__typeof__", fun loc -> TYPEOF loc);
95: ("__typeof", fun loc -> TYPEOF loc);
96: ("typeof", fun loc -> TYPEOF loc);
97: ("__alignof", fun loc -> ALIGNOF loc);
98: ("__alignof__", fun loc -> ALIGNOF loc);
99: ("__volatile__", fun loc -> VOLATILE loc);
100: ("__volatile", fun loc -> VOLATILE loc);
101:
102: ("__FUNCTION__", fun loc -> FUNCTION__ loc);
103: ("__func__", fun loc -> FUNCTION__ loc); (* ISO 6.4.2.2 *)
104: ("__PRETTY_FUNCTION__", fun loc -> PRETTY_FUNCTION__ loc);
105: ("__label__", fun _ -> LABEL__);
106: (*** weimer: GCC arcana ***)
107: ("__restrict", fun loc -> RESTRICT loc);
108: ("restrict", fun loc -> RESTRICT loc);
109: (* ("__extension__", EXTENSION); *)
110: (**** MS VC ***)
111: ("__int64", fun _ -> INT64 (currentLoc ()));
112: ("__int32", fun loc -> INT loc);
113: ("_cdecl", fun _ -> MSATTR ("_cdecl", currentLoc ()));
114: ("__cdecl", fun _ -> MSATTR ("__cdecl", currentLoc ()));
115: ("_stdcall", fun _ -> MSATTR ("_stdcall", currentLoc ()));
116: ("__stdcall", fun _ -> MSATTR ("__stdcall", currentLoc ()));
117: ("_fastcall", fun _ -> MSATTR ("_fastcall", currentLoc ()));
118: ("__fastcall", fun _ -> MSATTR ("__fastcall", currentLoc ()));
119: ("__w64", fun _ -> MSATTR("__w64", currentLoc ()));
120: ("__declspec", fun loc -> DECLSPEC loc);
121: ("__forceinline", fun loc -> INLINE loc); (* !! we turn forceinline
122: * into inline *)
123: ("__try", fun loc -> TRY loc);
124: ("__except", fun loc -> EXCEPT loc);
125: ("__finally", fun loc -> FINALLY loc);
126: (* weimer: some files produced by 'GCC -E' expect this type to be
127: * defined *)
128: ("__builtin_va_list",
129: fun _ -> NAMED_TYPE ("__builtin_va_list", currentLoc ()));
130: ("__builtin_va_arg", fun loc -> BUILTIN_VA_ARG loc);
131: (* On some versions of GCC __thread is a regular identifier *)
132: ("__thread", fun loc ->
133: if Flx_cil_machdep.__thread_is_keyword then
134: THREAD loc
135: else
136: IDENT ("__thread", loc));
137: ]
138:
139: let cxx_extra_keywords = [
140: ("class", fun loc -> CLASS loc);
141: ("namespace", fun loc -> NAMESPACE loc);
142: ("using", fun loc -> USING loc);
143: ("typename", fun loc -> TYPENAME loc);
144: ("templatename", fun loc -> TEMPLATENAME loc);
145: ("public", fun loc -> PUBLIC loc);
146: ("private", fun loc -> PRIVATE loc);
147: ("protected", fun loc -> PROTECTED loc);
148: ("virtual", fun loc -> VIRTUAL loc);
149: ]
150:
151: let lexicon = H.create 211
152: let class_list = ref [""]
153:
154: let init_lexicon (langind : Flx_cil_cabs.lang_t) =
155: H.clear lexicon;
156: List.iter
157: (fun (key, builder) -> H.add lexicon key builder)
158: c_keywords
159: ;
160: if langind = `Cxx then
161: List.iter
162: (fun (key, builder) -> H.add lexicon key builder)
163: cxx_extra_keywords
164: ;
165: class_list := [""]
166:
167: let push_class s = class_list := s :: !class_list
168: let pop_class () = class_list := List.tl !class_list
169:
170: (* Mark an identifier as a type name. The old mapping is preserved and will
171: * be reinstated when we exit this context *)
172: let add_type name =
173: (* ignore (print_string ("adding type name " ^ name ^ "\n")); *)
174: H.add lexicon name (fun loc -> NAMED_TYPE (name, loc))
175:
176: let context : string list list ref = ref []
177:
178: let push_context _ = context := []::!context
179:
180: let pop_context _ =
181: match !context with
182: [] -> raise (InternalError "Empty context stack")
183: | con::sub ->
184: (context := sub;
185: List.iter (fun name ->
186: (* ignore (print_string ("removing lexicon for " ^ name ^ "\n")); *)
187: H.remove lexicon name) con)
188:
189: (* Mark an identifier as a variable name. The old mapping is preserved and
190: * will be reinstated when we exit this context *)
191: let add_identifier name =
192: match !context with
193: [] -> () (* Just ignore raise (InternalError "Empty context stack") *)
194: | con::sub ->
195: (context := (name::con)::sub;
196: (* print_string ("adding IDENT for " ^ name ^ "\n"); *)
197: H.add lexicon name (fun loc ->
198: dbgToken (IDENT (name, loc))))
199:
200:
201: (*
202: ** Useful primitives
203: *)
204: let scan_ident id =
205: let here = currentLoc () in
206: let s = ref "" in
207: for i = 0 to String.length id - 1 do
208: let ch = id.[i] in
209: if ch > ' ' then s := !s ^ String.make 1 ch
210: done;
211: try (H.find lexicon !s) here
212: (* default to variable name, as opposed to type *)
213: with Not_found -> dbgToken (IDENT (!s, here))
214:
215:
216: (*
217: ** Buffer processor
218: *)
219:
220: let attribDepth = ref 0 (* Remembers the nesting level when parsing
221: * attributes *)
222:
223:
224: let init ~(filename: string) ~(lang: Flx_cil_cabs.lang_t) : Lexing.lexbuf =
225: attribDepth := 0;
226: init_lexicon lang;
227: (* Inititialize the pointer in Flx_cil_errormsg *)
228: Flx_cil_lexerhack.add_type := add_type;
229: Flx_cil_lexerhack.push_context := push_context;
230: Flx_cil_lexerhack.pop_context := pop_context;
231: Flx_cil_lexerhack.push_class:= push_class;
232: Flx_cil_lexerhack.pop_class := pop_class;
233: Flx_cil_lexerhack.add_identifier := add_identifier;
234: let get_lang () = lang in
235: Flx_cil_lexerhack.get_lang := get_lang;
236: E.startParsing filename
237:
238:
239: let finish () =
240: E.finishParsing ()
241:
242: (*** Error handling ***)
243: let error msg =
244: E.parse_error msg
245:
246:
247: (*** escape character management ***)
248: let scan_escape (char: char) : int64 =
249: let result = match char with
250: 'n' -> '\n'
251: | 'r' -> '\r'
252: | 't' -> '\t'
253: | 'b' -> '\b'
254: | 'f' -> '\012' (* ASCII code 12 *)
255: | 'v' -> '\011' (* ASCII code 11 *)
256: | 'a' -> '\007' (* ASCII code 7 *)
257: | 'e' -> '\027' (* ASCII code 27. This is a GCC extension *)
258: | '\'' -> '\''
259: | '"'-> '"' (* '"' *)
260: | '?' -> '?'
261: | '\\' -> '\\'
262: | other -> error ("Unrecognized escape sequence: \\" ^ (String.make 1 other))
263: in
264: Int64.of_int (Char.code result)
265:
266: let scan_hex_escape str =
267: let radix = Int64.of_int 16 in
268: let the_value = ref Int64.zero in
269: (* start at character 2 to skip the \x *)
270: for i = 2 to (String.length str) - 1 do
271: let thisDigit = Flx_cil_cabs_helper.valueOfDigit (String.get str i) in
272: (* the_value := !the_value * 16 + thisDigit *)
273: the_value := Int64.add (Int64.mul !the_value radix) thisDigit
274: done;
275: !the_value
276:
277: let scan_oct_escape str =
278: let radix = Int64.of_int 8 in
279: let the_value = ref Int64.zero in
280: (* start at character 1 to skip the \x *)
281: for i = 1 to (String.length str) - 1 do
282: let thisDigit = Flx_cil_cabs_helper.valueOfDigit (String.get str i) in
283: (* the_value := !the_value * 8 + thisDigit *)
284: the_value := Int64.add (Int64.mul !the_value radix) thisDigit
285: done;
286: !the_value
287:
288: let lex_hex_escape remainder lexbuf =
289: let prefix = scan_hex_escape (Lexing.lexeme lexbuf) in
290: prefix :: remainder lexbuf
291:
292: let lex_oct_escape remainder lexbuf =
293: let prefix = scan_oct_escape (Lexing.lexeme lexbuf) in
294: prefix :: remainder lexbuf
295:
296: let lex_simple_escape remainder lexbuf =
297: let lexchar = Lexing.lexeme_char lexbuf 1 in
298: let prefix = scan_escape lexchar in
299: prefix :: remainder lexbuf
300:
301: let lex_unescaped remainder lexbuf =
302: let prefix = Int64.of_int (Char.code (Lexing.lexeme_char lexbuf 0)) in
303: prefix :: remainder lexbuf
304:
305: let make_char (i:int64):char =
306: let min_val = Int64.zero in
307: let max_val = Int64.of_int 255 in
308: (* if i < 0 || i > 255 then error*)
309: if compare i min_val < 0 || compare i max_val > 0 then begin
310: let msg = Printf.sprintf "clexer:make_char: character 0x%Lx too big" i in
311: error msg
312: end;
313: Char.chr (Int64.to_int i)
314:
315:
316: (* ISO standard locale-specific function to convert a wide character
317: * into a sequence of normal characters. Here we work on strings.
318: * We convert L"Hi" to "H\000i\000"
319: matth: this seems unused.
320: let wbtowc wstr =
321: let len = String.length wstr in
322: let dest = String.make (len * 2) '\000' in
323: for i = 0 to len-1 do
324: dest.[i*2] <- wstr.[i] ;
325: done ;
326: dest
327: *)
328:
329: (* This function converst the "Hi" in L"Hi" to { L'H', L'i', L'\0' }
330: matth: this seems unused.
331: let wstr_to_warray wstr =
332: let len = String.length wstr in
333: let res = ref "{ " in
334: for i = 0 to len-1 do
335: res := !res ^ (Printf.sprintf "L'%c', " wstr.[i])
336: done ;
337: res := !res ^ "}" ;
338: !res
339: *)
340:
341: (* Pragmas get explicit end-of-line tokens.
342: * Elsewhere they are silently discarded as whitespace. *)
343: let pragmaLine = ref false
344:
345: }
346:
347: let decdigit = ['0'-'9']
348: let octdigit = ['0'-'7']
349: let hexdigit = ['0'-'9' 'a'-'f' 'A'-'F']
350: let letter = ['a'- 'z' 'A'-'Z']
351:
352:
353: let usuffix = ['u' 'U']
354: let lsuffix = "l"|"L"|"ll"|"LL"
355: let intsuffix = lsuffix | usuffix | usuffix lsuffix | lsuffix usuffix
356:
357: let hexprefix = '0' ['x' 'X']
358:
359: let intnum = decdigit+ intsuffix?
360: let octnum = '0' octdigit+ intsuffix?
361: let hexnum = hexprefix hexdigit+ intsuffix?
362:
363: let exponent = ['e' 'E']['+' '-']? decdigit+
364: let fraction = '.' decdigit+
365: let decfloat = (intnum? fraction)
366: |(intnum exponent)
367: |(intnum? fraction exponent)
368: | (intnum '.')
369: | (intnum '.' exponent)
370:
371: let hexfraction = hexdigit* '.' hexdigit+ | hexdigit+
372: let binexponent = ['p' 'P'] ['+' '-']? decdigit+
373: let hexfloat = hexprefix hexfraction binexponent
374: | hexprefix hexdigit+ binexponent
375:
376: let floatsuffix = ['f' 'F' 'l' 'L']
377: let floatnum = (decfloat | hexfloat) floatsuffix?
378:
379: let ident = (letter|'_')(letter|decdigit|'_')*
380: let attribident = (letter|'_')(letter|decdigit|'_'|':')
381: let blank = [' ' '\t' '\012' '\r']+
382: let spaces = [' ' '\t' '\012' '\r']*
383: let escape = '\\' _
384: let hex_escape = '\\' ['x' 'X'] hexdigit+
385: let oct_escape = '\\' octdigit octdigit? octdigit?
386: let sym =
387: "<<=" | ">>=" |
388: "<<" | ">>" | "==" | "!=" | "<=" | ">=" |
389: "+=" | "-=" | "*=" | "/=" | "%=" | "&=" | "|=" | "^=" | "->" |
390: "+" | "-" | "*" | "/" | "%" | "&" | "|" | "^" | "!" | "~" | "="
391:
392:
393: let operator = "operator" spaces sym
394: let oident = operator | ident
395: let qualified_name = ("::" spaces)?oident (spaces "::" spaces oident)*
396:
397: rule initial = parse
398: | "/*" { let _ = comment lexbuf in initial lexbuf}
399: | "//" { endline lexbuf }
400: | blank {initial lexbuf}
401: | '\n' { E.newline ();
402: if !pragmaLine then
403: begin
404: pragmaLine := false;
405: PRAGMA_EOL
406: end
407: else
408: initial lexbuf }
409: | '#' { hash lexbuf}
410: | "_Pragma" { PRAGMA (currentLoc ()) }
411: | '\'' { CST_CHAR (chr lexbuf, currentLoc ())}
412: | "L'" { CST_WCHAR (chr lexbuf, currentLoc ()) }
413: | '"' { (* '"' *)
414: (* matth: BUG: this could be either a regular string or a wide string.
415: * e.g. if it's the "world" in
416: * L"Hello, " "world"
417: * then it should be treated as wide even though there's no L immediately
418: * preceding it. See test/small1/wchar5.c for a failure case. *)
419: try CST_STRING (str lexbuf, currentLoc ())
420: with e ->
421: raise (InternalError
422: ("str: " ^
423: Printexc.to_string e))}
424: | "L\"" { (* weimer: wchar_t string literal *)
425: try CST_WSTRING(str lexbuf, currentLoc ())
426: with e ->
427: raise (InternalError
428: ("wide string: " ^
429: Printexc.to_string e))}
430: | floatnum {CST_FLOAT (Lexing.lexeme lexbuf, currentLoc ())}
431: | hexnum {CST_INT (Lexing.lexeme lexbuf, currentLoc ())}
432: | octnum {CST_INT (Lexing.lexeme lexbuf, currentLoc ())}
433: | intnum {CST_INT (Lexing.lexeme lexbuf, currentLoc ())}
434: | "!quit!" {EOF}
435: | "..." {ELLIPSIS}
436: | "+=" {PLUS_EQ}
437: | "-=" {MINUS_EQ}
438: | "*=" {STAR_EQ}
439: | "/=" {SLASH_EQ}
440: | "%=" {PERCENT_EQ}
441: | "|=" {PIPE_EQ}
442: | "&=" {AND_EQ}
443: | "^=" {CIRC_EQ}
444: | "<<=" {INF_INF_EQ}
445: | ">>=" {SUP_SUP_EQ}
446: | "<<" {INF_INF}
447: | ">>" {SUP_SUP}
448: | "==" {EQ_EQ}
449: | "!=" {EXCLAM_EQ}
450: | "<=" {INF_EQ}
451: | ">=" {SUP_EQ}
452: | "=" {EQ}
453: | "<" {INF}
454: | ">" {SUP}
455: | "++" {PLUS_PLUS (currentLoc ())}
456: | "--" {MINUS_MINUS (currentLoc ())}
457: | "->" {ARROW}
458: | '+' {PLUS (currentLoc ())}
459: | '-' {MINUS (currentLoc ())}
460: | '*' {STAR (currentLoc ())}
461: | '/' {SLASH}
462: | '%' {PERCENT}
463: | '!' {EXCLAM (currentLoc ())}
464: | "&&" {AND_AND (currentLoc ())}
465: | "||" {PIPE_PIPE}
466: | '&' {AND (currentLoc ())}
467: | '|' {PIPE}
468: | '^' {CIRC}
469: | '?' {QUEST}
470: | ':' {COLON}
471: | '~' {TILDE (currentLoc ())}
472:
473: | '{' {dbgToken (LBRACE (currentLoc ()))}
474: | '}' {dbgToken (RBRACE (currentLoc ()))}
475: | '[' {LBRACKET}
476: | ']' {RBRACKET}
477: | '(' {dbgToken (LPAREN (currentLoc ())) }
478: | ')' {RPAREN}
479: | ';' {dbgToken (SEMICOLON (currentLoc ())) }
480: | ',' {COMMA}
481: | '.' {DOT}
482: | "sizeof" {SIZEOF (currentLoc ())}
483: | "__asm" { if !Flx_cil_cprint.msvcMode then
484: MSASM (msasm lexbuf, currentLoc ())
485: else (ASM (currentLoc ())) }
486: (* jms: a hack to change unsigned int to plain unsigned to fix
487: an shift/reduce parsing problem
488: with C++ class base list/unnamed bitfield *)
489:
490: | "unsigned" (' '|'\t')+ "int" {UNSIGNED (currentLoc())}
491:
492: (* sm: tree transformation keywords *)
493: | "@transform" {AT_TRANSFORM (currentLoc ())}
494: | "@transformExpr" {AT_TRANSFORMEXPR (currentLoc ())}
495: | "@specifier" {AT_SPECIFIER (currentLoc ())}
496: | "@expr" {AT_EXPR (currentLoc ())}
497: | "@name" {AT_NAME}
498:
499: (* __extension__ is a black. The parser runs into some conflicts if we let it
500: * pass *)
501: | "__extension__" {initial lexbuf }
502: | qualified_name
503: {
504: scan_ident (Lexing.lexeme lexbuf)
505: }
506: | eof {EOF}
507: | _ {E.parse_error
508: "Invalid symbol"
509: (Lexing.lexeme_start lexbuf)
510: (Lexing.lexeme_end lexbuf);
511: initial lexbuf}
512: and comment =
513: parse
514: "*/" { () }
515: | '\n' { E.newline (); comment lexbuf }
516: | _ { comment lexbuf }
517:
518: (* # <line number> <file name> ... *)
519: and hash = parse
520: '\n' { E.newline (); initial lexbuf}
521: | blank { hash lexbuf}
522: | intnum { (* We are seeing a line number. This is the number for the
523: * next line *)
524: E.setCurrentLine (int_of_string (Lexing.lexeme lexbuf) - 1);
525: (* A file name must follow *)
526: file lexbuf }
527: | "line" { hash lexbuf } (* MSVC line number info *)
528: (* MSVC warning pragmas have very irregular syntax. We parse
529: * them as a whole line. *)
530: | "pragma" blank "warning" { let here = currentLoc () in
531: PRAGMA_LINE ("warning" ^ pragma lexbuf, here)
532: }
533: | "pragma" blank "GCC" { let here = currentLoc () in
534: PRAGMA_LINE ("GCC" ^ pragma lexbuf, here)
535: }
536: | "pragma" { pragmaLine := true; PRAGMA (currentLoc ()) }
537: | _ { endline lexbuf}
538:
539: and file = parse
540: '\n' {E.newline (); initial lexbuf}
541: | blank {file lexbuf}
542: | '"' [^ '\012' '\t' '"']* '"' { (* '"' *)
543: let n = Lexing.lexeme lexbuf in
544: let n1 = String.sub n 1
545: ((String.length n) - 2) in
546: E.setCurrentFile n1;
547: endline lexbuf}
548:
549: | _ {endline lexbuf}
550:
551: and endline = parse
552: '\n' { E.newline (); initial lexbuf}
553: | eof { EOF }
554: | _ { endline lexbuf}
555:
556: and pragma = parse
557: '\n' { E.newline (); "" }
558: | _ { let cur = Lexing.lexeme lexbuf in
559: cur ^ (pragma lexbuf) }
560:
561: and str = parse
562: '"' {[]} (* no nul terminiation in CST_STRING *)
563: | hex_escape {lex_hex_escape str lexbuf}
564: | oct_escape {lex_oct_escape str lexbuf}
565: | escape {lex_simple_escape str lexbuf}
566: | _ {lex_unescaped str lexbuf}
567:
568: and chr = parse
569: '\'' {[]}
570: | hex_escape {lex_hex_escape chr lexbuf}
571: | oct_escape {lex_oct_escape chr lexbuf}
572: | escape {lex_simple_escape chr lexbuf}
573: | _ {lex_unescaped chr lexbuf}
574:
575: and msasm = parse
576: blank { msasm lexbuf }
577: | '{' { msasminbrace lexbuf }
578: | _ { let cur = Lexing.lexeme lexbuf in
579: cur ^ (msasmnobrace lexbuf) }
580:
581: and msasminbrace = parse
582: '}' { "" }
583: | _ { let cur = Lexing.lexeme lexbuf in
584: cur ^ (msasminbrace lexbuf) }
585: and msasmnobrace = parse
586: ['}' ';' '\n'] { lexbuf.Lexing.lex_curr_pos <-
587: lexbuf.Lexing.lex_curr_pos - 1;
588: "" }
589: | "__asm" { lexbuf.Lexing.lex_curr_pos <-
590: lexbuf.Lexing.lex_curr_pos - 5;
591: "" }
592: | _ { let cur = Lexing.lexeme lexbuf in
593:
594: cur ^ (msasmnobrace lexbuf) }
595:
596: and attribute = parse
597: '\n' { E.newline (); attribute lexbuf }
598: | blank { attribute lexbuf }
599: | '(' { incr attribDepth; LPAREN (currentLoc ()) }
600: | ')' { decr attribDepth;
601: if !attribDepth = 0 then
602: initial lexbuf (* Skip the last closed paren *)
603: else
604: RPAREN }
605: | attribident { IDENT (Lexing.lexeme lexbuf, currentLoc ()) }
606:
607: | '\'' { CST_CHAR (chr lexbuf, currentLoc ())}
608: | '"' { (* '"' *)
609: try CST_STRING (str lexbuf, currentLoc ())
610: with e ->
611: raise (InternalError "str")}
612: | floatnum {CST_FLOAT (Lexing.lexeme lexbuf, currentLoc ())}
613: | hexnum {CST_INT (Lexing.lexeme lexbuf, currentLoc ())}
614: | octnum {CST_INT (Lexing.lexeme lexbuf, currentLoc ())}
615: | intnum {CST_INT (Lexing.lexeme lexbuf, currentLoc ())}
616:
617:
618: {
619:
620: }
621:
Start data section to src/flx_cil_cparser.mly[1
/1
]
1: /*
2: (**
3: ** 1.0 3.22.99 Hugues Cassé First version.
4: ** 2.0 George Necula 12/12/00: Many extensions
5: *)
6: */
7: %{
8: open Flx_cil_cabs
9: open Flx_cil_cabs_helper
10: module E = Flx_cil_errormsg
11:
12: let parse_error msg : unit = (* sm: c++-mode highlight hack: -> ' <- *)
13: E.parse_error msg
14:
15: let print = print_string
16:
17:
18: let currentLoc () =
19: let l, f, c = E.getPosition () in
20: { lineno = l; filename = f; byteno = c; }
21:
22: let cabslu = {lineno = -10; filename = "cabs loc unknown"; byteno = -10;}
23:
24: (*
25: ** Expression building
26: *)
27: let smooth_expression lst =
28: match lst with
29: [] -> NOTHING
30: | [expr] -> expr
31: | _ -> COMMA (lst)
32:
33:
34: let currentFunctionName = ref "<outside any function>"
35:
36: let announceFunctionName ((n, decl, _, _):name) =
37: !Flx_cil_lexerhack.add_identifier n;
38: (* Start a context that includes the parameter names and the whole body.
39: * Will pop when we finish parsing the function body *)
40: !Flx_cil_lexerhack.push_context ();
41: (* Go through all the parameter names and mark them as identifiers *)
42: let rec findProto = function
43: PROTO (d, args, _) when isJUSTBASE d ->
44: List.iter (fun (_, (an, _, _, _)) -> !Flx_cil_lexerhack.add_identifier an) args
45:
46: | PROTO (d, _, _) -> findProto d
47: | PARENTYPE (_, d, _) -> findProto d
48: | PTR (_, d) -> findProto d
49: | ARRAY (d, _, _) -> findProto d
50: | _ -> parse_error "Cannot find the prototype in a function definition";
51: raise Parsing.Parse_error
52:
53: and isJUSTBASE = function
54: JUSTBASE -> true
55: | PARENTYPE (_, d, _) -> isJUSTBASE d
56: | _ -> false
57: in
58: findProto decl;
59: currentFunctionName := n
60:
61:
62:
63: let applyPointer (ptspecs: attribute list list) (dt: decl_type)
64: : decl_type =
65: (* Outer specification first *)
66: let rec loop = function
67: [] -> dt
68: | attrs :: rest -> PTR(attrs, loop rest)
69: in
70: loop ptspecs
71:
72: let doDeclaration (loc: cabsloc) (specs: spec_elem list) (nl: init_name list) : definition =
73: if isTypedef specs then begin
74: (* Tell the lexer about the new type names *)
75: List.iter (fun ((n, _, _, _), _) -> !Flx_cil_lexerhack.add_type n) nl;
76: TYPEDEF ((specs, List.map (fun (n, _) -> n) nl), loc)
77: end else
78: if nl = [] then
79: ONLYTYPEDEF (specs, loc)
80: else begin
81: (* Tell the lexer about the new variable names *)
82: List.iter (fun ((n, _, _, _), _) -> !Flx_cil_lexerhack.add_identifier n) nl;
83: DECDEF ((specs, nl), loc)
84: end
85:
86:
87: let doFunctionDef (loc: cabsloc)
88: (lend: cabsloc)
89: (specs: spec_elem list)
90: (n: name)
91: (b: block) : definition =
92: let fname = (specs, n) in
93: FUNDEF (fname, b, loc, lend)
94:
95:
96: let doOldParDecl (names: string list)
97: ((pardefs: name_group list), (isva: bool))
98: : single_name list * bool =
99: let findOneName n =
100: (* Search in pardefs for the definition for this parameter *)
101: let rec loopGroups = function
102: [] -> ([SpecType Tint], (n, JUSTBASE, [], cabslu))
103: | (specs, names) :: restgroups ->
104: let rec loopNames = function
105: [] -> loopGroups restgroups
106: | ((n',_, _, _) as sn) :: _ when n' = n -> (specs, sn)
107: | _ :: restnames -> loopNames restnames
108: in
109: loopNames names
110: in
111: loopGroups pardefs
112: in
113: let args = List.map findOneName names in
114: (args, isva)
115:
116: let checkConnective (s : string) : unit =
117: begin
118: (* checking this means I could possibly have more connectives, with *)
119: (* different meaning *)
120: if (s <> "to") then (
121: parse_error "transformer connective must be 'to'";
122: raise Parsing.Parse_error
123: )
124: else ()
125: end
126:
127: (* takes a not-nul-terminated list, and converts it to a string. *)
128: let rec intlist_to_string (str: int64 list):string =
129: match str with
130: [] -> "" (* add nul-termination *)
131: | value::rest ->
132: let this_char =
133: if (compare value (Int64.of_int 255) > 0)
134: || (compare value Int64.zero < 0)
135: then begin
136: let msg = Printf.sprintf "cparser:intlist_to_string: character 0x%Lx too big" value in
137: parse_error msg;
138: raise Parsing.Parse_error
139: end
140: else
141: String.make 1 (Char.chr (Int64.to_int value))
142: in
143: this_char ^ (intlist_to_string rest)
144:
145: let fst3 (result, _, _) = result
146: let snd3 (_, result, _) = result
147: let trd3 (_, _, result) = result
148:
149: let mkflds accessible ls =
150: let accessible = ref accessible in
151: let nls = ref [] in
152: List.iter
153: (fun x -> match x with
154: | `Fields x -> if !accessible then nls := x :: !nls
155: | `Access_public -> accessible := true
156: | `Access_private | `Access_protected -> accessible := false
157: )
158: ls
159: ;
160: Some (List.rev !nls)
161:
162: %}
163:
164: %token <string * Flx_cil_cabs.cabsloc> IDENT
165: %token <int64 list * Flx_cil_cabs.cabsloc> CST_CHAR
166: %token <int64 list * Flx_cil_cabs.cabsloc> CST_WCHAR
167: %token <string * Flx_cil_cabs.cabsloc> CST_INT
168: %token <string * Flx_cil_cabs.cabsloc> CST_FLOAT
169: %token <string * Flx_cil_cabs.cabsloc> NAMED_TYPE
170:
171: /* Each character is its own list element, and the terminating nul is not
172: included in this list. */
173: %token <int64 list * Flx_cil_cabs.cabsloc> CST_STRING
174: %token <int64 list * Flx_cil_cabs.cabsloc> CST_WSTRING
175:
176: %token EOF
177: %token<Flx_cil_cabs.cabsloc> BOOL CHAR INT DOUBLE FLOAT COMPLEX IMAGINARY VOID INT64 INT32
178: %token<Flx_cil_cabs.cabsloc> ENUM STRUCT TYPEDEF UNION
179: %token<Flx_cil_cabs.cabsloc> SIGNED UNSIGNED LONG SHORT
180: %token<Flx_cil_cabs.cabsloc> VOLATILE EXTERN STATIC CONST RESTRICT AUTO REGISTER
181: %token<Flx_cil_cabs.cabsloc> THREAD
182: %token<Flx_cil_cabs.cabsloc> CLASS NAMESPACE USING
183: %token<Flx_cil_cabs.cabsloc> TYPENAME TEMPLATENAME
184: %token<Flx_cil_cabs.cabsloc> PUBLIC PRIVATE PROTECTED VIRTUAL
185:
186: %token<Flx_cil_cabs.cabsloc> SIZEOF ALIGNOF
187:
188: %token EQ PLUS_EQ MINUS_EQ STAR_EQ SLASH_EQ PERCENT_EQ
189: %token AND_EQ PIPE_EQ CIRC_EQ INF_INF_EQ SUP_SUP_EQ
190: %token ARROW DOT
191:
192: %token EQ_EQ EXCLAM_EQ INF SUP INF_EQ SUP_EQ
193: %token<Flx_cil_cabs.cabsloc> PLUS MINUS STAR
194: %token SLASH PERCENT
195: %token<Flx_cil_cabs.cabsloc> TILDE AND
196: %token PIPE CIRC
197: %token<Flx_cil_cabs.cabsloc> EXCLAM AND_AND
198: %token PIPE_PIPE
199: %token INF_INF SUP_SUP
200: %token<Flx_cil_cabs.cabsloc> PLUS_PLUS MINUS_MINUS
201:
202: %token RPAREN
203: %token<Flx_cil_cabs.cabsloc> LPAREN RBRACE
204: %token<Flx_cil_cabs.cabsloc> LBRACE
205: %token LBRACKET RBRACKET
206: %token COLON XCOLON
207: %token<Flx_cil_cabs.cabsloc> SEMICOLON
208: %token COMMA ELLIPSIS QUEST
209:
210: %token<Flx_cil_cabs.cabsloc> BREAK CONTINUE GOTO RETURN
211: %token<Flx_cil_cabs.cabsloc> SWITCH CASE DEFAULT
212: %token<Flx_cil_cabs.cabsloc> WHILE DO FOR
213: %token<Flx_cil_cabs.cabsloc> IF TRY EXCEPT FINALLY
214: %token ELSE
215:
216: %token<Flx_cil_cabs.cabsloc> ATTRIBUTE INLINE ASM TYPEOF FUNCTION__ PRETTY_FUNCTION__
217: %token LABEL__
218: %token<Flx_cil_cabs.cabsloc> BUILTIN_VA_ARG
219: %token BUILTIN_VA_LIST
220: %token BLOCKATTRIBUTE
221: %token<Flx_cil_cabs.cabsloc> DECLSPEC
222: %token<string * Flx_cil_cabs.cabsloc> MSASM MSATTR
223: %token<Flx_cil_cabs.cabsloc> PRAGMA
224: %token<string * Flx_cil_cabs.cabsloc> PRAGMA_LINE
225: %token PRAGMA_EOL
226:
227: /* sm: cabs tree transformation specification keywords */
228: %token<Flx_cil_cabs.cabsloc> AT_TRANSFORM AT_TRANSFORMEXPR AT_SPECIFIER AT_EXPR
229: %token AT_NAME
230:
231: /* operator precedence */
232: %nonassoc IF
233: %nonassoc ELSE
234:
235:
236: %left COMMA
237: %right EQ PLUS_EQ MINUS_EQ STAR_EQ SLASH_EQ PERCENT_EQ
238: AND_EQ PIPE_EQ CIRC_EQ INF_INF_EQ SUP_SUP_EQ
239: %right QUEST COLON
240: %left PIPE_PIPE
241: %left AND_AND
242: %left PIPE
243: %left CIRC
244: %left AND
245: %left EQ_EQ EXCLAM_EQ
246: %left INF SUP INF_EQ SUP_EQ
247: %left INF_INF SUP_SUP
248: %left PLUS MINUS
249: %left STAR SLASH PERCENT CONST RESTRICT VOLATILE
250: %right EXCLAM TILDE PLUS_PLUS MINUS_MINUS CAST RPAREN ADDROF SIZEOF ALIGNOF
251: %left LBRACKET
252: %left DOT ARROW LPAREN LBRACE
253: %right NAMED_TYPE /* We'll use this to handle redefinitions of
254: * NAMED_TYPE as variables */
255: %left IDENT
256:
257: /* Non-terminals informations */
258: %start interpret file
259: %type <Flx_cil_cabs.definition list> file interpret globals
260:
261: %type <Flx_cil_cabs.definition> global
262:
263:
264: %type <Flx_cil_cabs.attribute list> attributes attributes_with_asm asmattr
265: %type <Flx_cil_cabs.statement> statement
266: %type <Flx_cil_cabs.constant * cabsloc> constant
267: %type <string * cabsloc> string_constant
268: %type <Flx_cil_cabs.expression * cabsloc> expression
269: %type <Flx_cil_cabs.expression> opt_expression
270: %type <Flx_cil_cabs.init_expression> init_expression
271: %type <Flx_cil_cabs.expression list * cabsloc> comma_expression
272: %type <Flx_cil_cabs.expression list * cabsloc> paren_comma_expression
273: %type <Flx_cil_cabs.expression list> arguments
274: %type <Flx_cil_cabs.expression list> bracket_comma_expression
275: %type <int64 list * cabsloc> string_list
276: %type <int64 list * cabsloc> wstring_list
277:
278: %type <Flx_cil_cabs.initwhat * Flx_cil_cabs.init_expression> initializer
279: %type <(Flx_cil_cabs.initwhat * Flx_cil_cabs.init_expression) list> initializer_list
280: %type <Flx_cil_cabs.initwhat> init_designators init_designators_opt
281:
282: %type <spec_elem list * cabsloc> decl_spec_list
283: %type <typeSpecifier * cabsloc> type_spec
284: /* %type <Flx_cil_cabs.field_group list> struct_decl_list */
285:
286:
287: %type <Flx_cil_cabs.name> old_proto_decl
288: %type <Flx_cil_cabs.single_name> parameter_decl
289: %type <Flx_cil_cabs.enum_item> enumerator
290: %type <Flx_cil_cabs.enum_item list> enum_list
291: %type <Flx_cil_cabs.definition> declaration function_def
292: %type <cabsloc * spec_elem list * name> function_def_start
293: %type <Flx_cil_cabs.spec_elem list * Flx_cil_cabs.decl_type> type_name
294: %type <Flx_cil_cabs.block * cabsloc * cabsloc> block
295: %type <Flx_cil_cabs.statement list> block_element_list
296: %type <string list> local_labels local_label_names
297: %type <string list> old_parameter_list_ne
298:
299: %type <Flx_cil_cabs.init_name> init_declarator
300: %type <Flx_cil_cabs.init_name list> init_declarator_list
301: %type <Flx_cil_cabs.name> declarator
302: %type <Flx_cil_cabs.name * expression option> field_decl
303: %type <(Flx_cil_cabs.name * expression option) list> field_decl_list
304: %type <string * Flx_cil_cabs.decl_type> direct_decl
305: %type <Flx_cil_cabs.decl_type> abs_direct_decl abs_direct_decl_opt
306: %type <Flx_cil_cabs.decl_type * Flx_cil_cabs.attribute list> abstract_decl
307:
308: /* (* Each element is a "* <type_quals_opt>". *) */
309: %type <attribute list list * cabsloc> pointer pointer_opt
310: %type <Flx_cil_cabs.cabsloc> location
311: %type <Flx_cil_cabs.spec_elem * cabsloc> cvspec
312: %%
313:
314: interpret:
315: | file EOF {$1}
316: ;
317: file: globals {$1}
318: ;
319: globals:
320: | /* empty */ { [] }
321: | global globals { $1 :: $2 }
322: | SEMICOLON globals { $2 }
323: ;
324:
325: location:
326: /* empty */ { currentLoc () } %prec IDENT
327:
328:
329: /*** Global Definition ***/
330: global:
331: | declaration { $1 }
332: | function_def { $1 }
333: /*(* Some C header files ar shared with the C++ compiler and have linkage
334: * specification *)*/
335: | EXTERN string_constant declaration { LINKAGE (fst $2, snd $2, [ $3 ]) }
336: | EXTERN string_constant LBRACE globals RBRACE
337: { LINKAGE (fst $2, snd $2, $4) }
338:
339: | NAMESPACE IDENT LBRACE globals RBRACE
340: { NAMESPACE (fst $2, snd $2, $4) }
341:
342: | ASM LPAREN string_constant RPAREN SEMICOLON
343: { GLOBASM (fst $3, $1) }
344: | PRAGMA attr PRAGMA_EOL { PRAGMA ($2, $1) }
345: | PRAGMA attr SEMICOLON PRAGMA_EOL { PRAGMA ($2, $1) }
346: | PRAGMA_LINE { PRAGMA (VARIABLE (fst $1),
347: snd $1) }
348: /* (* Old-style function prototype. This should be somewhere else, like in
349: * "declaration". For now we keep it at global scope only because in local
350: * scope it looks too much like a function call *) */
351:
352: | IDENT LPAREN old_parameter_list_ne RPAREN old_pardef_list SEMICOLON
353: { (* Convert pardecl to new style *)
354: let pardecl, isva = doOldParDecl $3 $5 in
355: (* Make the function declarator *)
356: doDeclaration (snd $1) []
357: [((fst $1, PROTO(JUSTBASE, pardecl,isva), [], cabslu),
358: NO_INIT)]
359: }
360: /* (* Old style function prototype, but without any arguments *) */
361: | IDENT LPAREN RPAREN SEMICOLON
362: { (* Make the function declarator *)
363: doDeclaration (snd $1) []
364: [((fst $1, PROTO(JUSTBASE,[],false), [], cabslu),
365: NO_INIT)]
366: }
367: /* transformer for a toplevel construct */
368: | AT_TRANSFORM LBRACE global RBRACE IDENT/*to*/ LBRACE globals RBRACE {
369: checkConnective(fst $5);
370: TRANSFORMER($3, $7, $1)
371: }
372: /* transformer for an expression */
373: | AT_TRANSFORMEXPR LBRACE expression RBRACE IDENT/*to*/ LBRACE expression RBRACE {
374: checkConnective(fst $5);
375: EXPRTRANSFORMER(fst $3, fst $7, $1)
376: }
377: | location error SEMICOLON { PRAGMA (VARIABLE "parse_error", $1) }
378: ;
379:
380: id_or_typename:
381: | IDENT {fst $1}
382: | NAMED_TYPE {fst $1}
383: | AT_NAME LPAREN IDENT RPAREN { "@name(" ^ fst $3 ^ ")" } /* pattern variable name */
384: ;
385:
386: maybecomma:
387: | /* empty */ { () }
388: | COMMA { () }
389: ;
390:
391: /* *** Expressions *** */
392:
393:
394: expression:
395: | constant
396: {CONSTANT (fst $1), snd $1}
397: | IDENT
398: {VARIABLE (fst $1), snd $1}
399: | SIZEOF expression
400: {EXPR_SIZEOF (fst $2), $1}
401: | SIZEOF LPAREN type_name RPAREN
402: {let b, d = $3 in TYPE_SIZEOF (b, d), $1}
403: | ALIGNOF expression
404: {EXPR_ALIGNOF (fst $2), $1}
405: | ALIGNOF LPAREN type_name RPAREN
406: {let b, d = $3 in TYPE_ALIGNOF (b, d), $1}
407: | PLUS expression
408: {UNARY (PLUS, fst $2), $1}
409: | MINUS expression
410: {UNARY (MINUS, fst $2), $1}
411: | STAR expression
412: {UNARY (MEMOF, fst $2), $1}
413: | AND expression %prec ADDROF
414: {UNARY (ADDROF, fst $2), $1}
415: | EXCLAM expression
416: {UNARY (NOT, fst $2), $1}
417: | TILDE expression
418: {UNARY (BNOT, fst $2), $1}
419: | PLUS_PLUS expression %prec CAST
420: {UNARY (PREINCR, fst $2), $1}
421: | expression PLUS_PLUS
422: {UNARY (POSINCR, fst $1), snd $1}
423: | MINUS_MINUS expression %prec CAST
424: {UNARY (PREDECR, fst $2), $1}
425: | expression MINUS_MINUS
426: {UNARY (POSDECR, fst $1), snd $1}
427: | expression ARROW id_or_typename
428: {MEMBEROFPTR (fst $1, $3), snd $1}
429: | expression DOT id_or_typename
430: {MEMBEROF (fst $1, $3), snd $1}
431: | LPAREN block RPAREN
432: { GNU_BODY (fst3 $2), $1 }
433: | paren_comma_expression
434: {smooth_expression (fst $1), snd $1}
435: | expression LPAREN arguments RPAREN
436: {CALL (fst $1, $3), snd $1}
437: | BUILTIN_VA_ARG LPAREN expression COMMA type_name RPAREN
438: { let b, d = $5 in
439: CALL (VARIABLE "__builtin_va_arg",
440: [fst $3; TYPE_SIZEOF (b, d)]), $1 }
441: | expression bracket_comma_expression
442: {INDEX (fst $1, smooth_expression $2), snd $1}
443: | expression QUEST opt_expression COLON expression
444: {QUESTION (fst $1, $3, fst $5), snd $1}
445: | expression PLUS expression
446: {BINARY(ADD, fst $1, fst $3), snd $1}
447: | expression MINUS expression
448: {BINARY(SUB, fst $1, fst $3), snd $1}
449: | expression STAR expression
450: {BINARY(MUL, fst $1, fst $3), snd $1}
451: | expression SLASH expression
452: {BINARY(DIV, fst $1, fst $3), snd $1}
453: | expression PERCENT expression
454: {BINARY(MOD, fst $1, fst $3), snd $1}
455: | expression AND_AND expression
456: {BINARY(AND, fst $1, fst $3), snd $1}
457: | expression PIPE_PIPE expression
458: {BINARY(OR, fst $1, fst $3), snd $1}
459: | expression AND expression
460: {BINARY(BAND, fst $1, fst $3), snd $1}
461: | expression PIPE expression
462: {BINARY(BOR, fst $1, fst $3), snd $1}
463: | expression CIRC expression
464: {BINARY(XOR, fst $1, fst $3), snd $1}
465: | expression EQ_EQ expression
466: {BINARY(EQ, fst $1, fst $3), snd $1}
467: | expression EXCLAM_EQ expression
468: {BINARY(NE, fst $1, fst $3), snd $1}
469: | expression INF expression
470: {BINARY(LT, fst $1, fst $3), snd $1}
471: | expression SUP expression
472: {BINARY(GT, fst $1, fst $3), snd $1}
473: | expression INF_EQ expression
474: {BINARY(LE, fst $1, fst $3), snd $1}
475: | expression SUP_EQ expression
476: {BINARY(GE, fst $1, fst $3), snd $1}
477: | expression INF_INF expression
478: {BINARY(SHL, fst $1, fst $3), snd $1}
479: | expression SUP_SUP expression
480: {BINARY(SHR, fst $1, fst $3), snd $1}
481: | expression EQ expression
482: {BINARY(ASSIGN, fst $1, fst $3), snd $1}
483: | expression PLUS_EQ expression
484: {BINARY(ADD_ASSIGN, fst $1, fst $3), snd $1}
485: | expression MINUS_EQ expression
486: {BINARY(SUB_ASSIGN, fst $1, fst $3), snd $1}
487: | expression STAR_EQ expression
488: {BINARY(MUL_ASSIGN, fst $1, fst $3), snd $1}
489: | expression SLASH_EQ expression
490: {BINARY(DIV_ASSIGN, fst $1, fst $3), snd $1}
491: | expression PERCENT_EQ expression
492: {BINARY(MOD_ASSIGN, fst $1, fst $3), snd $1}
493: | expression AND_EQ expression
494: {BINARY(BAND_ASSIGN, fst $1, fst $3), snd $1}
495: | expression PIPE_EQ expression
496: {BINARY(BOR_ASSIGN, fst $1, fst $3), snd $1}
497: | expression CIRC_EQ expression
498: {BINARY(XOR_ASSIGN, fst $1, fst $3), snd $1}
499: | expression INF_INF_EQ expression
500: {BINARY(SHL_ASSIGN, fst $1, fst $3), snd $1}
501: | expression SUP_SUP_EQ expression
502: {BINARY(SHR_ASSIGN, fst $1, fst $3), snd $1}
503: | LPAREN type_name RPAREN expression
504: { CAST($2, SINGLE_INIT (fst $4)), $1 }
505: /* (* We handle GCC constructor expressions *) */
506: | LPAREN type_name RPAREN LBRACE initializer_list_opt RBRACE
507: { CAST($2, COMPOUND_INIT $5), $1 }
508: /* (* GCC's address of labels *) */
509: | AND_AND IDENT { LABELADDR (fst $2), $1 }
510: | AT_EXPR LPAREN IDENT RPAREN /* expression pattern variable */
511: { EXPR_PATTERN(fst $3), $1 }
512: ;
513:
514: constant:
515: | CST_INT {CONST_INT (fst $1), snd $1}
516: | CST_FLOAT {CONST_FLOAT (fst $1), snd $1}
517: | CST_CHAR {CONST_CHAR (fst $1), snd $1}
518: | CST_WCHAR {CONST_WCHAR (fst $1), snd $1}
519: | string_constant {CONST_STRING (fst $1), snd $1}
520: | wstring_list {CONST_WSTRING (fst $1), snd $1}
521: ;
522:
523: string_constant:
524: /* Now that we know this constant isn't part of a wstring, convert it
525: back to a string for easy viewing. */
526: | string_list {intlist_to_string (fst $1), snd $1 }
527: ;
528: one_string_constant:
529: /* Don't concat multiple strings. For asm templates. */
530: | CST_STRING {intlist_to_string (fst $1) }
531: ;
532: string_list:
533: | one_string { $1 }
534: | string_list one_string { (fst $1) @ (fst $2), snd $1 }
535: ;
536:
537: wstring_list:
538: | CST_WSTRING { $1 }
539: | wstring_list one_string { (fst $1) @ (fst $2), snd $1 }
540: | wstring_list CST_WSTRING { (fst $1) @ (fst $2), snd $1 }
541: /* Only the first string in the list needs an L, so L"a" "b" is the same
542: * as L"ab" or L"a" L"b". */
543:
544: one_string:
545: | CST_STRING {$1}
546: | FUNCTION__ {(Flx_cil_cabs_helper.explodeStringToInts
547: !currentFunctionName), $1}
548: | PRETTY_FUNCTION__ {(Flx_cil_cabs_helper.explodeStringToInts
549: !currentFunctionName), $1}
550: ;
551:
552: init_expression:
553: | expression { SINGLE_INIT (fst $1) }
554: | LBRACE initializer_list_opt RBRACE
555: { COMPOUND_INIT $2}
556:
557: /* ISO 6.7.8. Allow a trailing COMMA */
558: initializer_list:
559: | initializer { [$1] }
560: | initializer COMMA initializer_list_opt { $1 :: $3 }
561: ;
562: initializer_list_opt:
563: | /* empty */ { [] }
564: | initializer_list { $1 }
565: ;
566: initializer:
567: | init_designators eq_opt init_expression { ($1, $3) }
568: | gcc_init_designators init_expression { ($1, $2) }
569: | init_expression { (NEXT_INIT, $1) }
570: ;
571: eq_opt:
572: | EQ { () }
573: /*(* GCC allows missing = *)*/
574: | /*(* empty *)*/ { () }
575: ;
576: init_designators:
577: | DOT id_or_typename init_designators_opt { INFIELD_INIT($2, $3) }
578: | LBRACKET expression RBRACKET init_designators_opt
579: { ATINDEX_INIT(fst $2, $4) }
580: | LBRACKET expression ELLIPSIS expression RBRACKET
581: { ATINDEXRANGE_INIT(fst $2, fst $4) }
582: ;
583: init_designators_opt:
584: | /* empty */ { NEXT_INIT }
585: | init_designators { $1 }
586: ;
587:
588: /*(* GCC supports these strange things *)*/
589: gcc_init_designators:
590: | id_or_typename COLON { INFIELD_INIT($1, NEXT_INIT) }
591: ;
592:
593: arguments:
594: | /* empty */ { [] }
595: | comma_expression { fst $1 }
596: ;
597:
598: opt_expression:
599: | /* empty */
600: {NOTHING}
601: | comma_expression
602: {smooth_expression (fst $1)}
603: ;
604:
605: comma_expression:
606: | expression {[fst $1], snd $1}
607: | expression COMMA comma_expression { fst $1 :: fst $3, snd $1 }
608: | error COMMA comma_expression { $3 }
609: ;
610:
611: comma_expression_opt:
612: | /* empty */ { NOTHING }
613: | comma_expression { smooth_expression (fst $1) }
614: ;
615:
616: paren_comma_expression:
617: | LPAREN comma_expression RPAREN { $2 }
618: | LPAREN error RPAREN { [], $1 }
619: ;
620:
621: bracket_comma_expression:
622: | LBRACKET comma_expression RBRACKET { fst $2 }
623: | LBRACKET error RBRACKET { [] }
624: ;
625:
626:
627: /*** statements ***/
628: /* ISO 6.8.2 */
629: block:
630: | block_begin local_labels block_attrs block_element_list RBRACE
631: {!Flx_cil_lexerhack.pop_context();
632: { blabels = $2;
633: battrs = $3;
634: bstmts = $4 },
635: $1, $5
636: }
637: | error location RBRACE { { blabels = [];
638: battrs = [];
639: bstmts = [] },
640: $2, $3
641: }
642: ;
643: block_begin:
644: | LBRACE {!Flx_cil_lexerhack.push_context (); $1}
645: ;
646:
647: block_attrs:
648: | /* empty */ { [] }
649: | BLOCKATTRIBUTE paren_attr_list_ne
650: { [("__blockattribute__", $2)] }
651: ;
652:
653: /* statements and declarations in a block, in any order (for C99 support) */
654: block_element_list:
655: | /* empty */ { [] }
656: | declaration block_element_list { DEFINITION($1) :: $2 }
657: | statement block_element_list { $1 :: $2 }
658: /*(* GCC accepts a label at the end of a block *)*/
659: | IDENT COLON { [ LABEL (fst $1, NOP (snd $1),
660: snd $1)] }
661: ;
662:
663: local_labels:
664: | /* empty */ { [] }
665: | LABEL__ local_label_names SEMICOLON local_labels { $2 @ $4 }
666: ;
667: local_label_names:
668: | IDENT { [ fst $1 ] }
669: | IDENT COMMA local_label_names { fst $1 :: $3 }
670: ;
671:
672:
673:
674: statement:
675: | SEMICOLON {NOP $1 }
676: | comma_expression SEMICOLON
677: {COMPUTATION (smooth_expression (fst $1), snd $1)}
678: | block {BLOCK (fst3 $1, snd3 $1)}
679: | IF paren_comma_expression statement %prec IF
680: {IF (smooth_expression (fst $2), $3, NOP $1, $1)}
681: | IF paren_comma_expression statement ELSE statement
682: {IF (smooth_expression (fst $2), $3, $5, $1)}
683: | SWITCH paren_comma_expression statement
684: {SWITCH (smooth_expression (fst $2), $3, $1)}
685: | WHILE paren_comma_expression statement
686: {WHILE (smooth_expression (fst $2), $3, $1)}
687: | DO statement WHILE paren_comma_expression SEMICOLON
688: {DOWHILE (smooth_expression (fst $4), $2, $1)}
689: | FOR LPAREN for_clause opt_expression
690: SEMICOLON opt_expression RPAREN statement
691: {FOR ($3, $4, $6, $8, $1)}
692: | IDENT COLON statement
693: {LABEL (fst $1, $3, snd $1)}
694: | CASE expression COLON
695: {CASE (fst $2, NOP $1, $1)}
696: | CASE expression ELLIPSIS expression COLON
697: {CASERANGE (fst $2, fst $4, NOP $1, $1)}
698: | DEFAULT COLON
699: {DEFAULT (NOP $1, $1)}
700: | RETURN SEMICOLON {RETURN (NOTHING, $1)}
701: | RETURN comma_expression SEMICOLON
702: {RETURN (smooth_expression (fst $2), $1)}
703: | BREAK SEMICOLON {BREAK $1}
704: | CONTINUE SEMICOLON {CONTINUE $1}
705: | GOTO IDENT SEMICOLON
706: {GOTO (fst $2, $1)}
707: | GOTO STAR comma_expression SEMICOLON
708: { COMPGOTO (smooth_expression (fst $3), $1) }
709: | ASM asmattr LPAREN asmtemplate asmoutputs RPAREN SEMICOLON
710: { let (outs,ins,clobs) = $5 in
711: ASM ($2, $4, outs, ins, clobs, $1) }
712: | MSASM { ASM ([], [fst $1], [], [], [], snd $1)}
713: | TRY block EXCEPT paren_comma_expression block
714: { let b, _, _ = $2 in
715: let h, _, _ = $5 in
716: if not !Flx_cil_cprint.msvcMode then
717: parse_error "try/except in GCC code";
718: TRY_EXCEPT (b, COMMA (fst $4), h, $1) }
719: | TRY block FINALLY block
720: { let b, _, _ = $2 in
721: let h, _, _ = $4 in
722: if not !Flx_cil_cprint.msvcMode then
723: parse_error "try/finally in GCC code";
724: TRY_FINALLY (b, h, $1) }
725:
726: | error location SEMICOLON { (NOP $2)}
727: ;
728:
729:
730: for_clause:
731: | opt_expression SEMICOLON { FC_EXP $1 }
732: | declaration { FC_DECL $1 }
733: ;
734:
735: /* ISO 6.7.*/
736: declaration:
737: | decl_spec_list init_declarator_list SEMICOLON
738: { doDeclaration (snd $1) (fst $1) $2 }
739: | decl_spec_list SEMICOLON { doDeclaration (snd $1) (fst $1) [] }
740: ;
741:
742: /* ISO 6.7 */
743: init_declarator_list:
744: | init_declarator { [$1] }
745: | init_declarator COMMA init_declarator_list { $1 :: $3 }
746:
747: ;
748:
749: /* ISO 6.7 */
750: init_declarator:
751: | declarator { ($1, NO_INIT) }
752: | declarator EQ init_expression
753: { ($1, $3) }
754: ;
755:
756: /* ISO 6.7 */
757: decl_spec_list:
758: /* ISO 6.7.1 */
759: | TYPEDEF decl_spec_list_opt { SpecTypedef :: $2, $1 }
760: | EXTERN decl_spec_list_opt { SpecStorage EXTERN :: $2, $1 }
761: | STATIC decl_spec_list_opt { SpecStorage STATIC :: $2, $1 }
762: | AUTO decl_spec_list_opt { SpecStorage AUTO :: $2, $1 }
763: | REGISTER decl_spec_list_opt { SpecStorage REGISTER :: $2, $1}
764: /* ISO 6.7.2 */
765: | type_spec decl_spec_list_opt_no_named { SpecType (fst $1) :: $2, snd $1 }
766: /* ISO 6.7.4 */
767: | INLINE decl_spec_list_opt { SpecInline :: $2, $1 }
768: | cvspec decl_spec_list_opt { (fst $1) :: $2, snd $1 }
769: | attribute_nocv decl_spec_list_opt { SpecAttr (fst $1) :: $2, snd $1 }
770: /* specifier pattern variable (must be last in spec list) */
771: | AT_SPECIFIER LPAREN IDENT RPAREN { [ SpecPattern(fst $3) ], $1 }
772: ;
773: /* (* In most cases if we see a NAMED_TYPE we must shift it. Thus we declare
774: * NAMED_TYPE to have right associativity *) */
775: decl_spec_list_opt:
776: | /* empty */ { [] } %prec NAMED_TYPE
777: | decl_spec_list { fst $1 }
778: ;
779: /* (* We add this separate rule to handle the special case when an appearance
780: * of NAMED_TYPE should not be considered as part of the specifiers but as
781: * part of the declarator. IDENT has higher precedence than NAMED_TYPE *)
782: */
783: decl_spec_list_opt_no_named:
784: | /* empty */ { [] } %prec IDENT
785: | decl_spec_list { fst $1 }
786: ;
787:
788:
789: base:
790: | id_or_typename { `Public $1 }
791: | PUBLIC id_or_typename { `Public $2 }
792: | PROTECTED id_or_typename { `Protected $2 }
793: | PRIVATE id_or_typename { `Private $2 }
794: | VIRTUAL id_or_typename { `Public $2 }
795: | VIRTUAL PUBLIC id_or_typename { `Public $3 }
796: | VIRTUAL PROTECTED id_or_typename { `Protected $3 }
797: | VIRTUAL PRIVATE id_or_typename { `Private $3 }
798: | PUBLIC VIRTUAL id_or_typename { `Public $3 }
799: | PROTECTED VIRTUAL id_or_typename { `Protected $3 }
800: | PRIVATE VIRTUAL id_or_typename { `Private $3 }
801:
802: bases:
803: | base COMMA bases {$1 :: $3 }
804: | base { [$1] }
805:
806: int_spec:
807: | CHAR { Tchar, $1 }
808: | SHORT { Tshort, $1 }
809: | INT { Tint, $1 }
810: | LONG { Tlong, $1 }
811: | INT64 { Tint64, $1 }
812: | SIGNED { Tsigned, $1 }
813: | UNSIGNED { Tunsigned, $1 }
814:
815: /* ISO 6.7.2 */
816: type_spec:
817: | int_spec { $1 }
818: | VOID { Tvoid, $1}
819: | BOOL { Tbool, $1 }
820: | FLOAT { Tfloat, $1 }
821: | COMPLEX { Tcomplex, $1 }
822: | IMAGINARY { Timaginary, $1 }
823: | DOUBLE { Tdouble, $1 }
824:
825: | STRUCT id_or_typename
826: { Tstruct ($2, None, []), $1 }
827: | STRUCT id_or_typename LBRACE struct_decl_list RBRACE
828: { Tstruct ($2, mkflds true $4, []), $1 }
829: | STRUCT id_or_typename COLON bases LBRACE struct_decl_list RBRACE
830: { Tstruct ($2, mkflds true $6, []), $1 }
831: | STRUCT LBRACE struct_decl_list RBRACE
832: { Tstruct ("", mkflds true $3, []), $1 }
833: | STRUCT just_attributes id_or_typename LBRACE struct_decl_list RBRACE
834: { Tstruct ($3, mkflds true $5, $2), $1 }
835: | STRUCT just_attributes id_or_typename COLON bases LBRACE struct_decl_list RBRACE
836: { Tstruct ($3, mkflds true $7, $2), $1 }
837: | STRUCT just_attributes LBRACE struct_decl_list RBRACE
838: { Tstruct ("", mkflds true $4, $2), $1 }
839:
840: | CLASS id_or_typename
841: { Tstruct ($2, None, []), $1 }
842: | CLASS id_or_typename LBRACE struct_decl_list RBRACE
843: { Tstruct ($2, mkflds false $4, []), $1 }
844: | CLASS id_or_typename COLON bases LBRACE struct_decl_list RBRACE
845: { Tstruct ($2, mkflds false $6, []), $1 }
846: | CLASS LBRACE struct_decl_list RBRACE
847: { Tstruct ("", mkflds false $3, []), $1 }
848: | CLASS just_attributes id_or_typename LBRACE struct_decl_list RBRACE
849: { Tstruct ($3, mkflds false $5, $2), $1 }
850: | CLASS just_attributes id_or_typename COLON bases LBRACE struct_decl_list RBRACE
851: { Tstruct ($3, mkflds false $7, $2), $1 }
852: | CLASS just_attributes LBRACE struct_decl_list RBRACE
853: { Tstruct ("", mkflds false $4, $2), $1 }
854:
855: | UNION id_or_typename
856: { Tunion ($2, None, []), $1 }
857: | UNION id_or_typename LBRACE struct_decl_list RBRACE
858: { Tunion ($2, mkflds true $4, []), $1 }
859: | UNION id_or_typename COLON bases LBRACE struct_decl_list RBRACE
860: { Tunion ($2, mkflds true $6, []), $1 }
861: | UNION LBRACE struct_decl_list RBRACE
862: { Tunion ("", mkflds true $3, []), $1 }
863: | UNION just_attributes id_or_typename LBRACE struct_decl_list RBRACE
864: { Tunion ($3, mkflds true $5, $2), $1 }
865: | UNION just_attributes id_or_typename COLON bases LBRACE struct_decl_list RBRACE
866: { Tunion ($3, mkflds true $7, $2), $1 }
867: | UNION just_attributes LBRACE struct_decl_list RBRACE
868: { Tunion ("", mkflds true $4, $2), $1 }
869:
870: | ENUM id_or_typename
871: { Tenum ($2, None, []), $1 }
872: | ENUM id_or_typename LBRACE enum_list maybecomma RBRACE
873: { Tenum ($2, Some $4, []), $1 }
874: | ENUM LBRACE enum_list maybecomma RBRACE
875: { Tenum ("", Some $3, []), $1 }
876: | ENUM just_attributes id_or_typename LBRACE enum_list maybecomma RBRACE
877: { Tenum ($3, Some $5, $2), $1 }
878: | ENUM just_attributes LBRACE enum_list maybecomma RBRACE
879: { Tenum ("", Some $4, $2), $1 }
880: | NAMED_TYPE { Tnamed (fst $1), snd $1 }
881: | TYPEOF LPAREN expression RPAREN { TtypeofE (fst $3), $1 }
882: | TYPEOF LPAREN type_name RPAREN { let s, d = $3 in
883: TtypeofT (s, d), $1 }
884: ;
885:
886: /* (* ISO 6.7.2. Except that we allow empty structs. We
887: * also allow missing field names. *)
888: */
889: struct_decl_list:
890: | /* empty */ { [] }
891:
892: | decl_spec_list SEMICOLON struct_decl_list
893: { `Fields (fst $1, [(missingFieldDecl, None)]) :: $3 }
894:
895: /*(* GCC allows extra semicolons *)*/
896: | SEMICOLON struct_decl_list
897: { $2 }
898:
899: | decl_spec_list field_decl_list SEMICOLON struct_decl_list
900: { `Fields (fst $1, $2) :: $4 }
901:
902: /* this is a hack allowing 'int : 2' */
903:
904: | int_spec COLON expression SEMICOLON struct_decl_list
905: {
906: let ts: Flx_cil_cabs.spec_elem = SpecType (fst $1) in
907: let fld
908: : Flx_cil_cabs.name * Flx_cil_cabs.expression option
909: = missingFieldDecl,Some (fst $3)
910: in
911: let x = `Fields ([ts],[fld]) in
912: x :: $5
913: }
914:
915:
916: | PUBLIC COLON struct_decl_list { `Access_public :: $3 }
917: | PROTECTED COLON struct_decl_list { `Access_protected :: $3 }
918: | PRIVATE COLON struct_decl_list {`Access_private :: $3 }
919: | error SEMICOLON struct_decl_list
920: { $3 }
921: ;
922:
923: /* (* ISO 6.7.2 *) */
924: field_decl_list:
925: | field_decl { [$1] }
926: | field_decl COMMA field_decl_list { $1 :: $3 }
927: ;
928:
929: /* (* ISO 6.7.2. Except that we allow unnamed fields. *) */
930: field_decl:
931: | declarator { ($1, None) }
932: | declarator COLON expression { ($1, Some (fst $3)) }
933:
934: /* This construction can't be allowed in C++ because
935: there is a conflict here
936:
937: struct X : Y
938:
939: between declaring a nested class with a base, and an unnamed bitfield
940: of type struct X, length Y
941: */
942:
943: /*
944: | COLON expression { (missingFieldDecl, Some (fst $2)) }
945: */
946: ;
947:
948: /* (* ISO 6.7.2.2 *) */
949: enum_list:
950: | enumerator {[$1]}
951: | enum_list COMMA enumerator {$1 @ [$3]}
952: | enum_list COMMA error { $1 }
953: ;
954: enumerator:
955: | IDENT {(fst $1, NOTHING, snd $1)}
956: | IDENT EQ expression {(fst $1, fst $3, snd $1)}
957: ;
958:
959:
960: /* (* ISO 6.7.5. Plus Microsoft declarators.*) */
961: declarator:
962: | pointer_opt direct_decl attributes_with_asm
963: {
964: let (n, decl) = $2 in
965: (n, applyPointer (fst $1) decl, $3, snd $1)
966: }
967: ;
968:
969:
970: /* (* ISO 6.7.5 *) */
971: direct_decl:
972: /* (* We want to be able to redefine named
973: * types as variable names *) */
974: | id_or_typename { ($1, JUSTBASE) }
975:
976: | LPAREN attributes declarator RPAREN
977: { let (n,decl,al,loc) = $3 in
978: (n, PARENTYPE($2,decl,al)) }
979:
980: | direct_decl LBRACKET attributes comma_expression_opt RBRACKET
981: { let (n, decl) = $1 in
982: (n, ARRAY(decl, $3, $4)) }
983: | direct_decl LBRACKET attributes error RBRACKET
984: { let (n, decl) = $1 in
985: (n, ARRAY(decl, $3, NOTHING)) }
986: | direct_decl parameter_list_startscope rest_par_list RPAREN
987: { let (n, decl) = $1 in
988: let (params, isva) = $3 in
989: !Flx_cil_lexerhack.pop_context ();
990: (n, PROTO(decl, params, isva))
991: }
992: ;
993: parameter_list_startscope:
994: | LPAREN { !Flx_cil_lexerhack.push_context () }
995: ;
996: rest_par_list:
997: | /* empty */ { ([], false) }
998: | parameter_decl rest_par_list1 { let (params, isva) = $2 in
999: ($1 :: params, isva)
1000: }
1001: ;
1002: rest_par_list1:
1003: | /* empty */ { ([], false) }
1004: | COMMA ELLIPSIS { ([], true) }
1005: | COMMA parameter_decl rest_par_list1 { let (params, isva) = $3 in
1006: ($2 :: params, isva)
1007: }
1008: ;
1009:
1010:
1011: /* (* ISO 6.7.5 *) */
1012: parameter_decl:
1013: | decl_spec_list declarator { (fst $1, $2) }
1014: | decl_spec_list abstract_decl { let d, a = $2 in
1015: (fst $1, ("", d, a, cabslu)) }
1016: | decl_spec_list { (fst $1, ("", JUSTBASE, [], cabslu)) }
1017: | LPAREN parameter_decl RPAREN { $2 }
1018: ;
1019:
1020: /* (* Old style prototypes. Like a declarator *) */
1021: old_proto_decl:
1022: | pointer_opt direct_old_proto_decl { let (n, decl, a) = $2 in
1023: (n, applyPointer (fst $1) decl, a, snd $1) }
1024: ;
1025: direct_old_proto_decl:
1026: | direct_decl LPAREN old_parameter_list_ne RPAREN old_pardef_list
1027: { let par_decl, isva = doOldParDecl $3 $5 in
1028: let n, decl = $1 in
1029: (n, PROTO(decl, par_decl, isva), [])
1030: }
1031: | direct_decl LPAREN RPAREN
1032: { let n, decl = $1 in
1033: (n, PROTO(decl, [], false), [])
1034: }
1035: ;
1036:
1037: old_parameter_list_ne:
1038: | IDENT { [fst $1] }
1039: | IDENT COMMA old_parameter_list_ne { let rest = $3 in
1040: (fst $1 :: rest) }
1041: ;
1042:
1043: old_pardef_list:
1044: | /* empty */ { ([], false) }
1045: | decl_spec_list old_pardef SEMICOLON ELLIPSIS
1046: { ([(fst $1, $2)], true) }
1047: | decl_spec_list old_pardef SEMICOLON old_pardef_list
1048: { let rest, isva = $4 in
1049: ((fst $1, $2) :: rest, isva)
1050: }
1051: ;
1052:
1053: old_pardef:
1054: | declarator { [$1] }
1055: | declarator COMMA old_pardef { $1 :: $3 }
1056: | error { [] }
1057: ;
1058:
1059:
1060: /* (* ISO 6.7.5 *) */
1061: pointer:
1062: | STAR attributes pointer_opt { $2 :: fst $3, $1 }
1063: ;
1064: pointer_opt:
1065: | /**/ { [], currentLoc () }
1066: | pointer { $1 }
1067: ;
1068:
1069: /* (* ISO 6.7.6 *) */
1070: type_name:
1071: | decl_spec_list abstract_decl { let d, a = $2 in
1072: if a <> [] then begin
1073: parse_error "attributes in type name";
1074: raise Parsing.Parse_error
1075: end;
1076: (fst $1, d)
1077: }
1078: | decl_spec_list { (fst $1, JUSTBASE) }
1079: ;
1080: abstract_decl: /* (* ISO 6.7.6. *) */
1081: | pointer_opt abs_direct_decl attributes { applyPointer (fst $1) $2, $3 }
1082: | pointer { applyPointer (fst $1) JUSTBASE, [] }
1083: ;
1084:
1085: abs_direct_decl: /* (* ISO 6.7.6. We do not support optional declarator for
1086: * functions. Plus Microsoft attributes. See the
1087: * discussion for declarator. *) */
1088: | LPAREN attributes abstract_decl RPAREN
1089: { let d, a = $3 in
1090: PARENTYPE ($2, d, a)
1091: }
1092:
1093: | LPAREN error RPAREN
1094: { JUSTBASE }
1095:
1096: | abs_direct_decl_opt LBRACKET comma_expression_opt RBRACKET
1097: { ARRAY($1, [], $3) }
1098: /*(* The next shoudl be abs_direct_decl_opt but we get conflicts *)*/
1099: | abs_direct_decl parameter_list_startscope rest_par_list RPAREN
1100: { let (params, isva) = $3 in
1101: !Flx_cil_lexerhack.pop_context ();
1102: PROTO ($1, params, isva)
1103: }
1104: ;
1105: abs_direct_decl_opt:
1106: | abs_direct_decl { $1 }
1107: | /* empty */ { JUSTBASE }
1108: ;
1109: function_def: /* (* ISO 6.9.1 *) */
1110: | function_def_start block
1111: { let (loc, specs, decl) = $1 in
1112: currentFunctionName := "<__FUNCTION__ used outside any functions>";
1113: !Flx_cil_lexerhack.pop_context (); (* The context pushed by
1114: * announceFunctionName *)
1115: doFunctionDef loc (trd3 $2) specs decl (fst3 $2)
1116: }
1117:
1118:
1119: function_def_start: /* (* ISO 6.9.1 *) */
1120: | decl_spec_list declarator
1121: { announceFunctionName $2;
1122: (snd $1, fst $1, $2)
1123: }
1124:
1125: /* (* Old-style function prototype *) */
1126: | decl_spec_list old_proto_decl
1127: { announceFunctionName $2;
1128: (snd $1, fst $1, $2)
1129: }
1130: /* (* New-style function that does not have a return type *) */
1131: | IDENT parameter_list_startscope rest_par_list RPAREN
1132: { let (params, isva) = $3 in
1133: let fdec =
1134: (fst $1, PROTO(JUSTBASE, params, isva), [], snd $1) in
1135: announceFunctionName fdec;
1136: (* Default is int type *)
1137: let defSpec = [SpecType Tint] in
1138: (snd $1, defSpec, fdec)
1139: }
1140:
1141: /* (* No return type and old-style parameter list *) */
1142: | IDENT LPAREN old_parameter_list_ne RPAREN old_pardef_list
1143: { (* Convert pardecl to new style *)
1144: let pardecl, isva = doOldParDecl $3 $5 in
1145: (* Make the function declarator *)
1146: let fdec = (fst $1,
1147: PROTO(JUSTBASE, pardecl,isva),
1148: [], snd $1) in
1149: announceFunctionName fdec;
1150: (* Default is int type *)
1151: let defSpec = [SpecType Tint] in
1152: (snd $1, defSpec, fdec)
1153: }
1154: /* (* No return type and no parameters *) */
1155: | IDENT LPAREN RPAREN
1156: { (* Make the function declarator *)
1157: let fdec = (fst $1,
1158: PROTO(JUSTBASE, [], false),
1159: [], snd $1) in
1160: announceFunctionName fdec;
1161: (* Default is int type *)
1162: let defSpec = [SpecType Tint] in
1163: (snd $1, defSpec, fdec)
1164: }
1165: ;
1166:
1167: /* const/volatile as type specifier elements */
1168: cvspec:
1169: | CONST { SpecCV(CV_CONST), $1 }
1170: | VOLATILE { SpecCV(CV_VOLATILE), $1 }
1171: | RESTRICT { SpecCV(CV_RESTRICT), $1 }
1172: ;
1173:
1174: /*** GCC attributes ***/
1175: attributes:
1176: | /* empty */ { []}
1177: | attribute attributes { fst $1 :: $2 }
1178: ;
1179:
1180: /* (* In some contexts we can have an inline assembly to specify the name to
1181: * be used for a global. We treat this as a name attribute *) */
1182: attributes_with_asm:
1183: | /* empty */ { [] }
1184: | attribute attributes_with_asm { fst $1 :: $2 }
1185: | ASM LPAREN string_constant RPAREN attributes
1186: { ("__asm__",
1187: [CONSTANT(CONST_STRING (fst $3))]) :: $5 }
1188: ;
1189:
1190: /* things like __attribute__, but no const/volatile */
1191: attribute_nocv:
1192: | ATTRIBUTE LPAREN paren_attr_list_ne RPAREN
1193: { ("__attribute__", $3), $1 }
1194: | DECLSPEC paren_attr_list_ne { ("__declspec", $2), $1 }
1195: | MSATTR { (fst $1, []), snd $1 }
1196: /* ISO 6.7.3 */
1197: | THREAD { ("__thread",[]), $1 }
1198: ;
1199:
1200: /* __attribute__ plus const/volatile */
1201: attribute:
1202: | attribute_nocv { $1 }
1203: | CONST { ("const", []), $1 }
1204: | RESTRICT { ("restrict",[]), $1 }
1205: | VOLATILE { ("volatile",[]), $1 }
1206: ;
1207:
1208: /* (* sm: I need something that just includes __attribute__ and nothing more,
1209: * to support them appearing between the 'struct' keyword and the type name.
1210: * Actually, a declspec can appear there as well (on MSVC) *) */
1211: just_attribute:
1212: ATTRIBUTE LPAREN paren_attr_list_ne RPAREN
1213: { ("__attribute__", $3) }
1214: | DECLSPEC paren_attr_list_ne { ("__declspec", $2) }
1215: ;
1216:
1217: /* this can't be empty, b/c I folded that possibility into the calling
1218: * productions to avoid some S/R conflicts */
1219: just_attributes:
1220: | just_attribute { [$1] }
1221: | just_attribute just_attributes { $1 :: $2 }
1222: ;
1223:
1224: /** (* PRAGMAS and ATTRIBUTES *) ***/
1225: /* (* We want to allow certain strange things that occur in pragmas, so we
1226: * cannot use directly the language of expressions *) */
1227: attr:
1228: | id_or_typename { VARIABLE $1 }
1229: | IDENT IDENT { CALL(VARIABLE (fst $1), [VARIABLE (fst $2)]) }
1230: | IDENT COLON CST_INT { VARIABLE (fst $1 ^ ":" ^ fst $3) }
1231:
1232: | CST_INT COLON CST_INT { VARIABLE (fst $1 ^ ":" ^ fst $3) }
1233: | DEFAULT COLON CST_INT { VARIABLE ("default:" ^ fst $3) }
1234: /* (* use a VARIABLE "" so that the
1235: * parentheses are printed *) */
1236: | IDENT LPAREN RPAREN { CALL(VARIABLE (fst $1), [VARIABLE ""]) }
1237: | IDENT paren_attr_list_ne { CALL(VARIABLE (fst $1), $2) }
1238:
1239: | CST_INT { CONSTANT(CONST_INT (fst $1)) }
1240: | string_constant { CONSTANT(CONST_STRING (fst $1)) }
1241: /*(* Const when it appears in
1242: * attribute lists, is translated
1243: * to aconst *)*/
1244: | CONST { VARIABLE "aconst" }
1245: | SIZEOF expression {EXPR_SIZEOF (fst $2)}
1246: | SIZEOF LPAREN type_name RPAREN
1247: {let b, d = $3 in TYPE_SIZEOF (b, d)}
1248:
1249: | ALIGNOF expression {EXPR_ALIGNOF (fst $2)}
1250: | ALIGNOF LPAREN type_name RPAREN {let b, d = $3 in TYPE_ALIGNOF (b, d)}
1251: | PLUS expression {UNARY (PLUS, fst $2)}
1252: | MINUS expression {UNARY (MINUS, fst $2)}
1253: | STAR expression {UNARY (MEMOF, fst $2)}
1254: | AND expression %prec ADDROF
1255: {UNARY (ADDROF, fst $2)}
1256: | EXCLAM expression {UNARY (NOT, fst $2)}
1257: | TILDE expression {UNARY (BNOT, fst $2)}
1258: | attr PLUS attr {BINARY(ADD ,$1 , $3)}
1259: | attr MINUS attr {BINARY(SUB ,$1 , $3)}
1260: | attr STAR expression {BINARY(MUL ,$1 , fst $3)}
1261: | attr SLASH attr {BINARY(DIV ,$1 , $3)}
1262: | attr PERCENT attr {BINARY(MOD ,$1 , $3)}
1263: | attr AND_AND attr {BINARY(AND ,$1 , $3)}
1264: | attr PIPE_PIPE attr {BINARY(OR ,$1 , $3)}
1265: | attr AND attr {BINARY(BAND ,$1 , $3)}
1266: | attr PIPE attr {BINARY(BOR ,$1 , $3)}
1267: | attr CIRC attr {BINARY(XOR ,$1 , $3)}
1268: | attr EQ_EQ attr {BINARY(EQ ,$1 , $3)}
1269: | attr EXCLAM_EQ attr {BINARY(NE ,$1 , $3)}
1270: | attr INF attr {BINARY(LT ,$1 , $3)}
1271: | attr SUP attr {BINARY(GT ,$1 , $3)}
1272: | attr INF_EQ attr {BINARY(LE ,$1 , $3)}
1273: | attr SUP_EQ attr {BINARY(GE ,$1 , $3)}
1274: | attr INF_INF attr {BINARY(SHL ,$1 , $3)}
1275: | attr SUP_SUP attr {BINARY(SHR ,$1 , $3)}
1276: | attr ARROW id_or_typename {MEMBEROFPTR ($1, $3)}
1277: | attr DOT id_or_typename {MEMBEROF ($1, $3)}
1278: | LPAREN attr RPAREN { $2 }
1279: ;
1280:
1281: attr_list_ne:
1282: | attr { [$1] }
1283: | attr COMMA attr_list_ne { $1 :: $3 }
1284: | error COMMA attr_list_ne { $3 }
1285: ;
1286: paren_attr_list_ne:
1287: | LPAREN attr_list_ne RPAREN { $2 }
1288: | LPAREN error RPAREN { [] }
1289: ;
1290: /*** GCC ASM instructions ***/
1291: asmattr:
1292: | /* empty */ { [] }
1293: | VOLATILE asmattr { ("volatile", []) :: $2 }
1294: | CONST asmattr { ("const", []) :: $2 }
1295: ;
1296: asmtemplate:
1297: one_string_constant { [$1] }
1298: | one_string_constant asmtemplate { $1 :: $2 }
1299: ;
1300: asmoutputs:
1301: | /* empty */ { ([], [], []) }
1302: | COLON asmoperands asminputs
1303: { let (ins, clobs) = $3 in
1304: ($2, ins, clobs) }
1305: ;
1306: asmoperands:
1307: | /* empty */ { [] }
1308: | asmoperandsne { List.rev $1 }
1309: ;
1310: asmoperandsne:
1311: | asmoperand { [$1] }
1312: | asmoperandsne COMMA asmoperand { $3 :: $1 }
1313: ;
1314: asmoperand:
1315: | string_constant LPAREN expression RPAREN { (fst $1, fst $3) }
1316: | string_constant LPAREN error RPAREN { (fst $1, NOTHING ) }
1317: ;
1318: asminputs:
1319: | /* empty */ { ([], []) }
1320: | COLON asmoperands asmclobber
1321: { ($2, $3) }
1322: ;
1323: asmclobber:
1324: | /* empty */ { [] }
1325: | COLON asmcloberlst_ne { $2 }
1326: ;
1327: asmcloberlst_ne:
1328: | one_string_constant { [$1] }
1329: | one_string_constant COMMA asmcloberlst_ne { $1 :: $3 }
1330: ;
1331:
1332: %%
1333:
1334:
1335:
Start ocaml section to src/flx_cil_cprint.mli[1
/1
]
1: # 3105 "./lpsrc/flx_frontc.ipk"
2:
3: val version : string
4: type loc = { line : int; file : string; }
5: val lu : loc
6: val cabslu : Flx_cil_cabs.cabsloc
7: val curLoc : Flx_cil_cabs.cabsloc ref
8: val msvcMode : bool ref
9: val printLn : bool ref
10: val printLnComment : bool ref
11: val printCounters : bool ref
12: val printComments : bool ref
13: val out : out_channel ref
14: val width : int ref
15: val tab : int ref
16: val max_indent : int ref
17: val line : string ref
18: val line_len : int ref
19: val current : string ref
20: val current_len : int ref
21: val spaces : int ref
22: val follow : int ref
23: val roll : int ref
24: val print_tab : int -> unit
25: val flush : 'a -> unit
26: val commit : 'a -> unit
27: val addline : unit -> unit
28: val new_line : 'a -> unit
29: val force_new_line : 'a -> unit
30: val indent : 'a -> unit
31: val indentline : 'a -> unit
32: val unindent : 'a -> unit
33: val space : 'a -> unit
34: val print : string -> unit
35: val print_unescaped_string : string -> unit
36: val setLoc : Flx_cil_cabs.cabsloc -> unit
37: val print_list : (unit -> unit) -> ('a -> 'b) -> 'a list -> unit
38: val print_commas : bool -> ('a -> 'b) -> 'a list -> unit
39: val print_string : string -> unit
40: val print_wstring : Flx_cil_escape.wstring -> unit
41: val print_specifiers : Flx_cil_cabs.specifier -> unit
42: val print_type_spec : Flx_cil_cabs.typeSpecifier -> unit
43: val print_struct_name_attr :
44: string -> string -> Flx_cil_cabs.attribute list -> unit
45: val print_decl : string -> Flx_cil_cabs.decl_type -> unit
46: val print_fields : Flx_cil_cabs.field_group list -> unit
47: val print_enum_items : Flx_cil_cabs.enum_item list -> unit
48: val print_onlytype : Flx_cil_cabs.specifier * Flx_cil_cabs.decl_type -> unit
49: val print_name : Flx_cil_cabs.name -> unit
50: val print_init_name : Flx_cil_cabs.init_name -> unit
51: val print_name_group : Flx_cil_cabs.name_group -> unit
52: val print_field_group : Flx_cil_cabs.field_group -> unit
53: val print_field : Flx_cil_cabs.name * Flx_cil_cabs.expression option -> unit
54: val print_init_name_group : Flx_cil_cabs.init_name_group -> unit
55: val print_single_name : Flx_cil_cabs.single_name -> unit
56: val print_params : Flx_cil_cabs.single_name list -> bool -> unit
57: val print_old_params : string list -> bool -> unit
58: val get_operator : Flx_cil_cabs.expression -> string * int
59: val print_comma_exps : Flx_cil_cabs.expression list -> unit
60: val print_init_expression : Flx_cil_cabs.init_expression -> unit
61: val print_expression : Flx_cil_cabs.expression -> unit
62: val print_expression_level : int -> Flx_cil_cabs.expression -> unit
63: val print_statement : Flx_cil_cabs.statement -> unit
64: val print_block : Flx_cil_cabs.block -> unit
65: val print_substatement : Flx_cil_cabs.statement -> unit
66: val print_attribute : Flx_cil_cabs.attribute -> unit
67: val print_attributes : Flx_cil_cabs.attribute list -> unit
68: val print_defs : Flx_cil_cabs.definition list -> unit
69: val print_def : Flx_cil_cabs.definition -> unit
70: val comprint : string -> unit
71: val comstring : string -> string
72: val printFile : out_channel -> Flx_cil_cabs.file -> unit
73: val set_tab : int -> unit
74: val set_width : int -> unit
75:
Start ocaml section to src/flx_cil_cprint.ml[1
/1
]
1: # 3181 "./lpsrc/flx_frontc.ipk"
2: (* cprint -- pretty printer of C program from abstract syntax
3: **
4: ** Project: FrontC
5: ** File: cprint.ml
6: ** Version: 2.1e
7: ** Date: 9.1.99
8: ** Author: Hugues Cassé
9: **
10: ** 1.0 2.22.99 Hugues Cassé First version.
11: ** 2.0 3.18.99 Hugues Cassé Compatible with Flx_cil_frontc 2.1, use of CAML
12: ** pretty printer.
13: ** 2.1 3.22.99 Hugues Cassé More efficient custom pretty printer used.
14: ** 2.1a 4.12.99 Hugues Cassé Correctly handle:
15: ** char *m, *m, *p; m + (n - p)
16: ** 2.1b 4.15.99 Hugues Cassé x + (y + z) stays x + (y + z) for
17: ** keeping computation order.
18: ** 2.1c 7.23.99 Hugues Cassé Improvement of case and default display.
19: ** 2.1d 8.25.99 Hugues Cassé Rebuild escape sequences in string and
20: ** characters.
21: ** 2.1e 9.1.99 Hugues Cassé Fix, recognize and correctly display '\0'.
22: *)
23:
24: (* George Necula: I changed this pretty dramatically since CABS changed *)
25: open Flx_cil_cabs
26: open Flx_cil_cabs_helper
27: open Flx_cil_escape
28: let version = "Flx_cil_cprint 2.1e 9.1.99 Hugues Cassé"
29:
30: type loc = { line : int; file : string }
31:
32: let lu = {line = -1; file = "loc unknown";}
33: let cabslu = {lineno = -10; filename = "cabs loc unknown"; byteno = -10;}
34:
35: let curLoc = ref cabslu
36:
37: let msvcMode = ref false
38:
39: let printLn = ref true
40: let printLnComment = ref false
41:
42: let printCounters = ref false
43: let printComments = ref false
44:
45: (*
46: ** FrontC Flx_cil_pretty printer
47: *)
48: let out = ref stdout
49: let width = ref 80
50: let tab = ref 2
51: let max_indent = ref 60
52:
53: let line = ref ""
54: let line_len = ref 0
55: let current = ref ""
56: let current_len = ref 0
57: let spaces = ref 0
58: let follow = ref 0
59: let roll = ref 0
60:
61: let print_tab size =
62: for i = 1 to size / 8 do
63: output_char !out '\t'
64: done;
65: for i = 1 to size mod 8 do
66: output_char !out ' '
67: done
68:
69: let flush _ =
70: if !line <> "" then begin
71: print_tab (!spaces + !follow);
72: output_string !out !line;
73: line := "";
74: line_len := 0
75: end
76:
77: let commit _ =
78: if !current <> "" then begin
79: if !line = "" then begin
80: line := !current;
81: line_len := !current_len
82: end else begin
83: line := (!line ^ " " ^ !current);
84: line_len := !line_len + 1 + !current_len
85: end;
86: current := "";
87: current_len := 0
88: end
89:
90:
91: let addline () =
92: curLoc := {lineno = !curLoc.lineno+1;
93: filename = !curLoc.filename;
94: byteno = -1; (*sfg: can we do better than this?*) }
95:
96:
97: let new_line _ =
98: commit ();
99: if !line <> "" then begin
100: flush ();
101: addline();
102: output_char !out '\n'
103: end;
104: follow := 0
105:
106: let force_new_line _ =
107: commit ();
108: flush ();
109: addline();
110: output_char !out '\n';
111: follow := 0
112:
113: let indent _ =
114: new_line ();
115: spaces := !spaces + !tab;
116: if !spaces >= !max_indent then begin
117: spaces := !tab;
118: roll := !roll + 1
119: end
120:
121: let indentline _ =
122: new_line ();
123: if !spaces >= !max_indent then begin
124: spaces := !tab;
125: roll := !roll + 1
126: end
127:
128: let unindent _ =
129: new_line ();
130: spaces := !spaces - !tab;
131: if (!spaces <= 0) && (!roll > 0) then begin
132: spaces := ((!max_indent - 1) / !tab) * !tab;
133: roll := !roll - 1
134: end
135:
136: let space _ = commit ()
137:
138: let print str =
139: current := !current ^ str;
140: current_len := !current_len + (String.length str);
141: if (!spaces + !follow + !line_len + 1 + !current_len) > !width
142: then begin
143: if !line_len = 0 then commit ();
144: flush ();
145: addline();
146: output_char !out '\n';
147: if !follow = 0 then follow := !tab
148: end
149:
150: (* sm: for some reason I couldn't just call print from frontc.... ? *)
151: let print_unescaped_string str = print str
152:
153: let setLoc (l : cabsloc) =
154: let tempcur = current in
155: if !printLn then
156: if (l.lineno <> !curLoc.lineno) || l.filename <> !curLoc.filename then
157: begin
158: let oldspaces = !spaces in
159: (* sm: below, we had '//#' instead of '#', which means printLnComment was disregarded *)
160: if !printLnComment then print "//" else print "#";
161: if !msvcMode then print "line";
162: print " ";
163: print (string_of_int l.lineno);
164: if (l.filename <> !curLoc.filename) then begin
165: print (" \"" ^ l.filename ^ "\"")
166: end;
167: spaces := oldspaces;
168: new_line();
169: curLoc := l
170: end
171:
172:
173:
174: (*
175: ** Useful primitives
176: *)
177: let print_list print_sep print_elt lst =
178: let _ = List.fold_left
179: (fun com elt ->
180: if com then print_sep ();
181: print_elt elt;
182: true)
183: false
184: lst in
185: ()
186:
187: let print_commas nl fct lst =
188: print_list (fun () -> print ","; if nl then new_line() else space()) fct lst
189:
190: let print_string (s:string) =
191: print ("\"" ^ escape_string s ^ "\"")
192:
193: let print_wstring (s: int64 list ) =
194: print ("L\"" ^ escape_wstring s ^ "\"")
195:
196: (*
197: ** Base Type Printing
198: *)
199:
200: let rec print_specifiers (specs: spec_elem list) =
201: comprint "specifier(";
202: let print_spec_elem = function
203: SpecTypedef -> print "typedef "
204: | SpecInline -> print "__inline "
205: | SpecStorage sto ->
206: print (match sto with
207: NO_STORAGE -> (comstring "/*no storage*/")
208: | AUTO -> "auto "
209: | STATIC -> "static "
210: | EXTERN -> "extern "
211: | REGISTER -> "register ")
212: | SpecCV cv ->
213: print (match cv with
214: | CV_CONST -> "const "
215: | CV_VOLATILE -> "volatile "
216: | CV_RESTRICT -> "restrict ")
217: | SpecAttr al -> print_attribute al; space ()
218: | SpecType bt -> print_type_spec bt
219: | SpecPattern name -> print ("@specifier(" ^ name ^ ") ")
220: in
221: List.iter print_spec_elem specs
222: ;comprint ")"
223:
224:
225: and print_type_spec = function
226: Tvoid -> print "void "
227: | Tbool -> print "_Bool "
228: | Tchar -> print "char "
229: | Tshort -> print "short "
230: | Tint -> print "int "
231: | Tlong -> print "long "
232: | Tint64 -> print "__int64 "
233: | Tfloat -> print "float "
234: | Tdouble -> print "double "
235: | Tcomplex -> print "_Complex "
236: | Timaginary -> print "_Imaginary "
237: | Tsigned -> print "signed "
238: | Tunsigned -> print "unsigned "
239: | Tnamed s -> comprint "tnamed"; print s; space ();
240: | Tstruct (n, None, _) -> print ("struct " ^ n ^ " ")
241: | Tstruct (n, Some flds, extraAttrs) ->
242: (print_struct_name_attr "struct" n extraAttrs);
243: (print_fields flds)
244: | Tunion (n, None, _) -> print ("union " ^ n ^ " ")
245: | Tunion (n, Some flds, extraAttrs) ->
246: (print_struct_name_attr "union" n extraAttrs);
247: (print_fields flds)
248: | Tenum (n, None, _) -> print ("enum " ^ n ^ " ")
249: | Tenum (n, Some enum_items, extraAttrs) ->
250: (print_struct_name_attr "enum" n extraAttrs);
251: (print_enum_items enum_items)
252: | TtypeofE e -> print "__typeof__("; print_expression e; print ") "
253: | TtypeofT (s,d) -> print "__typeof__("; print_onlytype (s, d); print ") "
254:
255:
256: (* print "struct foo", but with specified keyword and a list of
257: * attributes to put between keyword and name *)
258: and print_struct_name_attr (keyword: string) (name: string) (extraAttrs: attribute list) =
259: begin
260: if extraAttrs = [] then
261: print (keyword ^ " " ^ name)
262: else begin
263: (print (keyword ^ " "));
264: (print_attributes extraAttrs); (* prints a final space *)
265: (print name);
266: end
267: end
268:
269:
270: (* This is the main printer for declarations. It is easy bacause the
271: * declarations are laid out as they need to be printed. *)
272: and print_decl (n: string) = function
273: JUSTBASE -> if n <> "___missing_field_name" then
274: print n
275: else
276: comprint "missing field name"
277: | PARENTYPE (al1, d, al2) ->
278: print "(";
279: print_attributes al1; space ();
280: print_decl n d; space ();
281: print_attributes al2; print ")"
282: | PTR (al, d) ->
283: print "* ";
284: print_attributes al; space ();
285: print_decl n d
286: | ARRAY (d, al, e) ->
287: print_decl n d;
288: print "[";
289: print_attributes al;
290: if e <> NOTHING then print_expression e;
291: print "]"
292: | PROTO(d, args, isva) ->
293: comprint "proto(";
294: print_decl n d;
295: print "(";
296: print_params args isva;
297: print ")";
298: comprint ")"
299:
300:
301: and print_fields (flds : field_group list) =
302: if flds = [] then print " { } "
303: else begin
304: print " {";
305: indent ();
306: List.iter
307: (fun fld -> print_field_group fld; print ";"; new_line ())
308: flds;
309: unindent ();
310: print "} "
311: end
312:
313: and print_enum_items items =
314: if items = [] then print " { } "
315: else begin
316: print " {";
317: indent ();
318: print_commas
319: true
320: (fun (id, exp, loc) -> print id;
321: if exp = NOTHING then ()
322: else begin
323: space ();
324: print "= ";
325: print_expression exp
326: end)
327: items;
328: unindent ();
329: print "} ";
330: end
331:
332:
333: and print_onlytype (specs, dt) =
334: print_specifiers specs;
335: print_decl "" dt
336:
337: and print_name ((n, decl, attrs, _) : name) =
338: print_decl n decl;
339: space ();
340: print_attributes attrs
341:
342: and print_init_name ((n, i) : init_name) =
343: print_name n;
344: if i <> NO_INIT then begin
345: space ();
346: print "= ";
347: print_init_expression i
348: end
349:
350: and print_name_group (specs, names) =
351: print_specifiers specs;
352: print_commas false print_name names
353:
354: and print_field_group (specs, fields) =
355: print_specifiers specs;
356: print_commas false print_field fields
357:
358:
359: and print_field (name, widtho) =
360: print_name name;
361: (match widtho with
362: None -> ()
363: | Some w -> print " : "; print_expression w)
364:
365: and print_init_name_group (specs, names) =
366: print_specifiers specs;
367: print_commas false print_init_name names
368:
369: and print_single_name (specs, name) =
370: print_specifiers specs;
371: print_name name
372:
373: and print_params (pars : single_name list) (ell : bool) =
374: print_commas false print_single_name pars;
375: if ell then print (if pars = [] then "..." else ", ...") else ()
376:
377: and print_old_params pars ell =
378: print_commas false (fun id -> print id) pars;
379: if ell then print (if pars = [] then "..." else ", ...") else ()
380:
381:
382: (*
383: ** Expression printing
384: ** Priorities
385: ** 16 variables
386: ** 15 . -> [] call()
387: ** 14 ++, -- (post)
388: ** 13 ++ -- (pre) ~ ! - + & *(cast)
389: ** 12 * / %
390: ** 11 + -
391: ** 10 << >>
392: ** 9 < <= > >=
393: ** 8 == !=
394: ** 7 &
395: ** 6 ^
396: ** 5 |
397: ** 4 &&
398: ** 3 ||
399: ** 2 ? :
400: ** 1 = ?=
401: ** 0 ,
402: *)
403: and get_operator exp =
404: match exp with
405: NOTHING -> ("", 16)
406: | UNARY (op, _) ->
407: (match op with
408: MINUS -> ("-", 13)
409: | PLUS -> ("+", 13)
410: | NOT -> ("!", 13)
411: | BNOT -> ("~", 13)
412: | MEMOF -> ("*", 13)
413: | ADDROF -> ("&", 13)
414: | PREINCR -> ("++", 13)
415: | PREDECR -> ("--", 13)
416: | POSINCR -> ("++", 14)
417: | POSDECR -> ("--", 14))
418: | LABELADDR s -> ("", 16) (* Like a constant *)
419: | BINARY (op, _, _) ->
420: (match op with
421: MUL -> ("*", 12)
422: | DIV -> ("/", 12)
423: | MOD -> ("%", 12)
424: | ADD -> ("+", 11)
425: | SUB -> ("-", 11)
426: | SHL -> ("<<", 10)
427: | SHR -> (">>", 10)
428: | LT -> ("<", 9)
429: | LE -> ("<=", 9)
430: | GT -> (">", 9)
431: | GE -> (">=", 9)
432: | EQ -> ("==", 8)
433: | NE -> ("!=", 8)
434: | BAND -> ("&", 7)
435: | XOR -> ("^", 6)
436: | BOR -> ("|", 5)
437: | AND -> ("&&", 4)
438: | OR -> ("||", 3)
439: | ASSIGN -> ("=", 1)
440: | ADD_ASSIGN -> ("+=", 1)
441: | SUB_ASSIGN -> ("-=", 1)
442: | MUL_ASSIGN -> ("*=", 1)
443: | DIV_ASSIGN -> ("/=", 1)
444: | MOD_ASSIGN -> ("%=", 1)
445: | BAND_ASSIGN -> ("&=", 1)
446: | BOR_ASSIGN -> ("|=", 1)
447: | XOR_ASSIGN -> ("^=", 1)
448: | SHL_ASSIGN -> ("<<=", 1)
449: | SHR_ASSIGN -> (">>=", 1))
450: | QUESTION _ -> ("", 2)
451: | CAST _ -> ("", 13)
452: | CALL _ -> ("", 15)
453: | COMMA _ -> ("", 0)
454: | CONSTANT _ -> ("", 16)
455: | VARIABLE name -> ("", 16)
456: | EXPR_SIZEOF exp -> ("", 16)
457: | TYPE_SIZEOF _ -> ("", 16)
458: | EXPR_ALIGNOF exp -> ("", 16)
459: | TYPE_ALIGNOF _ -> ("", 16)
460: | INDEX (exp, idx) -> ("", 15)
461: | MEMBEROF (exp, fld) -> ("", 15)
462: | MEMBEROFPTR (exp, fld) -> ("", 15)
463: | GNU_BODY _ -> ("", 17)
464: | EXPR_PATTERN _ -> ("", 16) (* sm: not sure about this *)
465:
466: and print_comma_exps exps =
467: print_commas false print_expression exps
468:
469: and print_init_expression (iexp: init_expression) : unit =
470: match iexp with
471: NO_INIT -> ()
472: | SINGLE_INIT e -> print_expression e
473: | COMPOUND_INIT initexps ->
474: let doinitexp = function
475: NEXT_INIT, e -> print_init_expression e
476: | i, e ->
477: let rec doinit = function
478: NEXT_INIT -> ()
479: | INFIELD_INIT (fn, i) -> print ("." ^ fn); doinit i
480: | ATINDEX_INIT (e, i) ->
481: print "[";
482: print_expression e;
483: print "]";
484: doinit i
485: | ATINDEXRANGE_INIT (s, e) ->
486: print "[";
487: print_expression s;
488: print " ... ";
489: print_expression e;
490: print "]"
491: in
492: doinit i; print " = ";
493: print_init_expression e
494: in
495: print "{";
496: print_commas false doinitexp initexps;
497: print "}"
498:
499: and print_expression (exp: expression) = print_expression_level 1 exp
500:
501: and print_expression_level (lvl: int) (exp : expression) =
502: let (txt, lvl') = get_operator exp in
503: let _ = if lvl > lvl' then print "(" else () in
504: let _ = match exp with
505: NOTHING -> ()
506: | UNARY (op, exp') ->
507: (match op with
508: POSINCR | POSDECR ->
509: print_expression_level lvl' exp';
510: print txt
511: | _ ->
512: print txt; space (); (* Print the space to avoid --5 *)
513: print_expression_level lvl' exp')
514: | LABELADDR l -> print ("&& " ^ l)
515: | BINARY (op, exp1, exp2) ->
516: (*if (op = SUB) && (lvl <= lvl') then print "(";*)
517: print_expression_level lvl' exp1;
518: space ();
519: print txt;
520: space ();
521: (*print_expression exp2 (if op = SUB then (lvl' + 1) else lvl');*)
522: print_expression_level (lvl' + 1) exp2
523: (*if (op = SUB) && (lvl <= lvl') then print ")"*)
524: | QUESTION (exp1, exp2, exp3) ->
525: print_expression_level 2 exp1;
526: space ();
527: print "? ";
528: print_expression_level 2 exp2;
529: space ();
530: print ": ";
531: print_expression_level 2 exp3;
532: | CAST (typ, iexp) ->
533: print "(";
534: print_onlytype typ;
535: print ")";
536: (* Always print parentheses. In a small number of cases when we print
537: * constants we don't need them *)
538: (match iexp with
539: SINGLE_INIT e -> print_expression_level 15 e
540: | COMPOUND_INIT _ -> (* print "("; *)
541: print_init_expression iexp
542: (* ; print ")" *)
543: | NO_INIT -> print "<NO_INIT in cast. Should never arise>")
544:
545: | CALL (VARIABLE "__builtin_va_arg", [arg; TYPE_SIZEOF (bt, dt)]) ->
546: comprint "variable";
547: print "__builtin_va_arg";
548: print "(";
549: print_expression_level 1 arg;
550: print ",";
551: print_onlytype (bt, dt);
552: print ")"
553: | CALL (exp, args) ->
554: print_expression_level 16 exp;
555: print "(";
556: print_comma_exps args;
557: print ")"
558: | COMMA exps ->
559: print_comma_exps exps
560: | CONSTANT cst ->
561: (match cst with
562: CONST_INT i -> print i
563: | CONST_FLOAT r -> print r
564: | CONST_CHAR c -> print ("'" ^ escape_wstring c ^ "'")
565: | CONST_WCHAR c -> print ("L'" ^ escape_wstring c ^ "'")
566: | CONST_STRING s -> print_string s
567: | CONST_WSTRING ws -> print_wstring ws)
568: | VARIABLE name ->
569: comprint "variable";
570: print name
571: | EXPR_SIZEOF exp ->
572: print "sizeof(";
573: print_expression_level 0 exp;
574: print ")"
575: | TYPE_SIZEOF (bt,dt) ->
576: print "sizeof(";
577: print_onlytype (bt, dt);
578: print ")"
579: | EXPR_ALIGNOF exp ->
580: print "__alignof__(";
581: print_expression_level 0 exp;
582: print ")"
583: | TYPE_ALIGNOF (bt,dt) ->
584: print "__alignof__(";
585: print_onlytype (bt, dt);
586: print ")"
587: | INDEX (exp, idx) ->
588: print_expression_level 16 exp;
589: print "[";
590: print_expression_level 0 idx;
591: print "]"
592: | MEMBEROF (exp, fld) ->
593: print_expression_level 16 exp;
594: print ("." ^ fld)
595: | MEMBEROFPTR (exp, fld) ->
596: print_expression_level 16 exp;
597: print ("->" ^ fld)
598: | GNU_BODY (blk) ->
599: print "(";
600: print_block blk;
601: print ")"
602: | EXPR_PATTERN (name) ->
603: print ("@expr(" ^ name ^ ") ")
604: in
605: if lvl > lvl' then print ")" else ()
606:
607:
608: (*
609: ** Statement printing
610: *)
611: and print_statement stat =
612: match stat with
613: NOP (loc) ->
614: setLoc(loc);
615: print ";";
616: new_line ()
617: | COMPUTATION (exp, loc) ->
618: setLoc(loc);
619: print_expression exp;
620: print ";";
621: new_line ()
622: | BLOCK (blk, loc) -> print_block blk
623:
624: | SEQUENCE (s1, s2, loc) ->
625: setLoc(loc);
626: print_statement s1;
627: print_statement s2;
628: | IF (exp, s1, s2, loc) ->
629: setLoc(loc);
630: print "if(";
631: print_expression_level 0 exp;
632: print ")";
633: print_substatement s1;
634: (match s2 with
635: | NOP(_) -> ()
636: | _ -> begin
637: print "else";
638: print_substatement s2;
639: end)
640: | WHILE (exp, stat, loc) ->
641: setLoc(loc);
642: print "while(";
643: print_expression_level 0 exp;
644: print ")";
645: print_substatement stat
646: | DOWHILE (exp, stat, loc) ->
647: setLoc(loc);
648: print "do";
649: print_substatement stat;
650: print "while(";
651: print_expression_level 0 exp;
652: print ");";
653: new_line ();
654: | FOR (fc1, exp2, exp3, stat, loc) ->
655: setLoc(loc);
656: print "for(";
657: (match fc1 with
658: FC_EXP exp1 -> print_expression_level 0 exp1; print ";"
659: | FC_DECL dec1 -> print_def dec1);
660: space ();
661: print_expression_level 0 exp2;
662: print ";";
663: space ();
664: print_expression_level 0 exp3;
665: print ")";
666: print_substatement stat
667: | BREAK (loc)->
668: setLoc(loc);
669: print "break;"; new_line ()
670: | CONTINUE (loc) ->
671: setLoc(loc);
672: print "continue;"; new_line ()
673: | RETURN (exp, loc) ->
674: setLoc(loc);
675: print "return";
676: if exp = NOTHING
677: then ()
678: else begin
679: print " ";
680: print_expression_level 1 exp
681: end;
682: print ";";
683: new_line ()
684: | SWITCH (exp, stat, loc) ->
685: setLoc(loc);
686: print "switch(";
687: print_expression_level 0 exp;
688: print ")";
689: print_substatement stat
690: | CASE (exp, stat, loc) ->
691: setLoc(loc);
692: unindent ();
693: print "case ";
694: print_expression_level 1 exp;
695: print ":";
696: indent ();
697: print_substatement stat
698: | CASERANGE (expl, exph, stat, loc) ->
699: setLoc(loc);
700: unindent ();
701: print "case ";
702: print_expression expl;
703: print " ... ";
704: print_expression exph;
705: print ":";
706: indent ();
707: print_substatement stat
708: | DEFAULT (stat, loc) ->
709: setLoc(loc);
710: unindent ();
711: print "default :";
712: indent ();
713: print_substatement stat
714: | LABEL (name, stat, loc) ->
715: setLoc(loc);
716: print (name ^ ":");
717: space ();
718: print_substatement stat
719: | GOTO (name, loc) ->
720: setLoc(loc);
721: print ("goto " ^ name ^ ";");
722: new_line ()
723: | COMPGOTO (exp, loc) ->
724: setLoc(loc);
725: print ("goto *"); print_expression exp; print ";"; new_line ()
726: | DEFINITION d ->
727: print_def d
728: | ASM (attrs, tlist, outs, ins, clobs, loc) ->
729: setLoc(loc);
730: let print_asm_operand (cnstr, e) =
731: print_string cnstr; space (); print_expression_level 100 e
732: in
733: if !msvcMode then begin
734: print "__asm {";
735: print_list (fun () -> new_line()) print tlist; (* templates *)
736: print "};"
737: end else begin
738: print "__asm__ ";
739: print_attributes attrs;
740: print "(";
741: print_list (fun () -> new_line()) print_string tlist; (* templates *)
742: if outs <> [] || ins <> [] || clobs <> [] then begin
743: print ":"; space ();
744: print_commas false print_asm_operand outs;
745: if ins <> [] || clobs <> [] then begin
746: print ":"; space ();
747: print_commas false print_asm_operand ins;
748: if clobs <> [] then begin
749: print ":"; space ();
750: print_commas false print_string clobs
751: end;
752: end
753: end;
754: print ");"
755: end;
756: new_line ()
757: | TRY_FINALLY (b, h, loc) ->
758: setLoc loc;
759: print "__try ";
760: print_block b;
761: print "__finally ";
762: print_block h
763:
764: | TRY_EXCEPT (b, e, h, loc) ->
765: setLoc loc;
766: print "__try ";
767: print_block b;
768: print "__except("; print_expression e; print ")";
769: print_block h
770:
771: and print_block blk =
772: new_line();
773: print "{";
774: indent ();
775: if blk.blabels <> [] then begin
776: print "__label__ ";
777: print_commas false print blk.blabels;
778: print ";";
779: new_line ();
780: end;
781: if blk.battrs <> [] then begin
782: List.iter print_attribute blk.battrs;
783: new_line ();
784: end;
785: List.iter print_statement blk.bstmts;
786: unindent ();
787: print "}";
788: new_line ()
789:
790: and print_substatement stat =
791: match stat with
792: IF _
793: | SEQUENCE _
794: | DOWHILE _ ->
795: new_line ();
796: print "{";
797: indent ();
798: print_statement stat;
799: unindent ();
800: print "}";
801: new_line ();
802: | BLOCK _ ->
803: print_statement stat
804: | _ ->
805: indent ();
806: print_statement stat;
807: unindent ()
808:
809:
810: (*
811: ** GCC Attributes
812: *)
813: and print_attribute (name,args) =
814: if args = [] then print (
815: match name with
816: "restrict" -> "__restrict"
817: (* weimer: Fri Dec 7 17:12:35 2001
818: * must not print 'restrict' and the code below does allows some
819: * plain 'restrict's to slip though! *)
820: | x -> x)
821: else begin
822: print name;
823: print "("; if name = "__attribute__" then print "(";
824: (match args with
825: [VARIABLE "aconst"] -> print "const"
826: | [VARIABLE "restrict"] -> print "__restrict"
827: | _ -> print_commas false (fun e -> print_expression e) args);
828: print ")"; if name = "__attribute__" then print ")"
829: end
830:
831: (* Print attributes. *)
832: and print_attributes attrs =
833: List.iter (fun a -> print_attribute a; space ()) attrs
834:
835: and print_base b = match b with
836: | `Public_virtual n -> print "public "; print "virtual "; print n
837: | `Protected_virtual n -> print "protected "; print "virtual "; print n
838: | `Private_virtual n -> print "private "; print "virtual "; print n
839: | `Public n -> print n
840: | `Protected n -> print "protected "; print n
841: | `Private n -> print "private "; print n
842:
843:
844: (*
845: ** Declaration printing
846: *)
847: and print_defs defs =
848: let prev = ref false in
849: List.iter
850: (fun def ->
851: (match def with
852: DECDEF _ -> prev := false
853: | _ ->
854: if not !prev then force_new_line ();
855: prev := true);
856: print_def def)
857: defs
858:
859: and print_def def =
860: match def with
861: FUNDEF (proto, body, loc, _) ->
862: comprint "fundef";
863: if !printCounters then begin
864: try
865: let fname =
866: match proto with
867: (_, (n, _, _, _)) -> n
868: in
869: print_def (DECDEF (([SpecType Tint],
870: [(fname ^ "__counter", JUSTBASE, [], cabslu),
871: NO_INIT]), loc));
872: with Not_found -> print "/* can't print the counter */"
873: end;
874: setLoc(loc);
875: print_single_name proto;
876: print_block body;
877: force_new_line ();
878:
879: | DECDEF (names, loc) ->
880: comprint "decdef";
881: setLoc(loc);
882: print_init_name_group names;
883: print ";";
884: new_line ()
885:
886: | TYPEDEF (names, loc) ->
887: comprint "typedef";
888: setLoc(loc);
889: print_name_group names;
890: print ";";
891: new_line ();
892: force_new_line ()
893:
894: | ONLYTYPEDEF (specs, loc) ->
895: comprint "onlytypedef";
896: setLoc(loc);
897: print_specifiers specs;
898: print ";";
899: new_line ();
900: force_new_line ()
901:
902: | GLOBASM (asm, loc) ->
903: setLoc(loc);
904: print "__asm__ ("; print_string asm; print ");";
905: new_line ();
906: force_new_line ()
907:
908: | PRAGMA (a,loc) ->
909: setLoc(loc);
910: force_new_line ();
911: print "#pragma ";
912: let oldwidth = !width in
913: width := 1000000; (* Do not wrap pragmas *)
914: print_expression a;
915: width := oldwidth;
916: force_new_line ()
917:
918: | LINKAGE (n, loc, dl) ->
919: setLoc (loc);
920: force_new_line ();
921: print "extern "; print_string n; print_string " {";
922: List.iter print_def dl;
923: print_string "}";
924: force_new_line ()
925:
926: | NAMESPACE (n, loc, dl) ->
927: setLoc (loc);
928: force_new_line ();
929: print "namespace "; print n; print_string " {";
930: indent();
931: List.iter print_def dl;
932: unindent();
933: print_string "}";
934: force_new_line ()
935:
936: | TRANSFORMER(srcdef, destdeflist, loc) ->
937: setLoc(loc);
938: print "@transform {";
939: force_new_line();
940: print "{";
941: force_new_line();
942: indent ();
943: print_def srcdef;
944: unindent();
945: print "}";
946: force_new_line();
947: print "to {";
948: force_new_line();
949: indent();
950: List.iter print_def destdeflist;
951: unindent();
952: print "}";
953: force_new_line()
954:
955: | EXPRTRANSFORMER(srcexpr, destexpr, loc) ->
956: setLoc(loc);
957: print "@transformExpr { ";
958: print_expression srcexpr;
959: print " } to { ";
960: print_expression destexpr;
961: print " }";
962: force_new_line()
963:
964:
965: (* sm: print a comment if the printComments flag is set *)
966: and comprint (str : string) : unit =
967: begin
968: if (!printComments) then (
969: print "/*";
970: print str;
971: print "*/ "
972: )
973: else
974: ()
975: end
976:
977: (* sm: yield either the given string, or "", depending on printComments *)
978: and comstring (str : string) : string =
979: begin
980: if (!printComments) then
981: str
982: else
983: ""
984: end
985:
986:
987: (* print abstrac_syntax -> ()
988: ** Flx_cil_pretty printing the given abstract syntax program.
989: *)
990: let printFile (result : out_channel) ((fname, defs) : file) =
991: out := result;
992: print_defs defs;
993: flush () (* sm: should do this here *)
994:
995: let set_tab t = tab := t
996: let set_width w = width := w
997:
Start ocaml section to src/flx_cil_frontc.ml[1
/1
]
1: # 4179 "./lpsrc/flx_frontc.ipk"
2:
3:
4: module E = Flx_cil_errormsg
5: open Flx_cil_trace
6: open Flx_cil_pretty
7:
8: (* Output management *)
9: let out : out_channel option ref = ref None
10: let close_me = ref false
11:
12: let close_output _ =
13: match !out with
14: None -> ()
15: | Some o -> begin
16: flush o;
17: if !close_me then close_out o else ();
18: close_me := false
19: end
20:
21: let set_output filename =
22: close_output ();
23: (try out := Some (open_out filename)
24: with (Sys_error msg) ->
25: output_string stderr ("Error while opening output: " ^ msg); exit 1);
26: close_me := true
27:
28: (* Signal that we are in MS VC mode *)
29: let setMSVCMode () =
30: Flx_cil_cprint.msvcMode := true
31:
32: (* filename for patching *)
33: let patchFileName : string ref = ref "" (* by default do no patching *)
34:
35: (* patching file contents *)
36: let patchFile : Flx_cil_cabs.file option ref = ref None
37:
38: (* whether to print the patched CABS files *)
39: let printFlx_cil_patchedFiles : bool ref = ref false
40:
41: (* whether to print a file of prototypes after parsing *)
42: let doPrintProtos : bool ref = ref false
43:
44: (* this seems like something that should be built-in.. *)
45: let isNone (o : 'a option) : bool =
46: begin
47: match o with
48: | Some _ -> false
49: | None -> true
50: end
51:
52: (*
53: ** Argument definition
54: *)
55: let args : (string * Arg.spec * string) list =
56: [
57: "--cabsonly", Arg.String set_output, "<fname>: CABS output file name";
58: "--printComments", Arg.Unit (fun _ -> Flx_cil_cprint.printComments := true),
59: ": print cabs tree structure in comments in cabs output";
60: "--patchFile", Arg.String (fun pf -> patchFileName := pf),
61: "<fname>: name the file containing patching transformations";
62: "--printFlx_cil_patched", Arg.Unit (fun _ -> printFlx_cil_patchedFiles := true),
63: ": print patched CABS files after patching, to *.patched";
64: "--printProtos", Arg.Unit (fun _ -> doPrintProtos := true),
65: ": print prototypes to safec.proto.h after parsing";
66: ]
67:
68: exception ParseError of string
69: exception Flx_cil_cabsOnly
70:
71: (* parse, and apply patching *)
72: let rec parse_to_cabs fname lang =
73: begin
74: (* parse the patch file if it isn't parsed already *)
75: if ((!patchFileName <> "") && (isNone !patchFile)) then (
76: (* parse the patch file *)
77: patchFile := Some(parse_to_cabs_inner !patchFileName lang);
78: if !E.hadErrors then
79: (failwith "There were parsing errors in the patch file")
80: );
81:
82: (* now parse the file we came here to parse *)
83: let cabs = parse_to_cabs_inner fname lang in
84: if !E.hadErrors then
85: E.s (E.error "There were parsing errors in %s\n" fname);
86:
87: (* and apply the patch file, return transformed file *)
88: let patched = match !patchFile with
89:
90: | Some(pf) -> (
91: (* save old value of out so I can use it for debugging during patching *)
92: let oldOut = !out in
93:
94: (* reset out so we don't try to print the patch file to it *)
95: out := None;
96:
97: (trace "patch" (dprintf "newpatching %s\n" fname));
98: let result = (Flx_cil_stats.time "newpatch" (Flx_cil_patch.applyFlx_cil_patch pf) cabs) in
99:
100: if (!printFlx_cil_patchedFiles) then begin
101: let outFname:string = fname ^ ".patched" in
102: (trace "patch" (dprintf "printing patched version of %s to %s\n"
103: fname outFname));
104: let o = (open_out outFname) in
105: (Flx_cil_cprint.printFile o result);
106: (close_out o)
107: end;
108:
109: (* restore out *)
110: Flx_cil_cprint.flush ();
111: out := oldOut;
112:
113: result
114: )
115: | None -> cabs
116: in
117:
118: (* print it ... *)
119: (match !out with
120: Some o -> begin
121: (trace "sm" (dprintf "writing the cabs output\n"));
122: output_string o ("/* Generated by Flx_cil_frontc */\n");
123: Flx_cil_stats.time "printCABS" (Flx_cil_cprint.printFile o) patched;
124: close_output ();
125: raise Flx_cil_cabsOnly
126: end
127: | None -> ());
128: if !E.hadErrors then
129: raise Parsing.Parse_error;
130:
131: (* and return the patched source *)
132: patched
133: end
134:
135:
136: (* just parse *)
137: and parse_to_cabs_inner (fname : string) (lang : Flx_cil_cabs.lang_t) =
138: try
139: if !E.verboseFlag then ignore (E.log "Flx_cil_frontc is parsing %s\n" fname);
140: flush !E.logChannel;
141: E.hadErrors := false;
142: let lexbuf = Flx_cil_clexer.init fname lang in
143: let cabs = Flx_cil_stats.time "parse" (Flx_cil_cparser.file Flx_cil_clexer.initial) lexbuf in
144: Flx_cil_clexer.finish ();
145: (fname, cabs)
146: with (Sys_error msg) -> begin
147: ignore (E.log "Cannot open %s : %s\n" fname msg);
148: close_output ();
149: raise (ParseError("Cannot open " ^ fname ^ ": " ^ msg ^ "\n"))
150: end
151: | Parsing.Parse_error -> begin
152: ignore (E.log "Parsing error\n");
153: close_output ();
154: raise (ParseError("Parse error"))
155: end
156: | e -> begin
157: ignore (E.log "Caught %s while parsing\n" (Printexc.to_string e));
158: raise e
159: end
160:
161:
162: (* print to safec.proto.h the prototypes of all functions that are defined *)
163: let printPrototypes ((fname, file) : Flx_cil_cabs.file) : unit =
164: begin
165: (*ignore (E.log "file has %d defns\n" (List.length file));*)
166:
167: let chan = open_out "safec.proto.h" in
168: ignore (fprintf chan "/* generated prototypes file, %d defs */\n" (List.length file));
169: Flx_cil_cprint.out := chan;
170:
171: let counter : int ref = ref 0 in
172:
173: let rec loop (d : Flx_cil_cabs.definition) = begin
174: match d with
175: | Flx_cil_cabs.FUNDEF(name, _, loc, _) -> (
176: match name with
177: | (_, (funcname, Flx_cil_cabs.PROTO(_,_,_), _, _)) -> (
178: incr counter;
179: ignore (fprintf chan "\n/* %s from %s:%d */\n"
180: funcname loc.Flx_cil_cabs.filename loc.Flx_cil_cabs.lineno);
181: flush chan;
182: Flx_cil_cprint.print_single_name name;
183: Flx_cil_cprint.print_unescaped_string ";";
184: Flx_cil_cprint.force_new_line ();
185: Flx_cil_cprint.flush ()
186: )
187: | _ -> ()
188: )
189:
190: | _ -> ()
191: end in
192: (List.iter loop file);
193:
194: ignore (fprintf chan "\n/* wrote %d prototypes */\n" !counter);
195: close_out chan;
196: ignore (E.log "printed %d prototypes from %d defns to safec.proto.h\n"
197: !counter (List.length file))
198: end
199:
200:
201:
202: let parse fname lang =
203: (trace "sm" (dprintf "parsing %s to Flx_cil_cabs\n" fname));
204: let cabs = parse_to_cabs fname lang in
205: (* Now (return a function that will) convert to CIL *)
206: fun _ ->
207: (trace "sm" (dprintf "converting %s from Flx_cil_cabs to CIL\n" fname));
208: let cil = Flx_cil_stats.time "conv" Flx_cil_cabs2cil.convFile cabs in
209: if !doPrintProtos then (printPrototypes cabs);
210: cil
211:
212:
Start ocaml section to src/flx_cil_frontc.mli[1
/1
]
1: # 4392 "./lpsrc/flx_frontc.ipk"
2:
3:
4: (* Signal that we are in MS VC mode *)
5: val setMSVCMode: unit -> unit
6:
7:
8: (* Parse a file in *)
9: exception ParseError of string
10:
11: (* Raised when the front-end is requested to print the CABS and return *)
12: exception Flx_cil_cabsOnly
13:
14: (* additional command line arguments *)
15: val args: (string * Arg.spec * string) list
16:
17: (* the main command to parse a file. Return a thunk that can be used to
18: * convert the AST to CIL. *)
19: val parse: string -> Flx_cil_cabs.lang_t -> (unit -> Flx_cil_cil.file)
20:
Start ocaml section to src/flx_cil_lexerhack.mli[1
/1
]
1: # 4413 "./lpsrc/flx_frontc.ipk"
2: val get_lang : (unit -> Flx_cil_cabs.lang_t) ref
3: val add_identifier : (string -> unit) ref
4: val add_type : (string -> unit) ref
5: val push_context : (unit -> unit) ref
6: val pop_context : (unit -> unit) ref
7: val push_class: (string-> unit) ref
8: val pop_class : (unit -> unit) ref
9: val currentPattern : string ref
10:
Start ocaml section to src/flx_cil_lexerhack.ml[1
/1
]
1: # 4424 "./lpsrc/flx_frontc.ipk"
2:
3: module E = Flx_cil_errormsg
4:
5: (* We provide here a pointer to a function. It will be set by the lexer and
6: * used by the parser. In Ocaml lexers depend on parsers, so we we have put
7: * such functions in a separate module. *)
8: let add_identifier: (string -> unit) ref =
9: ref (fun _ -> E.s (E.bug "You called an uninitialized add_identifier"))
10:
11: let add_type: (string -> unit) ref =
12: ref (fun _ -> E.s (E.bug "You called an uninitialized add_type"))
13:
14: let push_context: (unit -> unit) ref =
15: ref (fun _ -> E.s (E.bug "You called an uninitialized push_context"))
16:
17: let pop_context: (unit -> unit) ref =
18: ref (fun _ -> E.s (E.bug "You called an uninitialized pop_context"))
19:
20: let push_class: (string -> unit) ref =
21: ref (fun _ -> E.s (E.bug "You called an uninitialized push_class"))
22:
23: let pop_class : (unit -> unit) ref =
24: ref (fun _ -> E.s (E.bug "You called an uninitialized pop_class"))
25:
26: let get_lang: (unit -> Flx_cil_cabs.lang_t) ref =
27: ref (fun _ -> E.s (E.bug "You called an uninitialized get_lang"))
28:
29: (* Keep here the current pattern for formatparse *)
30: let currentPattern = ref ""
31: