HCoop / bpt / coccinelle.git / blob
? search:


db754122e58824fc0c6349ce4a01384634657931
[bpt/coccinelle.git] / parsing_cocci / parse_cocci.ml
1 (*
2 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
3 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
4 * This file is part of Coccinelle.
5 *
6 * Coccinelle is free software: you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation, according to version 2 of the License.
9 *
10 * Coccinelle is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
14 *
15 * You should have received a copy of the GNU General Public License
16 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
17 *
18 * The authors reserve the right to distribute this or future versions of
19 * Coccinelle under other licenses.
20 *)
21
22
23 (* splits the entire file into minus and plus fragments, and parses each
24 separately (thus duplicating work for the parsing of the context elements) *)
25
26 module D = Data
27 module PC = Parser_cocci_menhir
28 module V0 = Visitor_ast0
29 module VT0 = Visitor_ast0_types
30 module Ast = Ast_cocci
31 module Ast0 = Ast0_cocci
32 let pr = Printf.sprintf
33 (*let pr2 s = prerr_string s; prerr_string "\n"; flush stderr*)
34 let pr2 s = Printf.printf "%s\n" s
35
36 (* for isomorphisms. all should be at the front!!! *)
37 let reserved_names =
38 ["all";"optional_storage";"optional_qualifier";"value_format";"comm_assoc"]
39
40 (* ----------------------------------------------------------------------- *)
41 (* Debugging... *)
42
43 let line_type (d,_,_,_,_,_,_,_) = d
44
45 let line_type2c tok =
46 match line_type tok with
47 D.MINUS | D.OPTMINUS | D.UNIQUEMINUS -> ":-"
48 | D.PLUS -> ":+"
49 | D.CONTEXT | D.UNIQUE | D.OPT -> ""
50
51 let token2c (tok,_) =
52 match tok with
53 PC.TIdentifier -> "identifier"
54 | PC.TType -> "type"
55 | PC.TParameter -> "parameter"
56 | PC.TConstant -> "constant"
57 | PC.TExpression -> "expression"
58 | PC.TIdExpression -> "idexpression"
59 | PC.TInitialiser -> "initialiser"
60 | PC.TStatement -> "statement"
61 | PC.TPosition -> "position"
62 | PC.TPosAny -> "any"
63 | PC.TFunction -> "function"
64 | PC.TLocal -> "local"
65 | PC.Tlist -> "list"
66 | PC.TFresh -> "fresh"
67 | PC.TPure -> "pure"
68 | PC.TContext -> "context"
69 | PC.TTypedef -> "typedef"
70 | PC.TDeclarer -> "declarer"
71 | PC.TIterator -> "iterator"
72 | PC.TName -> "name"
73 | PC.TRuleName str -> "rule_name-"^str
74 | PC.TUsing -> "using"
75 | PC.TPathIsoFile str -> "path_iso_file-"^str
76 | PC.TDisable -> "disable"
77 | PC.TExtends -> "extends"
78 | PC.TDepends -> "depends"
79 | PC.TOn -> "on"
80 | PC.TEver -> "ever"
81 | PC.TNever -> "never"
82 | PC.TExists -> "exists"
83 | PC.TForall -> "forall"
84 | PC.TReverse -> "reverse"
85 | PC.TError -> "error"
86 | PC.TWords -> "words"
87 | PC.TGenerated -> "generated"
88
89 | PC.TNothing -> "nothing"
90
91 | PC.Tchar(clt) -> "char"^(line_type2c clt)
92 | PC.Tshort(clt) -> "short"^(line_type2c clt)
93 | PC.Tint(clt) -> "int"^(line_type2c clt)
94 | PC.Tdouble(clt) -> "double"^(line_type2c clt)
95 | PC.Tfloat(clt) -> "float"^(line_type2c clt)
96 | PC.Tlong(clt) -> "long"^(line_type2c clt)
97 | PC.Tvoid(clt) -> "void"^(line_type2c clt)
98 | PC.Tstruct(clt) -> "struct"^(line_type2c clt)
99 | PC.Tunion(clt) -> "union"^(line_type2c clt)
100 | PC.Tenum(clt) -> "enum"^(line_type2c clt)
101 | PC.Tunsigned(clt) -> "unsigned"^(line_type2c clt)
102 | PC.Tsigned(clt) -> "signed"^(line_type2c clt)
103 | PC.Tstatic(clt) -> "static"^(line_type2c clt)
104 | PC.Tinline(clt) -> "inline"^(line_type2c clt)
105 | PC.Ttypedef(clt) -> "typedef"^(line_type2c clt)
106 | PC.Tattr(s,clt) -> s^(line_type2c clt)
107 | PC.Tauto(clt) -> "auto"^(line_type2c clt)
108 | PC.Tregister(clt) -> "register"^(line_type2c clt)
109 | PC.Textern(clt) -> "extern"^(line_type2c clt)
110 | PC.Tconst(clt) -> "const"^(line_type2c clt)
111 | PC.Tvolatile(clt) -> "volatile"^(line_type2c clt)
112
113 | PC.TPragma(s,_) -> s
114 | PC.TIncludeL(s,clt) -> (pr "#include \"%s\"" s)^(line_type2c clt)
115 | PC.TIncludeNL(s,clt) -> (pr "#include <%s>" s)^(line_type2c clt)
116 | PC.TDefine(clt,_) -> "#define"^(line_type2c clt)
117 | PC.TDefineParam(clt,_,_) -> "#define_param"^(line_type2c clt)
118 | PC.TMinusFile(s,clt) -> (pr "--- %s" s)^(line_type2c clt)
119 | PC.TPlusFile(s,clt) -> (pr "+++ %s" s)^(line_type2c clt)
120
121 | PC.TInc(clt) -> "++"^(line_type2c clt)
122 | PC.TDec(clt) -> "--"^(line_type2c clt)
123
124 | PC.TIf(clt) -> "if"^(line_type2c clt)
125 | PC.TElse(clt) -> "else"^(line_type2c clt)
126 | PC.TWhile(clt) -> "while"^(line_type2c clt)
127 | PC.TFor(clt) -> "for"^(line_type2c clt)
128 | PC.TDo(clt) -> "do"^(line_type2c clt)
129 | PC.TSwitch(clt) -> "switch"^(line_type2c clt)
130 | PC.TCase(clt) -> "case"^(line_type2c clt)
131 | PC.TDefault(clt) -> "default"^(line_type2c clt)
132 | PC.TReturn(clt) -> "return"^(line_type2c clt)
133 | PC.TBreak(clt) -> "break"^(line_type2c clt)
134 | PC.TContinue(clt) -> "continue"^(line_type2c clt)
135 | PC.TGoto(clt) -> "goto"^(line_type2c clt)
136 | PC.TIdent(s,clt) -> (pr "ident-%s" s)^(line_type2c clt)
137 | PC.TTypeId(s,clt) -> (pr "typename-%s" s)^(line_type2c clt)
138 | PC.TDeclarerId(s,clt) -> (pr "declarername-%s" s)^(line_type2c clt)
139 | PC.TIteratorId(s,clt) -> (pr "iteratorname-%s" s)^(line_type2c clt)
140 | PC.TMetaDeclarer(_,_,_,clt) -> "declmeta"^(line_type2c clt)
141 | PC.TMetaIterator(_,_,_,clt) -> "itermeta"^(line_type2c clt)
142
143 | PC.TSizeof(clt) -> "sizeof"^(line_type2c clt)
144
145 | PC.TString(x,clt) -> x^(line_type2c clt)
146 | PC.TChar(x,clt) -> x^(line_type2c clt)
147 | PC.TFloat(x,clt) -> x^(line_type2c clt)
148 | PC.TInt(x,clt) -> x^(line_type2c clt)
149
150 | PC.TOrLog(clt) -> "||"^(line_type2c clt)
151 | PC.TAndLog(clt) -> "&&"^(line_type2c clt)
152 | PC.TOr(clt) -> "|"^(line_type2c clt)
153 | PC.TXor(clt) -> "^"^(line_type2c clt)
154 | PC.TAnd (clt) -> "&"^(line_type2c clt)
155 | PC.TEqEq(clt) -> "=="^(line_type2c clt)
156 | PC.TNotEq(clt) -> "!="^(line_type2c clt)
157 | PC.TLogOp(op,clt) ->
158 (match op with
159 Ast.Inf -> "<"
160 | Ast.InfEq -> "<="
161 | Ast.Sup -> ">"
162 | Ast.SupEq -> ">="
163 | _ -> failwith "not possible")
164 ^(line_type2c clt)
165 | PC.TShOp(op,clt) ->
166 (match op with
167 Ast.DecLeft -> "<<"
168 | Ast.DecRight -> ">>"
169 | _ -> failwith "not possible")
170 ^(line_type2c clt)
171 | PC.TPlus(clt) -> "+"^(line_type2c clt)
172 | PC.TMinus(clt) -> "-"^(line_type2c clt)
173 | PC.TMul(clt) -> "*"^(line_type2c clt)
174 | PC.TDmOp(op,clt) ->
175 (match op with
176 Ast.Div -> "/"
177 | Ast.Mod -> "%"
178 | _ -> failwith "not possible")
179 ^(line_type2c clt)
180 | PC.TTilde (clt) -> "~"^(line_type2c clt)
181
182 | PC.TMetaParam(_,_,clt) -> "parammeta"^(line_type2c clt)
183 | PC.TMetaParamList(_,_,_,clt) -> "paramlistmeta"^(line_type2c clt)
184 | PC.TMetaConst(_,_,_,_,clt) -> "constmeta"^(line_type2c clt)
185 | PC.TMetaErr(_,_,_,clt) -> "errmeta"^(line_type2c clt)
186 | PC.TMetaExp(_,_,_,_,clt) -> "expmeta"^(line_type2c clt)
187 | PC.TMetaIdExp(_,_,_,_,clt) -> "idexpmeta"^(line_type2c clt)
188 | PC.TMetaLocalIdExp(_,_,_,_,clt) -> "localidexpmeta"^(line_type2c clt)
189 | PC.TMetaExpList(_,_,_,clt) -> "explistmeta"^(line_type2c clt)
190 | PC.TMetaId(_,_,_,clt) -> "idmeta"^(line_type2c clt)
191 | PC.TMetaType(_,_,clt) -> "typemeta"^(line_type2c clt)
192 | PC.TMetaInit(_,_,clt) -> "initmeta"^(line_type2c clt)
193 | PC.TMetaStm(_,_,clt) -> "stmmeta"^(line_type2c clt)
194 | PC.TMetaStmList(_,_,clt) -> "stmlistmeta"^(line_type2c clt)
195 | PC.TMetaFunc(_,_,_,clt) -> "funcmeta"^(line_type2c clt)
196 | PC.TMetaLocalFunc(_,_,_,clt) -> "funcmeta"^(line_type2c clt)
197 | PC.TMetaPos(_,_,_,clt) -> "posmeta"
198 | PC.TMPtVirg -> ";"
199 | PC.TArobArob -> "@@"
200 | PC.TArob -> "@"
201 | PC.TPArob -> "P@"
202 | PC.TScript -> "script"
203 | PC.TInitialize -> "initialize"
204 | PC.TFinalize -> "finalize"
205
206 | PC.TWhen(clt) -> "WHEN"^(line_type2c clt)
207 | PC.TWhenTrue(clt) -> "WHEN TRUE"^(line_type2c clt)
208 | PC.TWhenFalse(clt) -> "WHEN FALSE"^(line_type2c clt)
209 | PC.TAny(clt) -> "ANY"^(line_type2c clt)
210 | PC.TStrict(clt) -> "STRICT"^(line_type2c clt)
211 | PC.TEllipsis(clt) -> "..."^(line_type2c clt)
212 (*
213 | PC.TCircles(clt) -> "ooo"^(line_type2c clt)
214 | PC.TStars(clt) -> "***"^(line_type2c clt)
215 *)
216
217 | PC.TOEllipsis(clt) -> "<..."^(line_type2c clt)
218 | PC.TCEllipsis(clt) -> "...>"^(line_type2c clt)
219 | PC.TPOEllipsis(clt) -> "<+..."^(line_type2c clt)
220 | PC.TPCEllipsis(clt) -> "...+>"^(line_type2c clt)
221 (*
222 | PC.TOCircles(clt) -> "<ooo"^(line_type2c clt)
223 | PC.TCCircles(clt) -> "ooo>"^(line_type2c clt)
224 | PC.TOStars(clt) -> "<***"^(line_type2c clt)
225 | PC.TCStars(clt) -> "***>"^(line_type2c clt)
226 *)
227 | PC.TBang0 -> "!"
228 | PC.TPlus0 -> "+"
229 | PC.TWhy0 -> "?"
230
231 | PC.TWhy(clt) -> "?"^(line_type2c clt)
232 | PC.TDotDot(clt) -> ":"^(line_type2c clt)
233 | PC.TBang(clt) -> "!"^(line_type2c clt)
234 | PC.TOPar(clt) -> "("^(line_type2c clt)
235 | PC.TOPar0(clt) -> "("^(line_type2c clt)
236 | PC.TMid0(clt) -> "|"^(line_type2c clt)
237 | PC.TCPar(clt) -> ")"^(line_type2c clt)
238 | PC.TCPar0(clt) -> ")"^(line_type2c clt)
239
240 | PC.TOBrace(clt) -> "{"^(line_type2c clt)
241 | PC.TCBrace(clt) -> "}"^(line_type2c clt)
242 | PC.TOCro(clt) -> "["^(line_type2c clt)
243 | PC.TCCro(clt) -> "]"^(line_type2c clt)
244 | PC.TOInit(clt) -> "{"^(line_type2c clt)
245
246 | PC.TPtrOp(clt) -> "->"^(line_type2c clt)
247
248 | PC.TEq(clt) -> "="^(line_type2c clt)
249 | PC.TAssign(_,clt) -> "=op"^(line_type2c clt)
250 | PC.TDot(clt) -> "."^(line_type2c clt)
251 | PC.TComma(clt) -> ","^(line_type2c clt)
252 | PC.TPtVirg(clt) -> ";"^(line_type2c clt)
253
254 | PC.EOF -> "eof"
255 | PC.TLineEnd(clt) -> "line end"
256 | PC.TInvalid -> "invalid"
257 | PC.TFunDecl(clt) -> "fundecl"
258
259 | PC.TIso -> "<=>"
260 | PC.TRightIso -> "=>"
261 | PC.TIsoTopLevel -> "TopLevel"
262 | PC.TIsoExpression -> "Expression"
263 | PC.TIsoArgExpression -> "ArgExpression"
264 | PC.TIsoTestExpression -> "TestExpression"
265 | PC.TIsoStatement -> "Statement"
266 | PC.TIsoDeclaration -> "Declaration"
267 | PC.TIsoType -> "Type"
268 | PC.TScriptData s -> s
269
270 let print_tokens s tokens =
271 Printf.printf "%s\n" s;
272 List.iter (function x -> Printf.printf "%s " (token2c x)) tokens;
273 Printf.printf "\n\n";
274 flush stdout
275
276 type plus = PLUS | NOTPLUS | SKIP
277
278 let plus_attachable only_plus (tok,_) =
279 match tok with
280 PC.Tchar(clt) | PC.Tshort(clt) | PC.Tint(clt) | PC.Tdouble(clt)
281 | PC.Tfloat(clt) | PC.Tlong(clt) | PC.Tvoid(clt) | PC.Tstruct(clt)
282 | PC.Tunion(clt) | PC.Tenum(clt) | PC.Tunsigned(clt) | PC.Tsigned(clt)
283 | PC.Tstatic(clt)
284 | PC.Tinline(clt) | PC.Ttypedef(clt) | PC.Tattr(_,clt)
285 | PC.Tauto(clt) | PC.Tregister(clt)
286 | PC.Textern(clt) | PC.Tconst(clt) | PC.Tvolatile(clt)
287
288 | PC.TIncludeL(_,clt) | PC.TIncludeNL(_,clt) | PC.TDefine(clt,_)
289 | PC.TDefineParam(clt,_,_) | PC.TMinusFile(_,clt) | PC.TPlusFile(_,clt)
290
291 | PC.TInc(clt) | PC.TDec(clt)
292
293 | PC.TIf(clt) | PC.TElse(clt) | PC.TWhile(clt) | PC.TFor(clt) | PC.TDo(clt)
294 | PC.TSwitch(clt) | PC.TCase(clt) | PC.TDefault(clt) | PC.TReturn(clt)
295 | PC.TBreak(clt) | PC.TContinue(clt) | PC.TGoto(clt) | PC.TIdent(_,clt)
296 | PC.TTypeId(_,clt) | PC.TDeclarerId(_,clt) | PC.TIteratorId(_,clt)
297
298 | PC.TSizeof(clt)
299
300 | PC.TString(_,clt) | PC.TChar(_,clt) | PC.TFloat(_,clt) | PC.TInt(_,clt)
301
302 | PC.TOrLog(clt) | PC.TAndLog(clt) | PC.TOr(clt) | PC.TXor(clt)
303 | PC.TAnd (clt) | PC.TEqEq(clt) | PC.TNotEq(clt) | PC.TLogOp(_,clt)
304 | PC.TShOp(_,clt) | PC.TPlus(clt) | PC.TMinus(clt) | PC.TMul(clt)
305 | PC.TDmOp(_,clt) | PC.TTilde (clt)
306
307 | PC.TMetaParam(_,_,clt) | PC.TMetaParamList(_,_,_,clt)
308 | PC.TMetaConst(_,_,_,_,clt) | PC.TMetaErr(_,_,_,clt)
309 | PC.TMetaExp(_,_,_,_,clt) | PC.TMetaIdExp(_,_,_,_,clt)
310 | PC.TMetaLocalIdExp(_,_,_,_,clt)
311 | PC.TMetaExpList(_,_,_,clt)
312 | PC.TMetaId(_,_,_,clt)
313 | PC.TMetaType(_,_,clt) | PC.TMetaInit(_,_,clt) | PC.TMetaStm(_,_,clt)
314 | PC.TMetaStmList(_,_,clt) | PC.TMetaFunc(_,_,_,clt)
315 | PC.TMetaLocalFunc(_,_,_,clt)
316
317 | PC.TWhen(clt) | PC.TWhenTrue(clt) | PC.TWhenFalse(clt)
318 | PC.TAny(clt) | PC.TStrict(clt) | PC.TEllipsis(clt)
319 (* | PC.TCircles(clt) | PC.TStars(clt) *)
320
321 | PC.TWhy(clt) | PC.TDotDot(clt) | PC.TBang(clt) | PC.TOPar(clt)
322 | PC.TCPar(clt)
323
324 | PC.TOBrace(clt) | PC.TCBrace(clt) | PC.TOCro(clt) | PC.TCCro(clt)
325 | PC.TOInit(clt)
326
327 | PC.TPtrOp(clt)
328
329 | PC.TEq(clt) | PC.TAssign(_,clt) | PC.TDot(clt) | PC.TComma(clt)
330 | PC.TPtVirg(clt) ->
331 if line_type clt = D.PLUS
332 then PLUS
333 else if only_plus then NOTPLUS
334 else if line_type clt = D.CONTEXT then PLUS else NOTPLUS
335
336 | PC.TOPar0(clt) | PC.TMid0(clt) | PC.TCPar0(clt)
337 | PC.TOEllipsis(clt) | PC.TCEllipsis(clt)
338 | PC.TPOEllipsis(clt) | PC.TPCEllipsis(clt) (* | PC.TOCircles(clt)
339 | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *) -> NOTPLUS
340 | PC.TMetaPos(nm,_,_,_) -> NOTPLUS
341
342 | _ -> SKIP
343
344 let get_clt (tok,_) =
345 match tok with
346 PC.Tchar(clt) | PC.Tshort(clt) | PC.Tint(clt) | PC.Tdouble(clt)
347 | PC.Tfloat(clt) | PC.Tlong(clt) | PC.Tvoid(clt) | PC.Tstruct(clt)
348 | PC.Tunion(clt) | PC.Tenum(clt) | PC.Tunsigned(clt) | PC.Tsigned(clt)
349 | PC.Tstatic(clt)
350 | PC.Tinline(clt) | PC.Tattr(_,clt) | PC.Tauto(clt) | PC.Tregister(clt)
351 | PC.Textern(clt) | PC.Tconst(clt) | PC.Tvolatile(clt)
352
353 | PC.TIncludeL(_,clt) | PC.TIncludeNL(_,clt) | PC.TDefine(clt,_)
354 | PC.TDefineParam(clt,_,_) | PC.TMinusFile(_,clt) | PC.TPlusFile(_,clt)
355
356 | PC.TInc(clt) | PC.TDec(clt)
357
358 | PC.TIf(clt) | PC.TElse(clt) | PC.TWhile(clt) | PC.TFor(clt) | PC.TDo(clt)
359 | PC.TSwitch(clt) | PC.TCase(clt) | PC.TDefault(clt) | PC.TReturn(clt)
360 | PC.TBreak(clt) | PC.TContinue(clt) | PC.TGoto(clt) | PC.TIdent(_,clt)
361 | PC.TTypeId(_,clt) | PC.TDeclarerId(_,clt) | PC.TIteratorId(_,clt)
362
363 | PC.TSizeof(clt)
364
365 | PC.TString(_,clt) | PC.TChar(_,clt) | PC.TFloat(_,clt) | PC.TInt(_,clt)
366
367 | PC.TOrLog(clt) | PC.TAndLog(clt) | PC.TOr(clt) | PC.TXor(clt)
368 | PC.TAnd (clt) | PC.TEqEq(clt) | PC.TNotEq(clt) | PC.TLogOp(_,clt)
369 | PC.TShOp(_,clt) | PC.TPlus(clt) | PC.TMinus(clt) | PC.TMul(clt)
370 | PC.TDmOp(_,clt) | PC.TTilde (clt)
371
372 | PC.TMetaParam(_,_,clt) | PC.TMetaParamList(_,_,_,clt)
373 | PC.TMetaConst(_,_,_,_,clt) | PC.TMetaErr(_,_,_,clt)
374 | PC.TMetaExp(_,_,_,_,clt) | PC.TMetaIdExp(_,_,_,_,clt)
375 | PC.TMetaLocalIdExp(_,_,_,_,clt)
376 | PC.TMetaExpList(_,_,_,clt)
377 | PC.TMetaId(_,_,_,clt)
378 | PC.TMetaType(_,_,clt) | PC.TMetaInit(_,_,clt) | PC.TMetaStm(_,_,clt)
379 | PC.TMetaStmList(_,_,clt) | PC.TMetaFunc(_,_,_,clt)
380 | PC.TMetaLocalFunc(_,_,_,clt) | PC.TMetaPos(_,_,_,clt)
381
382 | PC.TWhen(clt) | PC.TWhenTrue(clt) | PC.TWhenFalse(clt) |
383 PC.TAny(clt) | PC.TStrict(clt) | PC.TEllipsis(clt)
384 (* | PC.TCircles(clt) | PC.TStars(clt) *)
385
386 | PC.TWhy(clt) | PC.TDotDot(clt) | PC.TBang(clt) | PC.TOPar(clt)
387 | PC.TCPar(clt)
388
389 | PC.TOBrace(clt) | PC.TCBrace(clt) | PC.TOCro(clt) | PC.TCCro(clt)
390 | PC.TOInit(clt)
391
392 | PC.TPtrOp(clt)
393
394 | PC.TEq(clt) | PC.TAssign(_,clt) | PC.TDot(clt) | PC.TComma(clt)
395 | PC.TPtVirg(clt)
396
397 | PC.TOPar0(clt) | PC.TMid0(clt) | PC.TCPar0(clt)
398 | PC.TOEllipsis(clt) | PC.TCEllipsis(clt)
399 | PC.TPOEllipsis(clt) | PC.TPCEllipsis(clt) (* | PC.TOCircles(clt)
400 | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *) -> clt
401
402 | _ -> failwith "no clt"
403
404 let update_clt (tok,x) clt =
405 match tok with
406 PC.Tchar(_) -> (PC.Tchar(clt),x)
407 | PC.Tshort(_) -> (PC.Tshort(clt),x)
408 | PC.Tint(_) -> (PC.Tint(clt),x)
409 | PC.Tdouble(_) -> (PC.Tdouble(clt),x)
410 | PC.Tfloat(_) -> (PC.Tfloat(clt),x)
411 | PC.Tlong(_) -> (PC.Tlong(clt),x)
412 | PC.Tvoid(_) -> (PC.Tvoid(clt),x)
413 | PC.Tstruct(_) -> (PC.Tstruct(clt),x)
414 | PC.Tunion(_) -> (PC.Tunion(clt),x)
415 | PC.Tenum(_) -> (PC.Tenum(clt),x)
416 | PC.Tunsigned(_) -> (PC.Tunsigned(clt),x)
417 | PC.Tsigned(_) -> (PC.Tsigned(clt),x)
418 | PC.Tstatic(_) -> (PC.Tstatic(clt),x)
419 | PC.Tinline(_) -> (PC.Tinline(clt),x)
420 | PC.Ttypedef(_) -> (PC.Ttypedef(clt),x)
421 | PC.Tattr(s,_) -> (PC.Tattr(s,clt),x)
422 | PC.Tauto(_) -> (PC.Tauto(clt),x)
423 | PC.Tregister(_) -> (PC.Tregister(clt),x)
424 | PC.Textern(_) -> (PC.Textern(clt),x)
425 | PC.Tconst(_) -> (PC.Tconst(clt),x)
426 | PC.Tvolatile(_) -> (PC.Tvolatile(clt),x)
427
428 | PC.TIncludeL(s,_) -> (PC.TIncludeL(s,clt),x)
429 | PC.TIncludeNL(s,_) -> (PC.TIncludeNL(s,clt),x)
430 | PC.TDefine(_,a) -> (PC.TDefine(clt,a),x)
431 | PC.TDefineParam(_,a,b) -> (PC.TDefineParam(clt,a,b),x)
432 | PC.TMinusFile(s,_) -> (PC.TMinusFile(s,clt),x)
433 | PC.TPlusFile(s,_) -> (PC.TPlusFile(s,clt),x)
434
435 | PC.TInc(_) -> (PC.TInc(clt),x)
436 | PC.TDec(_) -> (PC.TDec(clt),x)
437
438 | PC.TIf(_) -> (PC.TIf(clt),x)
439 | PC.TElse(_) -> (PC.TElse(clt),x)
440 | PC.TWhile(_) -> (PC.TWhile(clt),x)
441 | PC.TFor(_) -> (PC.TFor(clt),x)
442 | PC.TDo(_) -> (PC.TDo(clt),x)
443 | PC.TSwitch(_) -> (PC.TSwitch(clt),x)
444 | PC.TCase(_) -> (PC.TCase(clt),x)
445 | PC.TDefault(_) -> (PC.TDefault(clt),x)
446 | PC.TReturn(_) -> (PC.TReturn(clt),x)
447 | PC.TBreak(_) -> (PC.TBreak(clt),x)
448 | PC.TContinue(_) -> (PC.TContinue(clt),x)
449 | PC.TGoto(_) -> (PC.TGoto(clt),x)
450 | PC.TIdent(s,_) -> (PC.TIdent(s,clt),x)
451 | PC.TTypeId(s,_) -> (PC.TTypeId(s,clt),x)
452 | PC.TDeclarerId(s,_) -> (PC.TDeclarerId(s,clt),x)
453 | PC.TIteratorId(s,_) -> (PC.TIteratorId(s,clt),x)
454
455 | PC.TSizeof(_) -> (PC.TSizeof(clt),x)
456
457 | PC.TString(s,_) -> (PC.TString(s,clt),x)
458 | PC.TChar(s,_) -> (PC.TChar(s,clt),x)
459 | PC.TFloat(s,_) -> (PC.TFloat(s,clt),x)
460 | PC.TInt(s,_) -> (PC.TInt(s,clt),x)
461
462 | PC.TOrLog(_) -> (PC.TOrLog(clt),x)
463 | PC.TAndLog(_) -> (PC.TAndLog(clt),x)
464 | PC.TOr(_) -> (PC.TOr(clt),x)
465 | PC.TXor(_) -> (PC.TXor(clt),x)
466 | PC.TAnd (_) -> (PC.TAnd (clt),x)
467 | PC.TEqEq(_) -> (PC.TEqEq(clt),x)
468 | PC.TNotEq(_) -> (PC.TNotEq(clt),x)
469 | PC.TLogOp(op,_) -> (PC.TLogOp(op,clt),x)
470 | PC.TShOp(op,_) -> (PC.TShOp(op,clt),x)
471 | PC.TPlus(_) -> (PC.TPlus(clt),x)
472 | PC.TMinus(_) -> (PC.TMinus(clt),x)
473 | PC.TMul(_) -> (PC.TMul(clt),x)
474 | PC.TDmOp(op,_) -> (PC.TDmOp(op,clt),x)
475 | PC.TTilde (_) -> (PC.TTilde (clt),x)
476
477 | PC.TMetaParam(a,b,_) -> (PC.TMetaParam(a,b,clt),x)
478 | PC.TMetaParamList(a,b,c,_) -> (PC.TMetaParamList(a,b,c,clt),x)
479 | PC.TMetaConst(a,b,c,d,_) -> (PC.TMetaConst(a,b,c,d,clt),x)
480 | PC.TMetaErr(a,b,c,_) -> (PC.TMetaErr(a,b,c,clt),x)
481 | PC.TMetaExp(a,b,c,d,_) -> (PC.TMetaExp(a,b,c,d,clt),x)
482 | PC.TMetaIdExp(a,b,c,d,_) -> (PC.TMetaIdExp(a,b,c,d,clt),x)
483 | PC.TMetaLocalIdExp(a,b,c,d,_) -> (PC.TMetaLocalIdExp(a,b,c,d,clt),x)
484 | PC.TMetaExpList(a,b,c,_) -> (PC.TMetaExpList(a,b,c,clt),x)
485 | PC.TMetaId(a,b,c,_) -> (PC.TMetaId(a,b,c,clt),x)
486 | PC.TMetaType(a,b,_) -> (PC.TMetaType(a,b,clt),x)
487 | PC.TMetaInit(a,b,_) -> (PC.TMetaInit(a,b,clt),x)
488 | PC.TMetaStm(a,b,_) -> (PC.TMetaStm(a,b,clt),x)
489 | PC.TMetaStmList(a,b,_) -> (PC.TMetaStmList(a,b,clt),x)
490 | PC.TMetaFunc(a,b,c,_) -> (PC.TMetaFunc(a,b,c,clt),x)
491 | PC.TMetaLocalFunc(a,b,c,_) -> (PC.TMetaLocalFunc(a,b,c,clt),x)
492
493 | PC.TWhen(_) -> (PC.TWhen(clt),x)
494 | PC.TWhenTrue(_) -> (PC.TWhenTrue(clt),x)
495 | PC.TWhenFalse(_) -> (PC.TWhenFalse(clt),x)
496 | PC.TAny(_) -> (PC.TAny(clt),x)
497 | PC.TStrict(_) -> (PC.TStrict(clt),x)
498 | PC.TEllipsis(_) -> (PC.TEllipsis(clt),x)
499 (*
500 | PC.TCircles(_) -> (PC.TCircles(clt),x)
501 | PC.TStars(_) -> (PC.TStars(clt),x)
502 *)
503
504 | PC.TOEllipsis(_) -> (PC.TOEllipsis(clt),x)
505 | PC.TCEllipsis(_) -> (PC.TCEllipsis(clt),x)
506 | PC.TPOEllipsis(_) -> (PC.TPOEllipsis(clt),x)
507 | PC.TPCEllipsis(_) -> (PC.TPCEllipsis(clt),x)
508 (*
509 | PC.TOCircles(_) -> (PC.TOCircles(clt),x)
510 | PC.TCCircles(_) -> (PC.TCCircles(clt),x)
511 | PC.TOStars(_) -> (PC.TOStars(clt),x)
512 | PC.TCStars(_) -> (PC.TCStars(clt),x)
513 *)
514
515 | PC.TWhy(_) -> (PC.TWhy(clt),x)
516 | PC.TDotDot(_) -> (PC.TDotDot(clt),x)
517 | PC.TBang(_) -> (PC.TBang(clt),x)
518 | PC.TOPar(_) -> (PC.TOPar(clt),x)
519 | PC.TOPar0(_) -> (PC.TOPar0(clt),x)
520 | PC.TMid0(_) -> (PC.TMid0(clt),x)
521 | PC.TCPar(_) -> (PC.TCPar(clt),x)
522 | PC.TCPar0(_) -> (PC.TCPar0(clt),x)
523
524 | PC.TOBrace(_) -> (PC.TOBrace(clt),x)
525 | PC.TCBrace(_) -> (PC.TCBrace(clt),x)
526 | PC.TOCro(_) -> (PC.TOCro(clt),x)
527 | PC.TCCro(_) -> (PC.TCCro(clt),x)
528 | PC.TOInit(_) -> (PC.TOInit(clt),x)
529
530 | PC.TPtrOp(_) -> (PC.TPtrOp(clt),x)
531
532 | PC.TEq(_) -> (PC.TEq(clt),x)
533 | PC.TAssign(s,_) -> (PC.TAssign(s,clt),x)
534 | PC.TDot(_) -> (PC.TDot(clt),x)
535 | PC.TComma(_) -> (PC.TComma(clt),x)
536 | PC.TPtVirg(_) -> (PC.TPtVirg(clt),x)
537
538 | PC.TLineEnd(_) -> (PC.TLineEnd(clt),x)
539 | PC.TFunDecl(_) -> (PC.TFunDecl(clt),x)
540
541 | _ -> failwith "no clt"
542
543
544 (* ----------------------------------------------------------------------- *)
545
546 let make_name prefix ln = Printf.sprintf "%s starting on line %d" prefix ln
547
548 (* ----------------------------------------------------------------------- *)
549 (* Read tokens *)
550
551 let wrap_lexbuf_info lexbuf =
552 (Lexing.lexeme lexbuf, Lexing.lexeme_start lexbuf)
553
554 let tokens_all_full token table file get_ats lexbuf end_markers :
555 (bool * ((PC.token * (string * (int * int) * (int * int))) list)) =
556 try
557 let rec aux () =
558 let result = token lexbuf in
559 let info = (Lexing.lexeme lexbuf,
560 (table.(Lexing.lexeme_start lexbuf)),
561 (Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) in
562 if result = PC.EOF
563 then
564 if get_ats
565 then failwith "unexpected end of file in a metavariable declaration"
566 else (false,[(result,info)])
567 else if List.mem result end_markers
568 then (true,[(result,info)])
569 else
570 let (more,rest) = aux() in
571 (more,(result, info)::rest)
572 in aux ()
573 with
574 e -> pr2 (Common.error_message file (wrap_lexbuf_info lexbuf) ); raise e
575
576 let tokens_all table file get_ats lexbuf end_markers :
577 (bool * ((PC.token * (string * (int * int) * (int * int))) list)) =
578 tokens_all_full Lexer_cocci.token table file get_ats lexbuf end_markers
579
580 let tokens_script_all table file get_ats lexbuf end_markers :
581 (bool * ((PC.token * (string * (int * int) * (int * int))) list)) =
582 tokens_all_full Lexer_script.token table file get_ats lexbuf end_markers
583
584 (* ----------------------------------------------------------------------- *)
585 (* Split tokens into minus and plus fragments *)
586
587 let split t clt =
588 let (d,_,_,_,_,_,_,_) = clt in
589 match d with
590 D.MINUS | D.OPTMINUS | D.UNIQUEMINUS -> ([t],[])
591 | D.PLUS -> ([],[t])
592 | D.CONTEXT | D.UNIQUE | D.OPT -> ([t],[t])
593
594 let split_token ((tok,_) as t) =
595 match tok with
596 PC.TIdentifier | PC.TConstant | PC.TExpression | PC.TIdExpression
597 | PC.TStatement | PC.TPosition | PC.TPosAny | PC.TInitialiser
598 | PC.TFunction | PC.TTypedef | PC.TDeclarer | PC.TIterator | PC.TName
599 | PC.TType | PC.TParameter | PC.TLocal | PC.Tlist | PC.TFresh | PC.TPure
600 | PC.TContext | PC.TRuleName(_) | PC.TUsing | PC.TDisable | PC.TExtends
601 | PC.TPathIsoFile(_)
602 | PC.TDepends | PC.TOn | PC.TEver | PC.TNever | PC.TExists | PC.TForall
603 | PC.TReverse
604 | PC.TError | PC.TWords | PC.TGenerated | PC.TNothing -> ([t],[t])
605
606 | PC.Tchar(clt) | PC.Tshort(clt) | PC.Tint(clt) | PC.Tdouble(clt)
607 | PC.Tfloat(clt) | PC.Tlong(clt) | PC.Tvoid(clt) | PC.Tstruct(clt)
608 | PC.Tunion(clt) | PC.Tenum(clt) | PC.Tunsigned(clt) | PC.Tsigned(clt)
609 | PC.Tstatic(clt) | PC.Tauto(clt) | PC.Tregister(clt) | PC.Textern(clt)
610 | PC.Tinline(clt) | PC.Ttypedef(clt) | PC.Tattr(_,clt)
611 | PC.Tconst(clt) | PC.Tvolatile(clt) -> split t clt
612
613 | PC.TPragma(s,_) -> ([],[t]) (* only allowed in + *)
614 | PC.TPlusFile(s,clt) | PC.TMinusFile(s,clt)
615 | PC.TIncludeL(s,clt) | PC.TIncludeNL(s,clt) ->
616 split t clt
617 | PC.TDefine(clt,_) | PC.TDefineParam(clt,_,_) -> split t clt
618
619 | PC.TIf(clt) | PC.TElse(clt) | PC.TWhile(clt) | PC.TFor(clt) | PC.TDo(clt)
620 | PC.TSwitch(clt) | PC.TCase(clt) | PC.TDefault(clt)
621 | PC.TSizeof(clt)
622 | PC.TReturn(clt) | PC.TBreak(clt) | PC.TContinue(clt) | PC.TGoto(clt)
623 | PC.TIdent(_,clt)
624 | PC.TTypeId(_,clt) | PC.TDeclarerId(_,clt) | PC.TIteratorId(_,clt)
625 | PC.TMetaConst(_,_,_,_,clt) | PC.TMetaExp(_,_,_,_,clt)
626 | PC.TMetaIdExp(_,_,_,_,clt) | PC.TMetaLocalIdExp(_,_,_,_,clt)
627 | PC.TMetaExpList(_,_,_,clt)
628 | PC.TMetaParam(_,_,clt) | PC.TMetaParamList(_,_,_,clt)
629 | PC.TMetaId(_,_,_,clt) | PC.TMetaType(_,_,clt) | PC.TMetaInit(_,_,clt)
630 | PC.TMetaStm(_,_,clt) | PC.TMetaStmList(_,_,clt) | PC.TMetaErr(_,_,_,clt)
631 | PC.TMetaFunc(_,_,_,clt) | PC.TMetaLocalFunc(_,_,_,clt)
632 | PC.TMetaDeclarer(_,_,_,clt) | PC.TMetaIterator(_,_,_,clt) -> split t clt
633 | PC.TMPtVirg | PC.TArob | PC.TArobArob | PC.TScript
634 | PC.TInitialize | PC.TFinalize -> ([t],[t])
635 | PC.TPArob | PC.TMetaPos(_,_,_,_) -> ([t],[])
636
637 | PC.TFunDecl(clt)
638 | PC.TWhen(clt) | PC.TWhenTrue(clt) | PC.TWhenFalse(clt)
639 | PC.TAny(clt) | PC.TStrict(clt) | PC.TLineEnd(clt)
640 | PC.TEllipsis(clt) (* | PC.TCircles(clt) | PC.TStars(clt) *) -> split t clt
641
642 | PC.TOEllipsis(_) | PC.TCEllipsis(_) (* clt must be context *)
643 | PC.TPOEllipsis(_) | PC.TPCEllipsis(_) (* clt must be context *)
644 (*
645 | PC.TOCircles(_) | PC.TCCircles(_) (* clt must be context *)
646 | PC.TOStars(_) | PC.TCStars(_) (* clt must be context *)
647 *)
648 | PC.TBang0 | PC.TPlus0 | PC.TWhy0 ->
649 ([t],[t])
650
651 | PC.TWhy(clt) | PC.TDotDot(clt)
652 | PC.TBang(clt) | PC.TOPar(clt) | PC.TOPar0(clt)
653 | PC.TMid0(clt) | PC.TCPar(clt) | PC.TCPar0(clt) -> split t clt
654
655 | PC.TInc(clt) | PC.TDec(clt) -> split t clt
656
657 | PC.TString(_,clt) | PC.TChar(_,clt) | PC.TFloat(_,clt) | PC.TInt(_,clt) ->
658 split t clt
659
660 | PC.TOrLog(clt) | PC.TAndLog(clt) | PC.TOr(clt) | PC.TXor(clt)
661 | PC.TAnd (clt) | PC.TEqEq(clt) | PC.TNotEq(clt) | PC.TLogOp(_,clt)
662 | PC.TShOp(_,clt) | PC.TPlus(clt) | PC.TMinus(clt) | PC.TMul(clt)
663 | PC.TDmOp(_,clt) | PC.TTilde (clt) -> split t clt
664
665 | PC.TOBrace(clt) | PC.TCBrace(clt) | PC.TOInit(clt) -> split t clt
666 | PC.TOCro(clt) | PC.TCCro(clt) -> split t clt
667
668 | PC.TPtrOp(clt) -> split t clt
669
670 | PC.TEq(clt) | PC.TAssign(_,clt) | PC.TDot(clt) | PC.TComma(clt)
671 | PC.TPtVirg(clt) -> split t clt
672
673 | PC.EOF | PC.TInvalid -> ([t],[t])
674
675 | PC.TIso | PC.TRightIso
676 | PC.TIsoExpression | PC.TIsoStatement | PC.TIsoDeclaration | PC.TIsoType
677 | PC.TIsoTopLevel | PC.TIsoArgExpression | PC.TIsoTestExpression ->
678 failwith "unexpected tokens"
679 | PC.TScriptData s -> ([t],[t])
680
681 let split_token_stream tokens =
682 let rec loop = function
683 [] -> ([],[])
684 | token::tokens ->
685 let (minus,plus) = split_token token in
686 let (minus_stream,plus_stream) = loop tokens in
687 (minus@minus_stream,plus@plus_stream) in
688 loop tokens
689
690 (* ----------------------------------------------------------------------- *)
691 (* Find function names *)
692 (* This addresses a shift-reduce problem in the parser, allowing us to
693 distinguish a function declaration from a function call even if the latter
694 has no return type. Undoubtedly, this is not very nice, but it doesn't
695 seem very convenient to refactor the grammar to get around the problem. *)
696
697 let rec find_function_names = function
698 [] -> []
699 | ((PC.TIdent(_,clt),info) as t1) :: ((PC.TOPar(_),_) as t2) :: rest
700 | ((PC.TMetaId(_,_,_,clt),info) as t1) :: ((PC.TOPar(_),_) as t2) :: rest
701 | ((PC.TMetaFunc(_,_,_,clt),info) as t1) :: ((PC.TOPar(_),_) as t2) :: rest
702 | ((PC.TMetaLocalFunc(_,_,_,clt),info) as t1)::((PC.TOPar(_),_) as t2)::rest
703 ->
704 let rec skip level = function
705 [] -> ([],false,[])
706 | ((PC.TCPar(_),_) as t)::rest ->
707 let level = level - 1 in
708 if level = 0
709 then ([t],true,rest)
710 else let (pre,found,post) = skip level rest in (t::pre,found,post)
711 | ((PC.TOPar(_),_) as t)::rest ->
712 let level = level + 1 in
713 let (pre,found,post) = skip level rest in (t::pre,found,post)
714 | ((PC.TArobArob,_) as t)::rest
715 | ((PC.TArob,_) as t)::rest
716 | ((PC.EOF,_) as t)::rest -> ([t],false,rest)
717 | t::rest ->
718 let (pre,found,post) = skip level rest in (t::pre,found,post) in
719 let (pre,found,post) = skip 1 rest in
720 (match (found,post) with
721 (true,((PC.TOBrace(_),_) as t3)::rest) ->
722 (PC.TFunDecl(clt),info) :: t1 :: t2 :: pre @
723 t3 :: (find_function_names rest)
724 | _ -> t1 :: t2 :: pre @ find_function_names post)
725 | t :: rest -> t :: find_function_names rest
726
727 (* ----------------------------------------------------------------------- *)
728 (* an attribute is an identifier that preceeds another identifier and
729 begins with __ *)
730
731 let rec detect_attr l =
732 let is_id = function
733 (PC.TIdent(_,_),_) | (PC.TMetaId(_,_,_,_),_) | (PC.TMetaFunc(_,_,_,_),_)
734 | (PC.TMetaLocalFunc(_,_,_,_),_) -> true
735 | _ -> false in
736 let rec loop = function
737 [] -> []
738 | [x] -> [x]
739 | ((PC.TIdent(nm,clt),info) as t1)::id::rest when is_id id ->
740 if String.length nm > 2 && String.sub nm 0 2 = "__"
741 then (PC.Tattr(nm,clt),info)::(loop (id::rest))
742 else t1::(loop (id::rest))
743 | x::xs -> x::(loop xs) in
744 loop l
745
746 (* ----------------------------------------------------------------------- *)
747 (* Look for variable declarations where the name is a typedef name.
748 We assume that C code does not contain a multiplication as a top-level
749 statement. *)
750
751 (* bug: once a type, always a type, even if the same name is later intended
752 to be used as a real identifier *)
753 let detect_types in_meta_decls l =
754 let is_delim infn = function
755 (PC.TOEllipsis(_),_) (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *)
756 | (PC.TPOEllipsis(_),_) (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *)
757 | (PC.TEllipsis(_),_) (* | (PC.TCircles(_),_) | (PC.TStars(_),_) *)
758 | (PC.TPtVirg(_),_) | (PC.TOBrace(_),_) | (PC.TOInit(_),_)
759 | (PC.TCBrace(_),_)
760 | (PC.TPure,_) | (PC.TContext,_)
761 | (PC.Tstatic(_),_) | (PC.Textern(_),_)
762 | (PC.Tinline(_),_) | (PC.Ttypedef(_),_) | (PC.Tattr(_),_) -> true
763 | (PC.TComma(_),_) when infn > 0 or in_meta_decls -> true
764 | (PC.TDotDot(_),_) when in_meta_decls -> true
765 | _ -> false in
766 let is_choices_delim = function
767 (PC.TOBrace(_),_) | (PC.TComma(_),_) -> true | _ -> false in
768 let is_id = function
769 (PC.TIdent(_,_),_) | (PC.TMetaId(_,_,_,_),_) | (PC.TMetaFunc(_,_,_,_),_)
770 | (PC.TMetaLocalFunc(_,_,_,_),_) -> true
771 | (PC.TMetaParam(_,_,_),_)
772 | (PC.TMetaParamList(_,_,_,_),_)
773 | (PC.TMetaConst(_,_,_,_,_),_)
774 | (PC.TMetaErr(_,_,_,_),_)
775 | (PC.TMetaExp(_,_,_,_,_),_)
776 | (PC.TMetaIdExp(_,_,_,_,_),_)
777 | (PC.TMetaLocalIdExp(_,_,_,_,_),_)
778 | (PC.TMetaExpList(_,_,_,_),_)
779 | (PC.TMetaType(_,_,_),_)
780 | (PC.TMetaInit(_,_,_),_)
781 | (PC.TMetaStm(_,_,_),_)
782 | (PC.TMetaStmList(_,_,_),_)
783 | (PC.TMetaPos(_,_,_,_),_) -> in_meta_decls
784 | _ -> false in
785 let redo_id ident clt v =
786 !Data.add_type_name ident;
787 (PC.TTypeId(ident,clt),v) in
788 let rec loop start infn type_names = function
789 (* infn: 0 means not in a function header
790 > 0 means in a function header, after infn - 1 unmatched open parens*)
791 [] -> []
792 | ((PC.TOBrace(clt),v)::_) as all when in_meta_decls ->
793 collect_choices type_names all (* never a function header *)
794 | delim::(PC.TIdent(ident,clt),v)::((PC.TMul(_),_) as x)::rest
795 when is_delim infn delim ->
796 let newid = redo_id ident clt v in
797 delim::newid::x::(loop false infn (ident::type_names) rest)
798 | delim::(PC.TIdent(ident,clt),v)::id::rest
799 when is_delim infn delim && is_id id ->
800 let newid = redo_id ident clt v in
801 delim::newid::id::(loop false infn (ident::type_names) rest)
802 | ((PC.TFunDecl(_),_) as fn)::rest ->
803 fn::(loop false 1 type_names rest)
804 | ((PC.TOPar(_),_) as lp)::rest when infn > 0 ->
805 lp::(loop false (infn + 1) type_names rest)
806 | ((PC.TCPar(_),_) as rp)::rest when infn > 0 ->
807 if infn - 1 = 1
808 then rp::(loop false 0 type_names rest) (* 0 means not in fn header *)
809 else rp::(loop false (infn - 1) type_names rest)
810 | (PC.TIdent(ident,clt),v)::((PC.TMul(_),_) as x)::rest when start ->
811 let newid = redo_id ident clt v in
812 newid::x::(loop false infn (ident::type_names) rest)
813 | (PC.TIdent(ident,clt),v)::id::rest when start && is_id id ->
814 let newid = redo_id ident clt v in
815 newid::id::(loop false infn (ident::type_names) rest)
816 | (PC.TIdent(ident,clt),v)::rest when List.mem ident type_names ->
817 (PC.TTypeId(ident,clt),v)::(loop false infn type_names rest)
818 | ((PC.TIdent(ident,clt),v) as x)::rest ->
819 x::(loop false infn type_names rest)
820 | x::rest -> x::(loop false infn type_names rest)
821 and collect_choices type_names = function
822 [] -> [] (* should happen, but let the parser detect that *)
823 | (PC.TCBrace(clt),v)::rest ->
824 (PC.TCBrace(clt),v)::(loop false 0 type_names rest)
825 | delim::(PC.TIdent(ident,clt),v)::rest
826 when is_choices_delim delim ->
827 let newid = redo_id ident clt v in
828 delim::newid::(collect_choices (ident::type_names) rest)
829 | x::rest -> x::(collect_choices type_names rest) in
830 loop true 0 [] l
831
832
833 (* ----------------------------------------------------------------------- *)
834 (* Insert TLineEnd tokens at the end of a line that contains a WHEN.
835 WHEN is restricted to a single line, to avoid ambiguity in eg:
836 ... WHEN != x
837 +3 *)
838
839 let token2line (tok,_) =
840 match tok with
841 PC.Tchar(clt) | PC.Tshort(clt) | PC.Tint(clt) | PC.Tdouble(clt)
842 | PC.Tfloat(clt) | PC.Tlong(clt) | PC.Tvoid(clt) | PC.Tstruct(clt)
843 | PC.Tunion(clt) | PC.Tenum(clt) | PC.Tunsigned(clt) | PC.Tsigned(clt)
844 | PC.Tstatic(clt) | PC.Tauto(clt) | PC.Tregister(clt) | PC.Textern(clt)
845 | PC.Tinline(clt) | PC.Ttypedef(clt) | PC.Tattr(_,clt) | PC.Tconst(clt)
846 | PC.Tvolatile(clt)
847
848 | PC.TInc(clt) | PC.TDec(clt)
849
850 | PC.TIf(clt) | PC.TElse(clt) | PC.TWhile(clt) | PC.TFor(clt) | PC.TDo(clt)
851 | PC.TSwitch (clt) | PC.TCase (clt) | PC.TDefault (clt) | PC.TSizeof (clt)
852 | PC.TReturn(clt) | PC.TBreak(clt) | PC.TContinue(clt) | PC.TGoto(clt)
853 | PC.TIdent(_,clt)
854 | PC.TTypeId(_,clt) | PC.TDeclarerId(_,clt) | PC.TIteratorId(_,clt)
855 | PC.TMetaDeclarer(_,_,_,clt) | PC.TMetaIterator(_,_,_,clt)
856
857 | PC.TString(_,clt) | PC.TChar(_,clt) | PC.TFloat(_,clt) | PC.TInt(_,clt)
858
859 | PC.TOrLog(clt) | PC.TAndLog(clt) | PC.TOr(clt) | PC.TXor(clt)
860 | PC.TAnd (clt) | PC.TEqEq(clt) | PC.TNotEq(clt) | PC.TLogOp(_,clt)
861 | PC.TShOp(_,clt) | PC.TPlus(clt) | PC.TMinus(clt) | PC.TMul(clt)
862 | PC.TDmOp(_,clt) | PC.TTilde (clt)
863
864 | PC.TMetaParam(_,_,clt) | PC.TMetaParamList(_,_,_,clt)
865 | PC.TMetaConst(_,_,_,_,clt) | PC.TMetaExp(_,_,_,_,clt)
866 | PC.TMetaIdExp(_,_,_,_,clt) | PC.TMetaLocalIdExp(_,_,_,_,clt)
867 | PC.TMetaExpList(_,_,_,clt)
868 | PC.TMetaId(_,_,_,clt) | PC.TMetaType(_,_,clt) | PC.TMetaInit(_,_,clt)
869 | PC.TMetaStm(_,_,clt) | PC.TMetaStmList(_,_,clt) | PC.TMetaFunc(_,_,_,clt)
870 | PC.TMetaLocalFunc(_,_,_,clt) | PC.TMetaPos(_,_,_,clt)
871
872 | PC.TFunDecl(clt)
873 | PC.TWhen(clt) | PC.TWhenTrue(clt) | PC.TWhenFalse(clt)
874 | PC.TAny(clt) | PC.TStrict(clt) | PC.TEllipsis(clt)
875 (* | PC.TCircles(clt) | PC.TStars(clt) *)
876
877 | PC.TOEllipsis(clt) | PC.TCEllipsis(clt)
878 | PC.TPOEllipsis(clt) | PC.TPCEllipsis(clt) (*| PC.TOCircles(clt)
879 | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *)
880
881 | PC.TWhy(clt) | PC.TDotDot(clt) | PC.TBang(clt) | PC.TOPar(clt)
882 | PC.TOPar0(clt) | PC.TMid0(clt) | PC.TCPar(clt)
883 | PC.TCPar0(clt)
884
885 | PC.TOBrace(clt) | PC.TCBrace(clt) | PC.TOCro(clt) | PC.TCCro(clt)
886 | PC.TOInit(clt)
887
888 | PC.TPtrOp(clt)
889
890 | PC.TDefine(clt,_) | PC.TDefineParam(clt,_,_)
891 | PC.TIncludeL(_,clt) | PC.TIncludeNL(_,clt)
892
893 | PC.TEq(clt) | PC.TAssign(_,clt) | PC.TDot(clt) | PC.TComma(clt)
894 | PC.TPtVirg(clt) ->
895 let (_,line,_,_,_,_,_,_) = clt in Some line
896
897 | _ -> None
898
899 let rec insert_line_end = function
900 [] -> []
901 | (((PC.TWhen(clt),q) as x)::xs) ->
902 x::(find_line_end true (token2line x) clt q xs)
903 | (((PC.TDefine(clt,_),q) as x)::xs)
904 | (((PC.TDefineParam(clt,_,_),q) as x)::xs) ->
905 x::(find_line_end false (token2line x) clt q xs)
906 | x::xs -> x::(insert_line_end xs)
907
908 and find_line_end inwhen line clt q = function
909 (* don't know what 2nd component should be so just use the info of
910 the When. Also inherit - of when, if any *)
911 [] -> [(PC.TLineEnd(clt),q)]
912 | ((PC.TIdent("strict",clt),a) as x)::xs when token2line x = line ->
913 (PC.TStrict(clt),a) :: (find_line_end inwhen line clt q xs)
914 | ((PC.TIdent("STRICT",clt),a) as x)::xs when token2line x = line ->
915 (PC.TStrict(clt),a) :: (find_line_end inwhen line clt q xs)
916 | ((PC.TIdent("any",clt),a) as x)::xs when token2line x = line ->
917 (PC.TAny(clt),a) :: (find_line_end inwhen line clt q xs)
918 | ((PC.TIdent("ANY",clt),a) as x)::xs when token2line x = line ->
919 (PC.TAny(clt),a) :: (find_line_end inwhen line clt q xs)
920 | ((PC.TIdent("forall",clt),a) as x)::xs when token2line x = line ->
921 (PC.TForall,a) :: (find_line_end inwhen line clt q xs)
922 | ((PC.TIdent("exists",clt),a) as x)::xs when token2line x = line ->
923 (PC.TExists,a) :: (find_line_end inwhen line clt q xs)
924 | ((PC.TComma(clt),a) as x)::xs when token2line x = line ->
925 (PC.TComma(clt),a) :: (find_line_end inwhen line clt q xs)
926 | ((PC.TPArob,a) as x)::xs -> (* no line #, just assume on the same line *)
927 x :: (find_line_end inwhen line clt q xs)
928 | x::xs when token2line x = line -> x :: (find_line_end inwhen line clt q xs)
929 | xs -> (PC.TLineEnd(clt),q)::(insert_line_end xs)
930
931 let rec translate_when_true_false = function
932 [] -> []
933 | (PC.TWhen(clt),q)::((PC.TNotEq(_),_) as x)::(PC.TIdent("true",_),_)::xs ->
934 (PC.TWhenTrue(clt),q)::x::(translate_when_true_false xs)
935 | (PC.TWhen(clt),q)::((PC.TNotEq(_),_) as x)::(PC.TIdent("false",_),_)::xs ->
936 (PC.TWhenFalse(clt),q)::x::(translate_when_true_false xs)
937 | x::xs -> x :: (translate_when_true_false xs)
938
939 (* ----------------------------------------------------------------------- *)
940 (* top level initializers: a sequence of braces followed by a dot *)
941
942 let find_top_init tokens =
943 match tokens with
944 (PC.TOBrace(clt),q) :: rest ->
945 let rec dot_start acc = function
946 ((PC.TOBrace(_),_) as x) :: rest ->
947 dot_start (x::acc) rest
948 | ((PC.TDot(_),_) :: rest) as x ->
949 Some ((PC.TOInit(clt),q) :: (List.rev acc) @ x)
950 | l -> None in
951 let rec comma_end acc = function
952 ((PC.TCBrace(_),_) as x) :: rest ->
953 comma_end (x::acc) rest
954 | ((PC.TComma(_),_) :: rest) as x ->
955 Some ((PC.TOInit(clt),q) :: (List.rev x) @ acc)
956 | l -> None in
957 (match dot_start [] rest with
958 Some x -> x
959 | None ->
960 (match List.rev rest with
961 (* not super sure what this does, but EOF, @, and @@ should be
962 the same, markind the end of a rule *)
963 ((PC.EOF,_) as x)::rest | ((PC.TArob,_) as x)::rest
964 | ((PC.TArobArob,_) as x)::rest ->
965 (match comma_end [x] rest with
966 Some x -> x
967 | None -> tokens)
968 | _ ->
969 failwith "unexpected empty token list"))
970 | _ -> tokens
971
972 (* ----------------------------------------------------------------------- *)
973 (* Integrate pragmas into some adjacent token. + tokens are preferred. Dots
974 are not allowed. *)
975
976 let rec collect_all_pragmas collected = function
977 (PC.TPragma(s,(_,line,logical_line,offset,col,_,_,pos)),_)::rest ->
978 let i =
979 { Ast0.line_start = line; Ast0.line_end = line;
980 Ast0.logical_start = logical_line; Ast0.logical_end = logical_line;
981 Ast0.column = col; Ast0.offset = offset; } in
982 collect_all_pragmas ((s,i)::collected) rest
983 | l -> (List.rev collected,l)
984
985 let rec collect_pass = function
986 [] -> ([],[])
987 | x::xs ->
988 match plus_attachable false x with
989 SKIP ->
990 let (pass,rest) = collect_pass xs in
991 (x::pass,rest)
992 | _ -> ([],x::xs)
993
994 let plus_attach strict = function
995 None -> NOTPLUS
996 | Some x -> plus_attachable strict x
997
998 let add_bef = function Some x -> [x] | None -> []
999
1000 (*skips should be things like line end
1001 skips is things before pragmas that can't be attached to, pass is things
1002 after. pass is used immediately. skips accumulates. *)
1003 let rec process_pragmas bef skips = function
1004 [] -> add_bef bef @ List.rev skips
1005 | ((PC.TPragma(s,i),_)::_) as l ->
1006 let (pragmas,rest) = collect_all_pragmas [] l in
1007 let (pass,rest0) = collect_pass rest in
1008 let (next,rest) =
1009 match rest0 with [] -> (None,[]) | next::rest -> (Some next,rest) in
1010 (match (bef,plus_attach true bef,next,plus_attach true next) with
1011 (Some bef,PLUS,_,_) ->
1012 let (a,b,c,d,e,strbef,straft,pos) = get_clt bef in
1013 (update_clt bef (a,b,c,d,e,strbef,pragmas,pos))::List.rev skips@
1014 pass@process_pragmas None [] rest0
1015 | (_,_,Some next,PLUS) ->
1016 let (a,b,c,d,e,strbef,straft,pos) = get_clt next in
1017 (add_bef bef) @ List.rev skips @ pass @
1018 (process_pragmas
1019 (Some (update_clt next (a,b,c,d,e,pragmas,straft,pos)))
1020 [] rest)
1021 | _ ->
1022 (match (bef,plus_attach false bef,next,plus_attach false next) with
1023 (Some bef,PLUS,_,_) ->
1024 let (a,b,c,d,e,strbef,straft,pos) = get_clt bef in
1025 (update_clt bef (a,b,c,d,e,strbef,pragmas,pos))::List.rev skips@
1026 pass@process_pragmas None [] rest0
1027 | (_,_,Some next,PLUS) ->
1028 let (a,b,c,d,e,strbef,straft,pos) = get_clt next in
1029 (add_bef bef) @ List.rev skips @ pass @
1030 (process_pragmas
1031 (Some (update_clt next (a,b,c,d,e,pragmas,straft,pos)))
1032 [] rest)
1033 | _ -> failwith "nothing to attach pragma to"))
1034 | x::xs ->
1035 (match plus_attachable false x with
1036 SKIP -> process_pragmas bef (x::skips) xs
1037 | _ -> (add_bef bef) @ List.rev skips @ (process_pragmas (Some x) [] xs))
1038
1039 (* ----------------------------------------------------------------------- *)
1040 (* Drop ... ... . This is only allowed in + code, and arises when there is
1041 some - code between the ... *)
1042 (* drop whens as well - they serve no purpose in + code and they cause
1043 problems for drop_double_dots *)
1044
1045 let rec drop_when = function
1046 [] -> []
1047 | (PC.TWhen(clt),info)::xs ->
1048 let rec loop = function
1049 [] -> []
1050 | (PC.TLineEnd(_),info)::xs -> drop_when xs
1051 | x::xs -> loop xs in
1052 loop xs
1053 | x::xs -> x::drop_when xs
1054
1055 (* instead of dropping the double dots, we put TNothing in between them.
1056 these vanish after the parser, but keeping all the ...s in the + code makes
1057 it easier to align the + and - code in context_neg and in preparation for the
1058 isomorphisms. This shouldn't matter because the context code of the +
1059 slice is mostly ignored anyway *)
1060 let minus_to_nothing l =
1061 (* for cases like | <..., which may or may not arise from removing minus
1062 code, depending on whether <... is a statement or expression *)
1063 let is_minus tok =
1064 try
1065 let (d,_,_,_,_,_,_,_) = get_clt tok in
1066 (match d with
1067 D.MINUS | D.OPTMINUS | D.UNIQUEMINUS -> true
1068 | D.PLUS -> false
1069 | D.CONTEXT | D.UNIQUE | D.OPT -> false)
1070 with _ -> false in
1071 let rec minus_loop = function
1072 [] -> []
1073 | (d::ds) as l -> if is_minus d then minus_loop ds else l in
1074 let rec loop = function
1075 [] -> []
1076 | ((PC.TMid0(clt),i) as x)::t1::ts when is_minus t1 ->
1077 (match minus_loop ts with
1078 ((PC.TOEllipsis(_),_)::_) | ((PC.TPOEllipsis(_),_)::_)
1079 | ((PC.TEllipsis(_),_)::_) as l -> x::(PC.TNothing,i)::(loop l)
1080 | l -> x::(loop l))
1081 | t::ts -> t::(loop ts) in
1082 loop l
1083
1084 let rec drop_double_dots l =
1085 let start = function
1086 (PC.TOEllipsis(_),_) | (PC.TPOEllipsis(_),_)
1087 (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *) ->
1088 true
1089 | _ -> false in
1090 let middle = function
1091 (PC.TEllipsis(_),_) (* | (PC.TCircles(_),_) | (PC.TStars(_),_) *) -> true
1092 | _ -> false in
1093 let whenline = function
1094 (PC.TLineEnd(_),_) -> true
1095 (*| (PC.TMid0(_),_) -> true*)
1096 | _ -> false in
1097 let final = function
1098 (PC.TCEllipsis(_),_) | (PC.TPCEllipsis(_),_)
1099 (* | (PC.TCCircles(_),_) | (PC.TCStars(_),_) *) ->
1100 true
1101 | _ -> false in
1102 let any_before x = start x or middle x or final x or whenline x in
1103 let any_after x = start x or middle x or final x in
1104 let rec loop ((_,i) as prev) = function
1105 [] -> []
1106 | x::rest when any_before prev && any_after x ->
1107 (PC.TNothing,i)::x::(loop x rest)
1108 | x::rest -> x :: (loop x rest) in
1109 match l with
1110 [] -> []
1111 | (x::xs) -> x :: loop x xs
1112
1113 let rec fix f l =
1114 let cur = f l in
1115 if l = cur then l else fix f cur
1116
1117 (* ( | ... | ) also causes parsing problems *)
1118
1119 exception Not_empty
1120
1121 let rec drop_empty_thing starter middle ender = function
1122 [] -> []
1123 | hd::rest when starter hd ->
1124 let rec loop = function
1125 x::rest when middle x -> loop rest
1126 | x::rest when ender x -> rest
1127 | _ -> raise Not_empty in
1128 (match try Some(loop rest) with Not_empty -> None with
1129 Some x -> drop_empty_thing starter middle ender x
1130 | None -> hd :: drop_empty_thing starter middle ender rest)
1131 | x::rest -> x :: drop_empty_thing starter middle ender rest
1132
1133 let drop_empty_or =
1134 drop_empty_thing
1135 (function (PC.TOPar0(_),_) -> true | _ -> false)
1136 (function (PC.TMid0(_),_) -> true | _ -> false)
1137 (function (PC.TCPar0(_),_) -> true | _ -> false)
1138
1139 let drop_empty_nest = drop_empty_thing
1140
1141 (* ----------------------------------------------------------------------- *)
1142 (* Read tokens *)
1143
1144 let get_s_starts (_, (s,_,(starts, ends))) =
1145 Printf.printf "%d %d\n" starts ends; (s, starts)
1146
1147 let pop2 l =
1148 let v = List.hd !l in
1149 l := List.tl !l;
1150 v
1151
1152 let reinit _ =
1153 PC.reinit (function _ -> PC.TArobArob (* a handy token *))
1154 (Lexing.from_function
1155 (function buf -> function n -> raise Common.Impossible))
1156
1157 let parse_one str parsefn file toks =
1158 let all_tokens = ref toks in
1159 let cur_tok = ref (List.hd !all_tokens) in
1160
1161 let lexer_function _ =
1162 let (v, info) = pop2 all_tokens in
1163 cur_tok := (v, info);
1164 v in
1165
1166 let lexbuf_fake =
1167 Lexing.from_function
1168 (function buf -> function n -> raise Common.Impossible)
1169 in
1170
1171 reinit();
1172
1173 try parsefn lexer_function lexbuf_fake
1174 with
1175 Lexer_cocci.Lexical s ->
1176 failwith
1177 (Printf.sprintf "%s: lexical error: %s\n =%s\n" str s
1178 (Common.error_message file (get_s_starts !cur_tok) ))
1179 | Parser_cocci_menhir.Error ->
1180 failwith
1181 (Printf.sprintf "%s: parse error: \n = %s\n" str
1182 (Common.error_message file (get_s_starts !cur_tok) ))
1183 | Semantic_cocci.Semantic s ->
1184 failwith
1185 (Printf.sprintf "%s: semantic error: %s\n =%s\n" str s
1186 (Common.error_message file (get_s_starts !cur_tok) ))
1187
1188 | e -> raise e
1189
1190 let prepare_tokens tokens =
1191 find_top_init
1192 (translate_when_true_false (* after insert_line_end *)
1193 (insert_line_end
1194 (detect_types false (find_function_names (detect_attr tokens)))))
1195
1196 let prepare_mv_tokens tokens =
1197 detect_types false (detect_attr tokens)
1198
1199 let rec consume_minus_positions = function
1200 [] -> []
1201 | ((PC.TOPar0(_),_) as x)::xs | ((PC.TCPar0(_),_) as x)::xs
1202 | ((PC.TMid0(_),_) as x)::xs -> x::consume_minus_positions xs
1203 | x::(PC.TPArob,_)::(PC.TMetaPos(name,constraints,per,clt),_)::xs ->
1204 let (arity,ln,lln,offset,col,strbef,straft,_) = get_clt x in
1205 let name = Parse_aux.clt2mcode name clt in
1206 let x =
1207 update_clt x
1208 (arity,ln,lln,offset,col,strbef,straft,
1209 Ast0.MetaPos(name,constraints,per)) in
1210 x::(consume_minus_positions xs)
1211 | x::xs -> x::consume_minus_positions xs
1212
1213 let any_modif rule =
1214 let mcode x =
1215 match Ast0.get_mcode_mcodekind x with
1216 Ast0.MINUS _ | Ast0.PLUS -> true
1217 | _ -> false in
1218 let donothing r k e = k e in
1219 let bind x y = x or y in
1220 let option_default = false in
1221 let fn =
1222 V0.flat_combiner bind option_default
1223 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1224 donothing donothing donothing donothing donothing donothing
1225 donothing donothing donothing donothing donothing donothing donothing
1226 donothing donothing in
1227 List.exists fn.VT0.combiner_rec_top_level rule
1228
1229 let drop_last extra l = List.rev(extra@(List.tl(List.rev l)))
1230
1231 let partition_either l =
1232 let rec part_either left right = function
1233 | [] -> (List.rev left, List.rev right)
1234 | x :: l ->
1235 (match x with
1236 | Common.Left e -> part_either (e :: left) right l
1237 | Common.Right e -> part_either left (e :: right) l) in
1238 part_either [] [] l
1239
1240 let get_metavars parse_fn table file lexbuf =
1241 let rec meta_loop acc (* read one decl at a time *) =
1242 let (_,tokens) =
1243 tokens_all table file true lexbuf [PC.TArobArob;PC.TMPtVirg] in
1244 let tokens = prepare_mv_tokens tokens in
1245 match tokens with
1246 [(PC.TArobArob,_)] -> List.rev acc
1247 | _ ->
1248 let metavars = parse_one "meta" parse_fn file tokens in
1249 meta_loop (metavars@acc) in
1250 partition_either (meta_loop [])
1251
1252 let get_script_metavars parse_fn table file lexbuf =
1253 let rec meta_loop acc =
1254 let (_, tokens) =
1255 tokens_all table file true lexbuf [PC.TArobArob; PC.TMPtVirg] in
1256 let tokens = prepare_tokens tokens in
1257 match tokens with
1258 [(PC.TArobArob, _)] -> List.rev acc
1259 | _ ->
1260 let metavar = parse_one "scriptmeta" parse_fn file tokens in
1261 meta_loop (metavar :: acc)
1262 in
1263 meta_loop []
1264
1265 let get_rule_name parse_fn starts_with_name get_tokens file prefix =
1266 Data.in_rule_name := true;
1267 let mknm _ = make_name prefix (!Lexer_cocci.line) in
1268 let name_res =
1269 if starts_with_name
1270 then
1271 let (_,tokens) = get_tokens [PC.TArob] in
1272 let check_name = function
1273 None -> Some (mknm())
1274 | Some nm ->
1275 (if List.mem nm reserved_names
1276 then failwith (Printf.sprintf "invalid name %s\n" nm));
1277 Some nm in
1278 match parse_one "rule name" parse_fn file tokens with
1279 Ast.CocciRulename (nm,a,b,c,d,e) ->
1280 Ast.CocciRulename (check_name nm,a,b,c,d,e)
1281 | Ast.GeneratedRulename (nm,a,b,c,d,e) ->
1282 Ast.GeneratedRulename (check_name nm,a,b,c,d,e)
1283 | Ast.ScriptRulename(s,deps) -> Ast.ScriptRulename(s,deps)
1284 | Ast.InitialScriptRulename(s) -> Ast.InitialScriptRulename(s)
1285 | Ast.FinalScriptRulename(s) -> Ast.FinalScriptRulename(s)
1286 else
1287 Ast.CocciRulename(Some(mknm()),Ast.NoDep,[],[],Ast.Undetermined,false) in
1288 Data.in_rule_name := false;
1289 name_res
1290
1291 let parse_iso file =
1292 let table = Common.full_charpos_to_pos file in
1293 Common.with_open_infile file (fun channel ->
1294 let lexbuf = Lexing.from_channel channel in
1295 let get_tokens = tokens_all table file false lexbuf in
1296 let res =
1297 match get_tokens [PC.TArobArob;PC.TArob] with
1298 (true,start) ->
1299 let parse_start start =
1300 let rev = List.rev start in
1301 let (arob,_) = List.hd rev in
1302 (arob = PC.TArob,List.rev(List.tl rev)) in
1303 let (starts_with_name,start) = parse_start start in
1304 let rec loop starts_with_name start =
1305 (!Data.init_rule)();
1306 (* get metavariable declarations - have to be read before the
1307 rest *)
1308 let (rule_name,_,_,_,_,_) =
1309 match get_rule_name PC.iso_rule_name starts_with_name get_tokens
1310 file ("iso file "^file) with
1311 Ast.CocciRulename (Some n,a,b,c,d,e) -> (n,a,b,c,d,e)
1312 | _ -> failwith "Script rules cannot appear in isomorphism rules"
1313 in
1314 Ast0.rule_name := rule_name;
1315 Data.in_meta := true;
1316 let iso_metavars =
1317 match get_metavars PC.iso_meta_main table file lexbuf with
1318 (iso_metavars,[]) -> iso_metavars
1319 | _ -> failwith "unexpected inheritance in iso" in
1320 Data.in_meta := false;
1321 (* get the rule *)
1322 let (more,tokens) =
1323 get_tokens
1324 [PC.TIsoStatement;PC.TIsoExpression;PC.TIsoArgExpression;
1325 PC.TIsoTestExpression;
1326 PC.TIsoDeclaration;PC.TIsoType;PC.TIsoTopLevel] in
1327 let next_start = List.hd(List.rev tokens) in
1328 let dummy_info = ("",(-1,-1),(-1,-1)) in
1329 let tokens = drop_last [(PC.EOF,dummy_info)] tokens in
1330 let tokens = prepare_tokens (start@tokens) in
1331 (*
1332 print_tokens "iso tokens" tokens;
1333 *)
1334 let entry = parse_one "iso main" PC.iso_main file tokens in
1335 let entry = List.map (List.map Test_exps.process_anything) entry in
1336 if more
1337 then (* The code below allows a header like Statement list,
1338 which is more than one word. We don't have that any more,
1339 but the code is left here in case it is put back. *)
1340 match get_tokens [PC.TArobArob;PC.TArob] with
1341 (true,start) ->
1342 let (starts_with_name,start) = parse_start start in
1343 (iso_metavars,entry,rule_name) ::
1344 (loop starts_with_name (next_start::start))
1345 | _ -> failwith "isomorphism ends early"
1346 else [(iso_metavars,entry,rule_name)] in
1347 loop starts_with_name start
1348 | (false,_) -> [] in
1349 res)
1350
1351 let parse_iso_files existing_isos iso_files extra_path =
1352 let get_names = List.map (function (_,_,nm) -> nm) in
1353 let old_names = get_names existing_isos in
1354 Data.in_iso := true;
1355 let (res,_) =
1356 List.fold_left
1357 (function (prev,names) ->
1358 function file ->
1359 Lexer_cocci.init ();
1360 let file =
1361 match file with
1362 Common.Left(fl) -> Filename.concat extra_path fl
1363 | Common.Right(fl) -> Filename.concat Config.path fl in
1364 let current = parse_iso file in
1365 let new_names = get_names current in
1366 if List.exists (function x -> List.mem x names) new_names
1367 then failwith (Printf.sprintf "repeated iso name found in %s" file);
1368 (current::prev,new_names @ names))
1369 ([],old_names) iso_files in
1370 Data.in_iso := false;
1371 existing_isos@(List.concat (List.rev res))
1372
1373 let parse file =
1374 let table = Common.full_charpos_to_pos file in
1375 Common.with_open_infile file (fun channel ->
1376 let lexbuf = Lexing.from_channel channel in
1377 let get_tokens = tokens_all table file false lexbuf in
1378 Data.in_prolog := true;
1379 let initial_tokens = get_tokens [PC.TArobArob;PC.TArob] in
1380 Data.in_prolog := false;
1381 let res =
1382 match initial_tokens with
1383 (true,data) ->
1384 (match List.rev data with
1385 ((PC.TArobArob as x),_)::_ | ((PC.TArob as x),_)::_ ->
1386 let iso_files =
1387 parse_one "iso file names" PC.include_main file data in
1388
1389 let parse_cocci_rule ruletype old_metas
1390 (rule_name, dependencies, iso, dropiso, exists, is_expression) =
1391 Ast0.rule_name := rule_name;
1392 Data.inheritable_positions :=
1393 rule_name :: !Data.inheritable_positions;
1394
1395 (* get metavariable declarations *)
1396 Data.in_meta := true;
1397 let (metavars, inherited_metavars) =
1398 get_metavars PC.meta_main table file lexbuf in
1399 Data.in_meta := false;
1400 Hashtbl.add Data.all_metadecls rule_name metavars;
1401 Hashtbl.add Lexer_cocci.rule_names rule_name ();
1402 Hashtbl.add Lexer_cocci.all_metavariables rule_name
1403 (Hashtbl.fold
1404 (fun key v rest -> (key,v)::rest)
1405 Lexer_cocci.metavariables []);
1406
1407 (* get transformation rules *)
1408 let (more, tokens) = get_tokens [PC.TArobArob; PC.TArob] in
1409 let (minus_tokens, _) = split_token_stream tokens in
1410 let (_, plus_tokens) =
1411 split_token_stream (minus_to_nothing tokens) in
1412
1413 let minus_tokens = consume_minus_positions minus_tokens in
1414 let minus_tokens = prepare_tokens minus_tokens in
1415 let plus_tokens = prepare_tokens plus_tokens in
1416
1417 (*
1418 print_tokens "minus tokens" minus_tokens;
1419 print_tokens "plus tokens" plus_tokens;
1420 *)
1421
1422 let plus_tokens =
1423 process_pragmas None []
1424 (fix (function x -> drop_double_dots (drop_empty_or x))
1425 (drop_when plus_tokens)) in
1426 (*
1427 print_tokens "plus tokens" plus_tokens;
1428 Printf.printf "before minus parse\n";
1429 *)
1430 let minus_res =
1431 if is_expression
1432 then parse_one "minus" PC.minus_exp_main file minus_tokens
1433 else parse_one "minus" PC.minus_main file minus_tokens in
1434 (*
1435 Unparse_ast0.unparse minus_res;
1436 Printf.printf "before plus parse\n";
1437 *)
1438 let plus_res =
1439 if !Flag.sgrep_mode2
1440 then (* not actually used for anything, except context_neg *)
1441 List.map
1442 (Iso_pattern.rebuild_mcode None).VT0.rebuilder_rec_top_level
1443 minus_res
1444 else
1445 if is_expression
1446 then parse_one "plus" PC.plus_exp_main file plus_tokens
1447 else parse_one "plus" PC.plus_main file plus_tokens in
1448 (*
1449 Printf.printf "after plus parse\n";
1450 *)
1451
1452 (if not !Flag.sgrep_mode2 &&
1453 (any_modif minus_res or any_modif plus_res)
1454 then Data.inheritable_positions := []);
1455
1456 Check_meta.check_meta rule_name old_metas inherited_metavars
1457 metavars minus_res plus_res;
1458
1459 (more, Ast0.CocciRule ((minus_res, metavars,
1460 (iso, dropiso, dependencies, rule_name, exists)),
1461 (plus_res, metavars), ruletype), metavars, tokens) in
1462
1463 let parse_script_rule language old_metas deps =
1464 let get_tokens = tokens_script_all table file false lexbuf in
1465
1466 (* meta-variables *)
1467 Data.in_meta := true;
1468 let metavars =
1469 get_script_metavars PC.script_meta_main table file lexbuf in
1470 Data.in_meta := false;
1471
1472 let exists_in old_metas (py,(r,m)) =
1473 let test (rr,mr) x =
1474 let (ro,vo) = Ast.get_meta_name x in
1475 ro = rr && vo = mr in
1476 List.exists (test (r,m)) old_metas in
1477
1478 List.iter
1479 (function x ->
1480 let meta2c (r,n) = Printf.sprintf "%s.%s" r n in
1481 if not (exists_in old_metas x) then
1482 failwith
1483 (Printf.sprintf
1484 "Script references unknown meta-variable: %s"
1485 (meta2c(snd x))))
1486 metavars;
1487
1488 (* script code *)
1489 let (more, tokens) = get_tokens [PC.TArobArob; PC.TArob] in
1490 let data =
1491 match List.hd tokens with
1492 (PC.TScriptData(s),_) -> s
1493 | (PC.TArobArob,_) | (PC.TArob,_) -> ""
1494 | _ -> failwith "Malformed script rule" in
1495 (more,Ast0.ScriptRule(language, deps, metavars, data),[],tokens) in
1496
1497 let parse_if_script_rule k language =
1498 let get_tokens = tokens_script_all table file false lexbuf in
1499
1500 (* script code *)
1501 let (more, tokens) = get_tokens [PC.TArobArob; PC.TArob] in
1502 let data =
1503 match List.hd tokens with
1504 (PC.TScriptData(s),_) -> s
1505 | (PC.TArobArob,_) | (PC.TArob,_) -> ""
1506 | _ -> failwith "Malformed script rule" in
1507 (more,k (language, data),[],tokens) in
1508
1509 let parse_iscript_rule =
1510 parse_if_script_rule
1511 (function (language,data) ->
1512 Ast0.InitialScriptRule(language,data)) in
1513
1514 let parse_fscript_rule =
1515 parse_if_script_rule
1516 (function (language,data) ->
1517 Ast0.FinalScriptRule(language,data)) in
1518
1519 let parse_rule old_metas starts_with_name =
1520 let rulename =
1521 get_rule_name PC.rule_name starts_with_name get_tokens file
1522 "rule" in
1523 match rulename with
1524 Ast.CocciRulename (Some s, a, b, c, d, e) ->
1525 parse_cocci_rule Ast.Normal old_metas (s, a, b, c, d, e)
1526 | Ast.GeneratedRulename (Some s, a, b, c, d, e) ->
1527 Data.in_generating := true;
1528 let res =
1529 parse_cocci_rule Ast.Generated old_metas (s,a,b,c,d,e) in
1530 Data.in_generating := false;
1531 res
1532 | Ast.ScriptRulename(l,deps) -> parse_script_rule l old_metas deps
1533 | Ast.InitialScriptRulename(l) -> parse_iscript_rule l
1534 | Ast.FinalScriptRulename(l) -> parse_fscript_rule l
1535 | _ -> failwith "Malformed rule name"
1536 in
1537
1538 let rec loop old_metas starts_with_name =
1539 (!Data.init_rule)();
1540
1541 let gen_starts_with_name more tokens =
1542 more &&
1543 (match List.hd (List.rev tokens) with
1544 (PC.TArobArob,_) -> false
1545 | (PC.TArob,_) -> true
1546 | _ -> failwith "unexpected token")
1547 in
1548
1549 let (more, rule, metavars, tokens) =
1550 parse_rule old_metas starts_with_name in
1551 if more then
1552 rule::
1553 (loop (metavars @ old_metas) (gen_starts_with_name more tokens))
1554 else [rule];
1555
1556 in
1557
1558 (iso_files, loop [] (x = PC.TArob))
1559 | _ -> failwith "unexpected code before the first rule\n")
1560 | (false,[(PC.TArobArob,_)]) | (false,[(PC.TArob,_)]) ->
1561 ([],([] : Ast0.parsed_rule list))
1562 | _ -> failwith "unexpected code before the first rule\n" in
1563 res)
1564
1565 (* parse to ast0 and then convert to ast *)
1566 let process file isofile verbose =
1567 let extra_path = Filename.dirname file in
1568 Lexer_cocci.init();
1569 let (iso_files, rules) = parse file in
1570 let std_isos =
1571 match isofile with
1572 None -> []
1573 | Some iso_file -> parse_iso_files [] [Common.Left iso_file] "" in
1574 let global_isos = parse_iso_files std_isos iso_files extra_path in
1575 let rules = Unitary_ast0.do_unitary rules in
1576 let parsed =
1577 List.map
1578 (function
1579 Ast0.ScriptRule (a,b,c,d) -> [([],Ast.ScriptRule (a,b,c,d))]
1580 | Ast0.InitialScriptRule (a,b) -> [([],Ast.InitialScriptRule (a,b))]
1581 | Ast0.FinalScriptRule (a,b) -> [([],Ast.FinalScriptRule (a,b))]
1582 | Ast0.CocciRule
1583 ((minus, metavarsm,
1584 (iso, dropiso, dependencies, rule_name, exists)),
1585 (plus, metavars),ruletype) ->
1586 let chosen_isos =
1587 parse_iso_files global_isos
1588 (List.map (function x -> Common.Left x) iso)
1589 extra_path in
1590 let chosen_isos =
1591 (* check that dropped isos are actually available *)
1592 (try
1593 let iso_names =
1594 List.map (function (_,_,nm) -> nm) chosen_isos in
1595 let local_iso_names = reserved_names @ iso_names in
1596 let bad_dropped =
1597 List.find
1598 (function dropped ->
1599 not (List.mem dropped local_iso_names))
1600 dropiso in
1601 failwith
1602 ("invalid iso name " ^ bad_dropped ^ " in " ^ rule_name)
1603 with Not_found -> ());
1604 if List.mem "all" dropiso
1605 then
1606 if List.length dropiso = 1
1607 then []
1608 else failwith "disable all should only be by itself"
1609 else (* drop those isos *)
1610 List.filter
1611 (function (_,_,nm) -> not (List.mem nm dropiso))
1612 chosen_isos in
1613 List.iter Iso_compile.process chosen_isos;
1614 let dropped_isos =
1615 match reserved_names with
1616 "all"::others ->
1617 (match dropiso with
1618 ["all"] -> others
1619 | _ ->
1620 List.filter (function x -> List.mem x dropiso) others)
1621 | _ ->
1622 failwith
1623 "bad list of reserved names - all must be at start" in
1624 let minus = Test_exps.process minus in
1625 let minus = Compute_lines.compute_lines minus in
1626 let plus = Compute_lines.compute_lines plus in
1627 let is_exp =
1628 (* only relevant to Flag.make_hrule *)
1629 (* doesn't handle multiple minirules properly, but since
1630 we don't really handle them in lots of other ways, it
1631 doesn't seem very important *)
1632 match plus with
1633 [] -> [false]
1634 | p::_ ->
1635 [match Ast0.unwrap p with
1636 Ast0.CODE c ->
1637 (match List.map Ast0.unwrap (Ast0.undots c) with
1638 [Ast0.Exp e] -> true | _ -> false)
1639 | _ -> false] in
1640 let minus = Arity.minus_arity minus in
1641 let ((metavars,minus),function_prototypes) =
1642 Function_prototypes.process
1643 rule_name metavars dropped_isos minus plus ruletype in
1644 let plus = Adjust_pragmas.process plus in
1645 (* warning! context_neg side-effects its arguments *)
1646 let (m,p) = List.split (Context_neg.context_neg minus plus) in
1647 Type_infer.type_infer p;
1648 (if not !Flag.sgrep_mode2
1649 then Insert_plus.insert_plus m p (chosen_isos = []));
1650 Type_infer.type_infer minus;
1651 let (extra_meta, minus) =
1652 match (chosen_isos,ruletype) with
1653 (* separate case for [] because applying isos puts
1654 some restrictions on the -+ code *)
1655 ([],_) | (_,Ast.Generated) -> ([],minus)
1656 | _ -> Iso_pattern.apply_isos chosen_isos minus rule_name in
1657 let minus = Comm_assoc.comm_assoc minus rule_name dropiso in
1658 let minus =
1659 if !Flag.sgrep_mode2 then minus
1660 else Single_statement.single_statement minus in
1661 let minus = Simple_assignments.simple_assignments minus in
1662 let minus_ast =
1663 Ast0toast.ast0toast rule_name dependencies dropped_isos
1664 exists minus is_exp ruletype in
1665 match function_prototypes with
1666 None -> [(extra_meta @ metavars, minus_ast)]
1667 | Some mv_fp ->
1668 [(extra_meta @ metavars, minus_ast); mv_fp])
1669 (* Ast0.CocciRule ((minus, metavarsm, (iso, dropiso, dependencies, rule_name, exists)), (plus, metavars))*)
1670 rules in
1671 let parsed = List.concat parsed in
1672 let disjd = Disjdistr.disj parsed in
1673
1674 let (metavars,code,fvs,neg_pos,ua,pos) = Free_vars.free_vars disjd in
1675 if !Flag_parsing_cocci.show_SP
1676 then List.iter Pretty_print_cocci.unparse code;
1677
1678 let grep_tokens =
1679 Common.profile_code "get_constants"
1680 (fun () -> Get_constants.get_constants code) in (* for grep *)
1681 let glimpse_tokens2 =
1682 Common.profile_code "get_glimpse_constants"
1683 (fun () -> Get_constants2.get_constants code neg_pos) in(* for glimpse *)
1684 (metavars,code,fvs,neg_pos,ua,pos,grep_tokens,glimpse_tokens2)
Unnamed repository; edit this file 'description' to name the repository.