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


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