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


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