2 * Copyright 2005-2010, Ecole des Mines de Nantes, University of Copenhagen
3 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
4 * This file is part of Coccinelle.
6 * Coccinelle is free software: you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation, according to version 2 of the License.
10 * Coccinelle is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
15 * You should have received a copy of the GNU General Public License
16 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
18 * The authors reserve the right to distribute this or future versions of
19 * Coccinelle under other licenses.
23 (* splits the entire file into minus and plus fragments, and parses each
24 separately (thus duplicating work for the parsing of the context elements) *)
27 module PC
= Parser_cocci_menhir
28 module V0
= Visitor_ast0
29 module VT0
= Visitor_ast0_types
30 module Ast
= Ast_cocci
31 module Ast0
= Ast0_cocci
32 let pr = Printf.sprintf
33 (*let pr2 s = prerr_string s; prerr_string "\n"; flush stderr*)
34 let pr2 s
= Printf.printf
"%s\n" s
36 (* for isomorphisms. all should be at the front!!! *)
38 ["all";"optional_storage";"optional_qualifier";"value_format";"comm_assoc"]
40 (* ----------------------------------------------------------------------- *)
43 let line_type (d
,_
,_
,_
,_
,_
,_
,_
) = d
46 match line_type tok
with
47 D.MINUS
| D.OPTMINUS
| D.UNIQUEMINUS
-> ":-"
50 | D.CONTEXT
| D.UNIQUE
| D.OPT
-> ""
54 PC.TIdentifier
-> "identifier"
56 | PC.TParameter
-> "parameter"
57 | PC.TConstant
-> "constant"
58 | PC.TExpression
-> "expression"
59 | PC.TIdExpression
-> "idexpression"
60 | PC.TInitialiser
-> "initialiser"
61 | PC.TStatement
-> "statement"
62 | PC.TPosition
-> "position"
64 | PC.TFunction
-> "function"
65 | PC.TLocal
-> "local"
67 | PC.TFresh
-> "fresh"
68 | PC.TCppConcatOp
-> "##"
70 | PC.TContext
-> "context"
71 | PC.TTypedef
-> "typedef"
72 | PC.TDeclarer
-> "declarer"
73 | PC.TIterator
-> "iterator"
75 | PC.TRuleName str
-> "rule_name-"^str
76 | PC.TUsing
-> "using"
77 | PC.TVirtual
-> "virtual"
78 | PC.TPathIsoFile str
-> "path_iso_file-"^str
79 | PC.TDisable
-> "disable"
80 | PC.TExtends
-> "extends"
81 | PC.TDepends
-> "depends"
84 | PC.TNever
-> "never"
85 | PC.TExists
-> "exists"
86 | PC.TForall
-> "forall"
87 | PC.TError
-> "error"
88 | PC.TWords
-> "words"
89 | PC.TGenerated
-> "generated"
91 | PC.TNothing
-> "nothing"
93 | PC.Tchar
(clt
) -> "char"^
(line_type2c clt
)
94 | PC.Tshort
(clt
) -> "short"^
(line_type2c clt
)
95 | PC.Tint
(clt
) -> "int"^
(line_type2c clt
)
96 | PC.Tdouble
(clt
) -> "double"^
(line_type2c clt
)
97 | PC.Tfloat
(clt
) -> "float"^
(line_type2c clt
)
98 | PC.Tlong
(clt
) -> "long"^
(line_type2c clt
)
99 | PC.Tvoid
(clt
) -> "void"^
(line_type2c clt
)
100 | PC.Tstruct
(clt
) -> "struct"^
(line_type2c clt
)
101 | PC.Tunion
(clt
) -> "union"^
(line_type2c clt
)
102 | PC.Tenum
(clt
) -> "enum"^
(line_type2c clt
)
103 | PC.Tunsigned
(clt
) -> "unsigned"^
(line_type2c clt
)
104 | PC.Tsigned
(clt
) -> "signed"^
(line_type2c clt
)
105 | PC.Tstatic
(clt
) -> "static"^
(line_type2c clt
)
106 | PC.Tinline
(clt
) -> "inline"^
(line_type2c clt
)
107 | PC.Ttypedef
(clt
) -> "typedef"^
(line_type2c clt
)
108 | PC.Tattr
(s
,clt
) -> s^
(line_type2c clt
)
109 | PC.Tauto
(clt
) -> "auto"^
(line_type2c clt
)
110 | PC.Tregister
(clt
) -> "register"^
(line_type2c clt
)
111 | PC.Textern
(clt
) -> "extern"^
(line_type2c clt
)
112 | PC.Tconst
(clt
) -> "const"^
(line_type2c clt
)
113 | PC.Tvolatile
(clt
) -> "volatile"^
(line_type2c clt
)
115 | PC.TPragma
(Ast.Noindent s
,_
) -> s
116 | PC.TPragma
(Ast.Indent s
,_
) -> s
117 | PC.TIncludeL
(s
,clt
) -> (pr "#include \"%s\"" s
)^
(line_type2c clt
)
118 | PC.TIncludeNL
(s
,clt
) -> (pr "#include <%s>" s
)^
(line_type2c clt
)
119 | PC.TDefine
(clt
,_
) -> "#define"^
(line_type2c clt
)
120 | PC.TDefineParam
(clt
,_
,_
,_
) -> "#define_param"^
(line_type2c clt
)
121 | PC.TMinusFile
(s
,clt
) -> (pr "--- %s" s
)^
(line_type2c clt
)
122 | PC.TPlusFile
(s
,clt
) -> (pr "+++ %s" s
)^
(line_type2c clt
)
124 | PC.TInc
(clt
) -> "++"^
(line_type2c clt
)
125 | PC.TDec
(clt
) -> "--"^
(line_type2c clt
)
127 | PC.TIf
(clt
) -> "if"^
(line_type2c clt
)
128 | PC.TElse
(clt
) -> "else"^
(line_type2c clt
)
129 | PC.TWhile
(clt
) -> "while"^
(line_type2c clt
)
130 | PC.TFor
(clt
) -> "for"^
(line_type2c clt
)
131 | PC.TDo
(clt
) -> "do"^
(line_type2c clt
)
132 | PC.TSwitch
(clt
) -> "switch"^
(line_type2c clt
)
133 | PC.TCase
(clt
) -> "case"^
(line_type2c clt
)
134 | PC.TDefault
(clt
) -> "default"^
(line_type2c clt
)
135 | PC.TReturn
(clt
) -> "return"^
(line_type2c clt
)
136 | PC.TBreak
(clt
) -> "break"^
(line_type2c clt
)
137 | PC.TContinue
(clt
) -> "continue"^
(line_type2c clt
)
138 | PC.TGoto
(clt
) -> "goto"^
(line_type2c clt
)
139 | PC.TIdent
(s
,clt
) -> (pr "ident-%s" s
)^
(line_type2c clt
)
140 | PC.TTypeId
(s
,clt
) -> (pr "typename-%s" s
)^
(line_type2c clt
)
141 | PC.TDeclarerId
(s
,clt
) -> (pr "declarername-%s" s
)^
(line_type2c clt
)
142 | PC.TIteratorId
(s
,clt
) -> (pr "iteratorname-%s" s
)^
(line_type2c clt
)
143 | PC.TMetaDeclarer
(_
,_
,_
,clt
) -> "declmeta"^
(line_type2c clt
)
144 | PC.TMetaIterator
(_
,_
,_
,clt
) -> "itermeta"^
(line_type2c clt
)
146 | PC.TSizeof
(clt
) -> "sizeof"^
(line_type2c clt
)
148 | PC.TString
(x
,clt
) -> x^
(line_type2c clt
)
149 | PC.TChar
(x
,clt
) -> x^
(line_type2c clt
)
150 | PC.TFloat
(x
,clt
) -> x^
(line_type2c clt
)
151 | PC.TInt
(x
,clt
) -> x^
(line_type2c clt
)
153 | PC.TOrLog
(clt
) -> "||"^
(line_type2c clt
)
154 | PC.TAndLog
(clt
) -> "&&"^
(line_type2c clt
)
155 | PC.TOr
(clt
) -> "|"^
(line_type2c clt
)
156 | PC.TXor
(clt
) -> "^"^
(line_type2c clt
)
157 | PC.TAnd
(clt
) -> "&"^
(line_type2c clt
)
158 | PC.TEqEq
(clt
) -> "=="^
(line_type2c clt
)
159 | PC.TNotEq
(clt
) -> "!="^
(line_type2c clt
)
160 | PC.TTildeEq
(clt
) -> "~="^
(line_type2c clt
)
161 | PC.TTildeExclEq
(clt
) -> "~!="^
(line_type2c clt
)
162 | PC.TLogOp
(op
,clt
) ->
168 | _
-> failwith
"not possible")
170 | PC.TShOp
(op
,clt
) ->
173 | Ast.DecRight
-> ">>"
174 | _
-> failwith
"not possible")
176 | PC.TPlus
(clt
) -> "+"^
(line_type2c clt
)
177 | PC.TMinus
(clt
) -> "-"^
(line_type2c clt
)
178 | PC.TMul
(clt
) -> "*"^
(line_type2c clt
)
179 | PC.TDmOp
(op
,clt
) ->
183 | _
-> failwith
"not possible")
185 | PC.TTilde
(clt
) -> "~"^
(line_type2c clt
)
187 | PC.TMetaParam
(_
,_
,clt
) -> "parammeta"^
(line_type2c clt
)
188 | PC.TMetaParamList
(_
,_
,_
,clt
) -> "paramlistmeta"^
(line_type2c clt
)
189 | PC.TMetaConst
(_
,_
,_
,_
,clt
) -> "constmeta"^
(line_type2c clt
)
190 | PC.TMetaErr
(_
,_
,_
,clt
) -> "errmeta"^
(line_type2c clt
)
191 | PC.TMetaExp
(_
,_
,_
,_
,clt
) -> "expmeta"^
(line_type2c clt
)
192 | PC.TMetaIdExp
(_
,_
,_
,_
,clt
) -> "idexpmeta"^
(line_type2c clt
)
193 | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
) -> "localidexpmeta"^
(line_type2c clt
)
194 | PC.TMetaExpList
(_
,_
,_
,clt
) -> "explistmeta"^
(line_type2c clt
)
195 | PC.TMetaId
(_
,_
,_
,clt
) -> "idmeta"^
(line_type2c clt
)
196 | PC.TMetaType
(_
,_
,clt
) -> "typemeta"^
(line_type2c clt
)
197 | PC.TMetaInit
(_
,_
,clt
) -> "initmeta"^
(line_type2c clt
)
198 | PC.TMetaStm
(_
,_
,clt
) -> "stmmeta"^
(line_type2c clt
)
199 | PC.TMetaStmList
(_
,_
,clt
) -> "stmlistmeta"^
(line_type2c clt
)
200 | PC.TMetaFunc
(_
,_
,_
,clt
) -> "funcmeta"^
(line_type2c clt
)
201 | PC.TMetaLocalFunc
(_
,_
,_
,clt
) -> "funcmeta"^
(line_type2c clt
)
202 | PC.TMetaPos
(_
,_
,_
,clt
) -> "posmeta"
204 | PC.TArobArob
-> "@@"
207 | PC.TScript
-> "script"
208 | PC.TInitialize
-> "initialize"
209 | PC.TFinalize
-> "finalize"
211 | PC.TWhen
(clt
) -> "WHEN"^
(line_type2c clt
)
212 | PC.TWhenTrue
(clt
) -> "WHEN TRUE"^
(line_type2c clt
)
213 | PC.TWhenFalse
(clt
) -> "WHEN FALSE"^
(line_type2c clt
)
214 | PC.TAny
(clt
) -> "ANY"^
(line_type2c clt
)
215 | PC.TStrict
(clt
) -> "STRICT"^
(line_type2c clt
)
216 | PC.TEllipsis
(clt
) -> "..."^
(line_type2c clt
)
218 | PC.TCircles(clt) -> "ooo"^(line_type2c clt)
219 | PC.TStars(clt) -> "***"^(line_type2c clt)
222 | PC.TOEllipsis
(clt
) -> "<..."^
(line_type2c clt
)
223 | PC.TCEllipsis
(clt
) -> "...>"^
(line_type2c clt
)
224 | PC.TPOEllipsis
(clt
) -> "<+..."^
(line_type2c clt
)
225 | PC.TPCEllipsis
(clt
) -> "...+>"^
(line_type2c clt
)
227 | PC.TOCircles(clt) -> "<ooo"^(line_type2c clt)
228 | PC.TCCircles(clt) -> "ooo>"^(line_type2c clt)
229 | PC.TOStars(clt) -> "<***"^(line_type2c clt)
230 | PC.TCStars(clt) -> "***>"^(line_type2c clt)
236 | PC.TWhy
(clt
) -> "?"^
(line_type2c clt
)
237 | PC.TDotDot
(clt
) -> ":"^
(line_type2c clt
)
238 | PC.TBang
(clt
) -> "!"^
(line_type2c clt
)
239 | PC.TOPar
(clt
) -> "("^
(line_type2c clt
)
240 | PC.TOPar0
(clt
) -> "("^
(line_type2c clt
)
241 | PC.TMid0
(clt
) -> "|"^
(line_type2c clt
)
242 | PC.TCPar
(clt
) -> ")"^
(line_type2c clt
)
243 | PC.TCPar0
(clt
) -> ")"^
(line_type2c clt
)
245 | PC.TOBrace
(clt
) -> "{"^
(line_type2c clt
)
246 | PC.TCBrace
(clt
) -> "}"^
(line_type2c clt
)
247 | PC.TOCro
(clt
) -> "["^
(line_type2c clt
)
248 | PC.TCCro
(clt
) -> "]"^
(line_type2c clt
)
249 | PC.TOInit
(clt
) -> "{"^
(line_type2c clt
)
251 | PC.TPtrOp
(clt
) -> "->"^
(line_type2c clt
)
253 | PC.TEq
(clt
) -> "="^
(line_type2c clt
)
254 | PC.TAssign
(_
,clt
) -> "=op"^
(line_type2c clt
)
255 | PC.TDot
(clt
) -> "."^
(line_type2c clt
)
256 | PC.TComma
(clt
) -> ","^
(line_type2c clt
)
257 | PC.TPtVirg
(clt
) -> ";"^
(line_type2c clt
)
260 | PC.TLineEnd
(clt
) -> "line end"
261 | PC.TInvalid
-> "invalid"
262 | PC.TFunDecl
(clt
) -> "fundecl"
265 | PC.TRightIso
-> "=>"
266 | PC.TIsoTopLevel
-> "TopLevel"
267 | PC.TIsoExpression
-> "Expression"
268 | PC.TIsoArgExpression
-> "ArgExpression"
269 | PC.TIsoTestExpression
-> "TestExpression"
270 | PC.TIsoToTestExpression
-> "ToTestExpression"
271 | PC.TIsoStatement
-> "Statement"
272 | PC.TIsoDeclaration
-> "Declaration"
273 | PC.TIsoType
-> "Type"
274 | PC.TScriptData s
-> s
276 let print_tokens s tokens
=
277 Printf.printf
"%s\n" s
;
278 List.iter
(function x
-> Printf.printf
"%s " (token2c x
)) tokens
;
279 Printf.printf
"\n\n";
282 type plus
= PLUS
| NOTPLUS
| SKIP
284 let plus_attachable only_plus
(tok
,_
) =
286 PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
287 | PC.Tfloat
(clt
) | PC.Tlong
(clt
) | PC.Tvoid
(clt
) | PC.Tstruct
(clt
)
288 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
290 | PC.Tinline
(clt
) | PC.Ttypedef
(clt
) | PC.Tattr
(_
,clt
)
291 | PC.Tauto
(clt
) | PC.Tregister
(clt
)
292 | PC.Textern
(clt
) | PC.Tconst
(clt
) | PC.Tvolatile
(clt
)
294 | PC.TIncludeL
(_
,clt
) | PC.TIncludeNL
(_
,clt
) | PC.TDefine
(clt
,_
)
295 | PC.TDefineParam
(clt
,_
,_
,_
) | PC.TMinusFile
(_
,clt
) | PC.TPlusFile
(_
,clt
)
297 | PC.TInc
(clt
) | PC.TDec
(clt
)
299 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
300 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
) | PC.TReturn
(clt
)
301 | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
) | PC.TIdent
(_
,clt
)
302 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
306 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
)
308 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
309 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TTildeEq
(clt
) | PC.TLogOp
(_
,clt
)
310 | PC.TShOp
(_
,clt
) | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
311 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
)
313 | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
314 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaErr
(_
,_
,_
,clt
)
315 | PC.TMetaExp
(_
,_
,_
,_
,clt
) | PC.TMetaIdExp
(_
,_
,_
,_
,clt
)
316 | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
317 | PC.TMetaExpList
(_
,_
,_
,clt
)
318 | PC.TMetaId
(_
,_
,_
,clt
)
319 | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
) | PC.TMetaStm
(_
,_
,clt
)
320 | PC.TMetaStmList
(_
,_
,clt
) | PC.TMetaFunc
(_
,_
,_
,clt
)
321 | PC.TMetaLocalFunc
(_
,_
,_
,clt
)
323 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
)
324 | PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TEllipsis
(clt
)
325 (* | PC.TCircles(clt) | PC.TStars(clt) *)
327 | PC.TWhy
(clt
) | PC.TDotDot
(clt
) | PC.TBang
(clt
) | PC.TOPar
(clt
)
330 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOCro
(clt
) | PC.TCCro
(clt
)
335 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
337 if List.mem
(line_type clt
) [D.PLUS
;D.PLUSPLUS
]
339 else if only_plus
then NOTPLUS
340 else if line_type clt
= D.CONTEXT
then PLUS
else NOTPLUS
342 | PC.TOPar0
(clt
) | PC.TMid0
(clt
) | PC.TCPar0
(clt
)
343 | PC.TOEllipsis
(clt
) | PC.TCEllipsis
(clt
)
344 | PC.TPOEllipsis
(clt
) | PC.TPCEllipsis
(clt
) (* | PC.TOCircles(clt)
345 | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *) -> NOTPLUS
346 | PC.TMetaPos
(nm
,_
,_
,_
) -> NOTPLUS
350 let get_clt (tok
,_
) =
352 PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
353 | PC.Tfloat
(clt
) | PC.Tlong
(clt
) | PC.Tvoid
(clt
) | PC.Tstruct
(clt
)
354 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
356 | PC.Tinline
(clt
) | PC.Tattr
(_
,clt
) | PC.Tauto
(clt
) | PC.Tregister
(clt
)
357 | PC.Textern
(clt
) | PC.Tconst
(clt
) | PC.Tvolatile
(clt
)
359 | PC.TIncludeL
(_
,clt
) | PC.TIncludeNL
(_
,clt
) | PC.TDefine
(clt
,_
)
360 | PC.TDefineParam
(clt
,_
,_
,_
) | PC.TMinusFile
(_
,clt
) | PC.TPlusFile
(_
,clt
)
362 | PC.TInc
(clt
) | PC.TDec
(clt
)
364 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
365 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
) | PC.TReturn
(clt
)
366 | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
) | PC.TIdent
(_
,clt
)
367 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
371 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
)
373 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
374 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TTildeEq
(clt
) | PC.TLogOp
(_
,clt
)
375 | PC.TShOp
(_
,clt
) | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
376 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
)
378 | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
379 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaErr
(_
,_
,_
,clt
)
380 | PC.TMetaExp
(_
,_
,_
,_
,clt
) | PC.TMetaIdExp
(_
,_
,_
,_
,clt
)
381 | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
382 | PC.TMetaExpList
(_
,_
,_
,clt
)
383 | PC.TMetaId
(_
,_
,_
,clt
)
384 | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
) | PC.TMetaStm
(_
,_
,clt
)
385 | PC.TMetaStmList
(_
,_
,clt
) | PC.TMetaFunc
(_
,_
,_
,clt
)
386 | PC.TMetaLocalFunc
(_
,_
,_
,clt
) | PC.TMetaPos
(_
,_
,_
,clt
)
388 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
) |
389 PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TEllipsis
(clt
)
390 (* | PC.TCircles(clt) | PC.TStars(clt) *)
392 | PC.TWhy
(clt
) | PC.TDotDot
(clt
) | PC.TBang
(clt
) | PC.TOPar
(clt
)
395 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOCro
(clt
) | PC.TCCro
(clt
)
400 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
403 | PC.TOPar0
(clt
) | PC.TMid0
(clt
) | PC.TCPar0
(clt
)
404 | PC.TOEllipsis
(clt
) | PC.TCEllipsis
(clt
)
405 | PC.TPOEllipsis
(clt
) | PC.TPCEllipsis
(clt
) (* | PC.TOCircles(clt)
406 | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *) -> clt
408 | _
-> failwith
"no clt"
410 let update_clt (tok
,x
) clt
=
412 PC.Tchar
(_
) -> (PC.Tchar
(clt
),x
)
413 | PC.Tshort
(_
) -> (PC.Tshort
(clt
),x
)
414 | PC.Tint
(_
) -> (PC.Tint
(clt
),x
)
415 | PC.Tdouble
(_
) -> (PC.Tdouble
(clt
),x
)
416 | PC.Tfloat
(_
) -> (PC.Tfloat
(clt
),x
)
417 | PC.Tlong
(_
) -> (PC.Tlong
(clt
),x
)
418 | PC.Tvoid
(_
) -> (PC.Tvoid
(clt
),x
)
419 | PC.Tstruct
(_
) -> (PC.Tstruct
(clt
),x
)
420 | PC.Tunion
(_
) -> (PC.Tunion
(clt
),x
)
421 | PC.Tenum
(_
) -> (PC.Tenum
(clt
),x
)
422 | PC.Tunsigned
(_
) -> (PC.Tunsigned
(clt
),x
)
423 | PC.Tsigned
(_
) -> (PC.Tsigned
(clt
),x
)
424 | PC.Tstatic
(_
) -> (PC.Tstatic
(clt
),x
)
425 | PC.Tinline
(_
) -> (PC.Tinline
(clt
),x
)
426 | PC.Ttypedef
(_
) -> (PC.Ttypedef
(clt
),x
)
427 | PC.Tattr
(s
,_
) -> (PC.Tattr
(s
,clt
),x
)
428 | PC.Tauto
(_
) -> (PC.Tauto
(clt
),x
)
429 | PC.Tregister
(_
) -> (PC.Tregister
(clt
),x
)
430 | PC.Textern
(_
) -> (PC.Textern
(clt
),x
)
431 | PC.Tconst
(_
) -> (PC.Tconst
(clt
),x
)
432 | PC.Tvolatile
(_
) -> (PC.Tvolatile
(clt
),x
)
434 | PC.TIncludeL
(s
,_
) -> (PC.TIncludeL
(s
,clt
),x
)
435 | PC.TIncludeNL
(s
,_
) -> (PC.TIncludeNL
(s
,clt
),x
)
436 | PC.TDefine
(_
,a
) -> (PC.TDefine
(clt
,a
),x
)
437 | PC.TDefineParam
(_
,a
,b
,c
) -> (PC.TDefineParam
(clt
,a
,b
,c
),x
)
438 | PC.TMinusFile
(s
,_
) -> (PC.TMinusFile
(s
,clt
),x
)
439 | PC.TPlusFile
(s
,_
) -> (PC.TPlusFile
(s
,clt
),x
)
441 | PC.TInc
(_
) -> (PC.TInc
(clt
),x
)
442 | PC.TDec
(_
) -> (PC.TDec
(clt
),x
)
444 | PC.TIf
(_
) -> (PC.TIf
(clt
),x
)
445 | PC.TElse
(_
) -> (PC.TElse
(clt
),x
)
446 | PC.TWhile
(_
) -> (PC.TWhile
(clt
),x
)
447 | PC.TFor
(_
) -> (PC.TFor
(clt
),x
)
448 | PC.TDo
(_
) -> (PC.TDo
(clt
),x
)
449 | PC.TSwitch
(_
) -> (PC.TSwitch
(clt
),x
)
450 | PC.TCase
(_
) -> (PC.TCase
(clt
),x
)
451 | PC.TDefault
(_
) -> (PC.TDefault
(clt
),x
)
452 | PC.TReturn
(_
) -> (PC.TReturn
(clt
),x
)
453 | PC.TBreak
(_
) -> (PC.TBreak
(clt
),x
)
454 | PC.TContinue
(_
) -> (PC.TContinue
(clt
),x
)
455 | PC.TGoto
(_
) -> (PC.TGoto
(clt
),x
)
456 | PC.TIdent
(s
,_
) -> (PC.TIdent
(s
,clt
),x
)
457 | PC.TTypeId
(s
,_
) -> (PC.TTypeId
(s
,clt
),x
)
458 | PC.TDeclarerId
(s
,_
) -> (PC.TDeclarerId
(s
,clt
),x
)
459 | PC.TIteratorId
(s
,_
) -> (PC.TIteratorId
(s
,clt
),x
)
461 | PC.TSizeof
(_
) -> (PC.TSizeof
(clt
),x
)
463 | PC.TString
(s
,_
) -> (PC.TString
(s
,clt
),x
)
464 | PC.TChar
(s
,_
) -> (PC.TChar
(s
,clt
),x
)
465 | PC.TFloat
(s
,_
) -> (PC.TFloat
(s
,clt
),x
)
466 | PC.TInt
(s
,_
) -> (PC.TInt
(s
,clt
),x
)
468 | PC.TOrLog
(_
) -> (PC.TOrLog
(clt
),x
)
469 | PC.TAndLog
(_
) -> (PC.TAndLog
(clt
),x
)
470 | PC.TOr
(_
) -> (PC.TOr
(clt
),x
)
471 | PC.TXor
(_
) -> (PC.TXor
(clt
),x
)
472 | PC.TAnd
(_
) -> (PC.TAnd
(clt
),x
)
473 | PC.TEqEq
(_
) -> (PC.TEqEq
(clt
),x
)
474 | PC.TNotEq
(_
) -> (PC.TNotEq
(clt
),x
)
475 | PC.TTildeEq
(_
) -> (PC.TTildeEq
(clt
),x
)
476 | PC.TLogOp
(op
,_
) -> (PC.TLogOp
(op
,clt
),x
)
477 | PC.TShOp
(op
,_
) -> (PC.TShOp
(op
,clt
),x
)
478 | PC.TPlus
(_
) -> (PC.TPlus
(clt
),x
)
479 | PC.TMinus
(_
) -> (PC.TMinus
(clt
),x
)
480 | PC.TMul
(_
) -> (PC.TMul
(clt
),x
)
481 | PC.TDmOp
(op
,_
) -> (PC.TDmOp
(op
,clt
),x
)
482 | PC.TTilde
(_
) -> (PC.TTilde
(clt
),x
)
484 | PC.TMetaParam
(a
,b
,_
) -> (PC.TMetaParam
(a
,b
,clt
),x
)
485 | PC.TMetaParamList
(a
,b
,c
,_
) -> (PC.TMetaParamList
(a
,b
,c
,clt
),x
)
486 | PC.TMetaConst
(a
,b
,c
,d
,_
) -> (PC.TMetaConst
(a
,b
,c
,d
,clt
),x
)
487 | PC.TMetaErr
(a
,b
,c
,_
) -> (PC.TMetaErr
(a
,b
,c
,clt
),x
)
488 | PC.TMetaExp
(a
,b
,c
,d
,_
) -> (PC.TMetaExp
(a
,b
,c
,d
,clt
),x
)
489 | PC.TMetaIdExp
(a
,b
,c
,d
,_
) -> (PC.TMetaIdExp
(a
,b
,c
,d
,clt
),x
)
490 | PC.TMetaLocalIdExp
(a
,b
,c
,d
,_
) -> (PC.TMetaLocalIdExp
(a
,b
,c
,d
,clt
),x
)
491 | PC.TMetaExpList
(a
,b
,c
,_
) -> (PC.TMetaExpList
(a
,b
,c
,clt
),x
)
492 | PC.TMetaId
(a
,b
,c
,_
) -> (PC.TMetaId
(a
,b
,c
,clt
),x
)
493 | PC.TMetaType
(a
,b
,_
) -> (PC.TMetaType
(a
,b
,clt
),x
)
494 | PC.TMetaInit
(a
,b
,_
) -> (PC.TMetaInit
(a
,b
,clt
),x
)
495 | PC.TMetaStm
(a
,b
,_
) -> (PC.TMetaStm
(a
,b
,clt
),x
)
496 | PC.TMetaStmList
(a
,b
,_
) -> (PC.TMetaStmList
(a
,b
,clt
),x
)
497 | PC.TMetaFunc
(a
,b
,c
,_
) -> (PC.TMetaFunc
(a
,b
,c
,clt
),x
)
498 | PC.TMetaLocalFunc
(a
,b
,c
,_
) -> (PC.TMetaLocalFunc
(a
,b
,c
,clt
),x
)
500 | PC.TWhen
(_
) -> (PC.TWhen
(clt
),x
)
501 | PC.TWhenTrue
(_
) -> (PC.TWhenTrue
(clt
),x
)
502 | PC.TWhenFalse
(_
) -> (PC.TWhenFalse
(clt
),x
)
503 | PC.TAny
(_
) -> (PC.TAny
(clt
),x
)
504 | PC.TStrict
(_
) -> (PC.TStrict
(clt
),x
)
505 | PC.TEllipsis
(_
) -> (PC.TEllipsis
(clt
),x
)
507 | PC.TCircles(_) -> (PC.TCircles(clt),x)
508 | PC.TStars(_) -> (PC.TStars(clt),x)
511 | PC.TOEllipsis
(_
) -> (PC.TOEllipsis
(clt
),x
)
512 | PC.TCEllipsis
(_
) -> (PC.TCEllipsis
(clt
),x
)
513 | PC.TPOEllipsis
(_
) -> (PC.TPOEllipsis
(clt
),x
)
514 | PC.TPCEllipsis
(_
) -> (PC.TPCEllipsis
(clt
),x
)
516 | PC.TOCircles(_) -> (PC.TOCircles(clt),x)
517 | PC.TCCircles(_) -> (PC.TCCircles(clt),x)
518 | PC.TOStars(_) -> (PC.TOStars(clt),x)
519 | PC.TCStars(_) -> (PC.TCStars(clt),x)
522 | PC.TWhy
(_
) -> (PC.TWhy
(clt
),x
)
523 | PC.TDotDot
(_
) -> (PC.TDotDot
(clt
),x
)
524 | PC.TBang
(_
) -> (PC.TBang
(clt
),x
)
525 | PC.TOPar
(_
) -> (PC.TOPar
(clt
),x
)
526 | PC.TOPar0
(_
) -> (PC.TOPar0
(clt
),x
)
527 | PC.TMid0
(_
) -> (PC.TMid0
(clt
),x
)
528 | PC.TCPar
(_
) -> (PC.TCPar
(clt
),x
)
529 | PC.TCPar0
(_
) -> (PC.TCPar0
(clt
),x
)
531 | PC.TOBrace
(_
) -> (PC.TOBrace
(clt
),x
)
532 | PC.TCBrace
(_
) -> (PC.TCBrace
(clt
),x
)
533 | PC.TOCro
(_
) -> (PC.TOCro
(clt
),x
)
534 | PC.TCCro
(_
) -> (PC.TCCro
(clt
),x
)
535 | PC.TOInit
(_
) -> (PC.TOInit
(clt
),x
)
537 | PC.TPtrOp
(_
) -> (PC.TPtrOp
(clt
),x
)
539 | PC.TEq
(_
) -> (PC.TEq
(clt
),x
)
540 | PC.TAssign
(s
,_
) -> (PC.TAssign
(s
,clt
),x
)
541 | PC.TDot
(_
) -> (PC.TDot
(clt
),x
)
542 | PC.TComma
(_
) -> (PC.TComma
(clt
),x
)
543 | PC.TPtVirg
(_
) -> (PC.TPtVirg
(clt
),x
)
545 | PC.TLineEnd
(_
) -> (PC.TLineEnd
(clt
),x
)
546 | PC.TFunDecl
(_
) -> (PC.TFunDecl
(clt
),x
)
548 | _
-> failwith
"no clt"
551 (* ----------------------------------------------------------------------- *)
553 let make_name prefix ln
= Printf.sprintf
"%s starting on line %d" prefix ln
555 (* ----------------------------------------------------------------------- *)
558 let wrap_lexbuf_info lexbuf
=
559 (Lexing.lexeme lexbuf
, Lexing.lexeme_start lexbuf
)
561 let tokens_all_full token table file get_ats lexbuf end_markers
:
562 (bool * ((PC.token
* (string * (int * int) * (int * int))) list
)) =
565 let result = token lexbuf
in
566 let info = (Lexing.lexeme lexbuf
,
567 (table
.(Lexing.lexeme_start lexbuf
)),
568 (Lexing.lexeme_start lexbuf
, Lexing.lexeme_end lexbuf
)) in
572 then failwith
"unexpected end of file in a metavariable declaration"
573 else (false,[(result,info)])
574 else if List.mem
result end_markers
575 then (true,[(result,info)])
577 let (more
,rest
) = aux() in
578 (more
,(result, info)::rest
)
581 e
-> pr2 (Common.error_message file
(wrap_lexbuf_info lexbuf
) ); raise e
583 let tokens_all table file get_ats lexbuf end_markers
:
584 (bool * ((PC.token
* (string * (int * int) * (int * int))) list
)) =
585 tokens_all_full Lexer_cocci.token table file get_ats lexbuf end_markers
587 let tokens_script_all table file get_ats lexbuf end_markers
:
588 (bool * ((PC.token
* (string * (int * int) * (int * int))) list
)) =
589 tokens_all_full Lexer_script.token table file get_ats lexbuf end_markers
591 (* ----------------------------------------------------------------------- *)
592 (* Split tokens into minus and plus fragments *)
595 let (d
,_
,_
,_
,_
,_
,_
,_
) = clt
in
597 D.MINUS
| D.OPTMINUS
| D.UNIQUEMINUS
-> ([t
],[])
598 | D.PLUS
| D.PLUSPLUS
-> ([],[t
])
599 | D.CONTEXT
| D.UNIQUE
| D.OPT
-> ([t
],[t
])
601 let split_token ((tok
,_
) as t
) =
603 PC.TIdentifier
| PC.TConstant
| PC.TExpression
| PC.TIdExpression
604 | PC.TStatement
| PC.TPosition
| PC.TPosAny
| PC.TInitialiser
605 | PC.TFunction
| PC.TTypedef
| PC.TDeclarer
| PC.TIterator
| PC.TName
606 | PC.TType
| PC.TParameter
| PC.TLocal
| PC.Tlist
| PC.TFresh
607 | PC.TCppConcatOp
| PC.TPure
608 | PC.TContext
| PC.TRuleName
(_
) | PC.TUsing
| PC.TVirtual
| PC.TDisable
609 | PC.TExtends
| PC.TPathIsoFile
(_
)
610 | PC.TDepends
| PC.TOn
| PC.TEver
| PC.TNever
| PC.TExists
| PC.TForall
611 | PC.TError
| PC.TWords
| PC.TGenerated
| PC.TNothing
-> ([t
],[t
])
613 | PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
614 | PC.Tfloat
(clt
) | PC.Tlong
(clt
) | PC.Tvoid
(clt
) | PC.Tstruct
(clt
)
615 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
616 | PC.Tstatic
(clt
) | PC.Tauto
(clt
) | PC.Tregister
(clt
) | PC.Textern
(clt
)
617 | PC.Tinline
(clt
) | PC.Ttypedef
(clt
) | PC.Tattr
(_
,clt
)
618 | PC.Tconst
(clt
) | PC.Tvolatile
(clt
) -> split t clt
620 | PC.TPragma
(s
,_
) -> ([],[t
]) (* only allowed in + *)
621 | PC.TPlusFile
(s
,clt
) | PC.TMinusFile
(s
,clt
)
622 | PC.TIncludeL
(s
,clt
) | PC.TIncludeNL
(s
,clt
) ->
624 | PC.TDefine
(clt
,_
) | PC.TDefineParam
(clt
,_
,_
,_
) -> split t clt
626 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
627 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
)
629 | PC.TReturn
(clt
) | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
)
631 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
632 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaExp
(_
,_
,_
,_
,clt
)
633 | PC.TMetaIdExp
(_
,_
,_
,_
,clt
) | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
634 | PC.TMetaExpList
(_
,_
,_
,clt
)
635 | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
636 | PC.TMetaId
(_
,_
,_
,clt
) | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
)
637 | PC.TMetaStm
(_
,_
,clt
) | PC.TMetaStmList
(_
,_
,clt
) | PC.TMetaErr
(_
,_
,_
,clt
)
638 | PC.TMetaFunc
(_
,_
,_
,clt
) | PC.TMetaLocalFunc
(_
,_
,_
,clt
)
639 | PC.TMetaDeclarer
(_
,_
,_
,clt
) | PC.TMetaIterator
(_
,_
,_
,clt
) -> split t clt
640 | PC.TMPtVirg
| PC.TArob
| PC.TArobArob
| PC.TScript
641 | PC.TInitialize
| PC.TFinalize
-> ([t
],[t
])
642 | PC.TPArob
| PC.TMetaPos
(_
,_
,_
,_
) -> ([t
],[])
645 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
)
646 | PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TLineEnd
(clt
)
647 | PC.TEllipsis
(clt
) (* | PC.TCircles(clt) | PC.TStars(clt) *) -> split t clt
649 | PC.TOEllipsis
(_
) | PC.TCEllipsis
(_
) (* clt must be context *)
650 | PC.TPOEllipsis
(_
) | PC.TPCEllipsis
(_
) (* clt must be context *)
652 | PC.TOCircles(_) | PC.TCCircles(_) (* clt must be context *)
653 | PC.TOStars
(_
) | PC.TCStars
(_
) (* clt must be context *)
655 | PC.TBang0
| PC.TPlus0
| PC.TWhy0
->
658 | PC.TWhy
(clt
) | PC.TDotDot
(clt
)
659 | PC.TBang
(clt
) | PC.TOPar
(clt
) | PC.TOPar0
(clt
)
660 | PC.TMid0
(clt
) | PC.TCPar
(clt
) | PC.TCPar0
(clt
) -> split t clt
662 | PC.TInc
(clt
) | PC.TDec
(clt
) -> split t clt
664 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
) ->
667 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
668 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TTildeEq
(clt
) | PC.TTildeExclEq
(clt
) | PC.TLogOp
(_
,clt
)
669 | PC.TShOp
(_
,clt
) | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
670 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
) -> split t clt
672 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOInit
(clt
) -> split t clt
673 | PC.TOCro
(clt
) | PC.TCCro
(clt
) -> split t clt
675 | PC.TPtrOp
(clt
) -> split t clt
677 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
678 | PC.TPtVirg
(clt
) -> split t clt
680 | PC.EOF
| PC.TInvalid
-> ([t
],[t
])
682 | PC.TIso
| PC.TRightIso
683 | PC.TIsoExpression
| PC.TIsoStatement
| PC.TIsoDeclaration
| PC.TIsoType
684 | PC.TIsoTopLevel
| PC.TIsoArgExpression
| PC.TIsoTestExpression
685 | PC.TIsoToTestExpression
->
686 failwith
"unexpected tokens"
687 | PC.TScriptData s
-> ([t
],[t
])
689 let split_token_stream tokens
=
690 let rec loop = function
693 let (minus
,plus
) = split_token token
in
694 let (minus_stream
,plus_stream
) = loop tokens
in
695 (minus
@minus_stream
,plus
@plus_stream
) in
698 (* ----------------------------------------------------------------------- *)
699 (* Find function names *)
700 (* This addresses a shift-reduce problem in the parser, allowing us to
701 distinguish a function declaration from a function call even if the latter
702 has no return type. Undoubtedly, this is not very nice, but it doesn't
703 seem very convenient to refactor the grammar to get around the problem. *)
705 let rec find_function_names = function
707 | ((PC.TIdent
(_
,clt
),info) as t1
) :: ((PC.TOPar
(_
),_
) as t2
) :: rest
708 | ((PC.TMetaId
(_
,_
,_
,clt
),info) as t1
) :: ((PC.TOPar
(_
),_
) as t2
) :: rest
709 | ((PC.TMetaFunc
(_
,_
,_
,clt
),info) as t1
) :: ((PC.TOPar
(_
),_
) as t2
) :: rest
710 | ((PC.TMetaLocalFunc
(_
,_
,_
,clt
),info) as t1
)::((PC.TOPar
(_
),_
) as t2
)::rest
712 let rec skip level
= function
714 | ((PC.TCPar
(_
),_
) as t
)::rest
->
715 let level = level - 1 in
718 else let (pre
,found
,post
) = skip level rest
in (t
::pre
,found
,post
)
719 | ((PC.TOPar
(_
),_
) as t
)::rest
->
720 let level = level + 1 in
721 let (pre
,found
,post
) = skip level rest
in (t
::pre
,found
,post
)
722 | ((PC.TArobArob
,_
) as t
)::rest
723 | ((PC.TArob
,_
) as t
)::rest
724 | ((PC.EOF
,_
) as t
)::rest
-> ([t
],false,rest
)
726 let (pre
,found
,post
) = skip level rest
in (t
::pre
,found
,post
) in
727 let (pre
,found
,post
) = skip 1 rest
in
728 (match (found
,post
) with
729 (true,((PC.TOBrace
(_
),_
) as t3
)::rest
) ->
730 (PC.TFunDecl
(clt
),info) :: t1
:: t2
:: pre
@
731 t3
:: (find_function_names rest
)
732 | _
-> t1
:: t2
:: pre
@ find_function_names post
)
733 | t
:: rest
-> t
:: find_function_names rest
735 (* ----------------------------------------------------------------------- *)
736 (* an attribute is an identifier that preceeds another identifier and
739 let rec detect_attr l
=
741 (PC.TIdent
(_
,_
),_
) | (PC.TMetaId
(_
,_
,_
,_
),_
) | (PC.TMetaFunc
(_
,_
,_
,_
),_
)
742 | (PC.TMetaLocalFunc
(_
,_
,_
,_
),_
) -> true
744 let rec loop = function
747 | ((PC.TIdent
(nm
,clt
),info) as t1
)::id
::rest
when is_id id
->
748 if String.length nm
> 2 && String.sub nm
0 2 = "__"
749 then (PC.Tattr
(nm
,clt
),info)::(loop (id
::rest
))
750 else t1
::(loop (id
::rest
))
751 | x
::xs
-> x
::(loop xs
) in
754 (* ----------------------------------------------------------------------- *)
755 (* Look for variable declarations where the name is a typedef name.
756 We assume that C code does not contain a multiplication as a top-level
759 (* bug: once a type, always a type, even if the same name is later intended
760 to be used as a real identifier *)
761 let detect_types in_meta_decls l
=
762 let is_delim infn
= function
763 (PC.TOEllipsis
(_
),_
) (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *)
764 | (PC.TPOEllipsis
(_
),_
) (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *)
765 | (PC.TEllipsis
(_
),_
) (* | (PC.TCircles(_),_) | (PC.TStars(_),_) *)
766 | (PC.TPtVirg
(_
),_
) | (PC.TOBrace
(_
),_
) | (PC.TOInit
(_
),_
)
768 | (PC.TPure
,_
) | (PC.TContext
,_
)
769 | (PC.Tstatic
(_
),_
) | (PC.Textern
(_
),_
)
770 | (PC.Tinline
(_
),_
) | (PC.Ttypedef
(_
),_
) | (PC.Tattr
(_
),_
) -> true
771 | (PC.TComma
(_
),_
) when infn
> 0 or in_meta_decls
-> true
772 | (PC.TDotDot
(_
),_
) when in_meta_decls
-> true
774 let is_choices_delim = function
775 (PC.TOBrace
(_
),_
) | (PC.TComma
(_
),_
) -> true | _
-> false in
777 (PC.TIdent
(_
,_
),_
) | (PC.TMetaId
(_
,_
,_
,_
),_
) | (PC.TMetaFunc
(_
,_
,_
,_
),_
)
778 | (PC.TMetaLocalFunc
(_
,_
,_
,_
),_
) -> true
779 | (PC.TMetaParam
(_
,_
,_
),_
)
780 | (PC.TMetaParamList
(_
,_
,_
,_
),_
)
781 | (PC.TMetaConst
(_
,_
,_
,_
,_
),_
)
782 | (PC.TMetaErr
(_
,_
,_
,_
),_
)
783 | (PC.TMetaExp
(_
,_
,_
,_
,_
),_
)
784 | (PC.TMetaIdExp
(_
,_
,_
,_
,_
),_
)
785 | (PC.TMetaLocalIdExp
(_
,_
,_
,_
,_
),_
)
786 | (PC.TMetaExpList
(_
,_
,_
,_
),_
)
787 | (PC.TMetaType
(_
,_
,_
),_
)
788 | (PC.TMetaInit
(_
,_
,_
),_
)
789 | (PC.TMetaStm
(_
,_
,_
),_
)
790 | (PC.TMetaStmList
(_
,_
,_
),_
)
791 | (PC.TMetaPos
(_
,_
,_
,_
),_
) -> in_meta_decls
793 let redo_id ident clt v
=
794 !Data.add_type_name ident
;
795 (PC.TTypeId
(ident
,clt
),v
) in
796 let rec loop start infn type_names
= function
797 (* infn: 0 means not in a function header
798 > 0 means in a function header, after infn - 1 unmatched open parens*)
800 | ((PC.TOBrace
(clt
),v
)::_
) as all
when in_meta_decls
->
801 collect_choices type_names all
(* never a function header *)
802 | delim
::(PC.TIdent
(ident
,clt
),v
)::((PC.TMul
(_
),_
) as x
)::rest
803 when is_delim infn delim
->
804 let newid = redo_id ident clt v
in
805 delim
::newid::x
::(loop false infn
(ident
::type_names
) rest
)
806 | delim
::(PC.TIdent
(ident
,clt
),v
)::id
::rest
807 when is_delim infn delim
&& is_id id
->
808 let newid = redo_id ident clt v
in
809 delim
::newid::id
::(loop false infn
(ident
::type_names
) rest
)
810 | ((PC.TFunDecl
(_
),_
) as fn
)::rest
->
811 fn
::(loop false 1 type_names rest
)
812 | ((PC.TOPar
(_
),_
) as lp
)::rest
when infn
> 0 ->
813 lp
::(loop false (infn
+ 1) type_names rest
)
814 | ((PC.TCPar
(_
),_
) as rp
)::rest
when infn
> 0 ->
816 then rp
::(loop false 0 type_names rest
) (* 0 means not in fn header *)
817 else rp
::(loop false (infn
- 1) type_names rest
)
818 | (PC.TIdent
(ident
,clt
),v
)::((PC.TMul
(_
),_
) as x
)::rest
when start
->
819 let newid = redo_id ident clt v
in
820 newid::x
::(loop false infn
(ident
::type_names
) rest
)
821 | (PC.TIdent
(ident
,clt
),v
)::id
::rest
when start
&& is_id id
->
822 let newid = redo_id ident clt v
in
823 newid::id
::(loop false infn
(ident
::type_names
) rest
)
824 | (PC.TIdent
(ident
,clt
),v
)::rest
when List.mem ident type_names
->
825 (PC.TTypeId
(ident
,clt
),v
)::(loop false infn type_names rest
)
826 | ((PC.TIdent
(ident
,clt
),v
) as x
)::rest
->
827 x
::(loop false infn type_names rest
)
828 | x
::rest
-> x
::(loop false infn type_names rest
)
829 and collect_choices type_names
= function
830 [] -> [] (* should happen, but let the parser detect that *)
831 | (PC.TCBrace
(clt
),v
)::rest
->
832 (PC.TCBrace
(clt
),v
)::(loop false 0 type_names rest
)
833 | delim
::(PC.TIdent
(ident
,clt
),v
)::rest
834 when is_choices_delim delim
->
835 let newid = redo_id ident clt v
in
836 delim
::newid::(collect_choices
(ident
::type_names
) rest
)
837 | x
::rest
-> x
::(collect_choices type_names rest
) in
841 (* ----------------------------------------------------------------------- *)
842 (* Insert TLineEnd tokens at the end of a line that contains a WHEN.
843 WHEN is restricted to a single line, to avoid ambiguity in eg:
847 let token2line (tok
,_
) =
849 PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
850 | PC.Tfloat
(clt
) | PC.Tlong
(clt
) | PC.Tvoid
(clt
) | PC.Tstruct
(clt
)
851 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
852 | PC.Tstatic
(clt
) | PC.Tauto
(clt
) | PC.Tregister
(clt
) | PC.Textern
(clt
)
853 | PC.Tinline
(clt
) | PC.Ttypedef
(clt
) | PC.Tattr
(_
,clt
) | PC.Tconst
(clt
)
856 | PC.TInc
(clt
) | PC.TDec
(clt
)
858 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
859 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
) | PC.TSizeof
(clt
)
860 | PC.TReturn
(clt
) | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
)
862 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
863 | PC.TMetaDeclarer
(_
,_
,_
,clt
) | PC.TMetaIterator
(_
,_
,_
,clt
)
865 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
)
867 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
868 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TLogOp
(_
,clt
)
869 | PC.TShOp
(_
,clt
) | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
870 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
)
872 | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
873 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaExp
(_
,_
,_
,_
,clt
)
874 | PC.TMetaIdExp
(_
,_
,_
,_
,clt
) | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
875 | PC.TMetaExpList
(_
,_
,_
,clt
)
876 | PC.TMetaId
(_
,_
,_
,clt
) | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
)
877 | PC.TMetaStm
(_
,_
,clt
) | PC.TMetaStmList
(_
,_
,clt
) | PC.TMetaFunc
(_
,_
,_
,clt
)
878 | PC.TMetaLocalFunc
(_
,_
,_
,clt
) | PC.TMetaPos
(_
,_
,_
,clt
)
881 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
)
882 | PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TEllipsis
(clt
)
883 (* | PC.TCircles(clt) | PC.TStars(clt) *)
885 | PC.TOEllipsis
(clt
) | PC.TCEllipsis
(clt
)
886 | PC.TPOEllipsis
(clt
) | PC.TPCEllipsis
(clt
) (*| PC.TOCircles(clt)
887 | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *)
889 | PC.TWhy
(clt
) | PC.TDotDot
(clt
) | PC.TBang
(clt
) | PC.TOPar
(clt
)
890 | PC.TOPar0
(clt
) | PC.TMid0
(clt
) | PC.TCPar
(clt
)
893 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOCro
(clt
) | PC.TCCro
(clt
)
898 | PC.TDefine
(clt
,_
) | PC.TDefineParam
(clt
,_
,_
,_
)
899 | PC.TIncludeL
(_
,clt
) | PC.TIncludeNL
(_
,clt
)
901 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
903 let (_
,line
,_
,_
,_
,_
,_
,_
) = clt
in Some line
907 let rec insert_line_end = function
909 | (((PC.TWhen
(clt
),q
) as x
)::xs
) ->
910 x
::(find_line_end
true (token2line x
) clt q xs
)
911 | (((PC.TDefine
(clt
,_
),q
) as x
)::xs
)
912 | (((PC.TDefineParam
(clt
,_
,_
,_
),q
) as x
)::xs
) ->
913 x
::(find_line_end
false (token2line x
) clt q xs
)
914 | x
::xs
-> x
::(insert_line_end xs
)
916 and find_line_end inwhen line clt q
= function
917 (* don't know what 2nd component should be so just use the info of
918 the When. Also inherit - of when, if any *)
919 [] -> [(PC.TLineEnd
(clt
),q
)]
920 | ((PC.TIdent
("strict",clt
),a
) as x
)::xs
when token2line x
= line
->
921 (PC.TStrict
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
922 | ((PC.TIdent
("STRICT",clt
),a
) as x
)::xs
when token2line x
= line
->
923 (PC.TStrict
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
924 | ((PC.TIdent
("any",clt
),a
) as x
)::xs
when token2line x
= line
->
925 (PC.TAny
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
926 | ((PC.TIdent
("ANY",clt
),a
) as x
)::xs
when token2line x
= line
->
927 (PC.TAny
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
928 | ((PC.TIdent
("forall",clt
),a
) as x
)::xs
when token2line x
= line
->
929 (PC.TForall
,a
) :: (find_line_end inwhen line clt q xs
)
930 | ((PC.TIdent
("exists",clt
),a
) as x
)::xs
when token2line x
= line
->
931 (PC.TExists
,a
) :: (find_line_end inwhen line clt q xs
)
932 | ((PC.TComma
(clt
),a
) as x
)::xs
when token2line x
= line
->
933 (PC.TComma
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
934 | ((PC.TPArob
,a
) as x
)::xs
-> (* no line #, just assume on the same line *)
935 x
:: (find_line_end inwhen line clt q xs
)
936 | x
::xs
when token2line x
= line
-> x
:: (find_line_end inwhen line clt q xs
)
937 | xs
-> (PC.TLineEnd
(clt
),q
)::(insert_line_end xs
)
939 let rec translate_when_true_false = function
941 | (PC.TWhen
(clt
),q
)::((PC.TNotEq
(_
),_
) as x
)::(PC.TIdent
("true",_
),_
)::xs
->
942 (PC.TWhenTrue
(clt
),q
)::x
::(translate_when_true_false xs
)
943 | (PC.TWhen
(clt
),q
)::((PC.TNotEq
(_
),_
) as x
)::(PC.TIdent
("false",_
),_
)::xs
->
944 (PC.TWhenFalse
(clt
),q
)::x
::(translate_when_true_false xs
)
945 | x
::xs
-> x
:: (translate_when_true_false xs
)
947 (* ----------------------------------------------------------------------- *)
949 let check_parentheses tokens
=
950 let clt2line (_
,line
,_
,_
,_
,_
,_
,_
) = line
in
951 let rec loop seen_open
= function
953 | (PC.TOPar
(clt
),q
) :: rest
954 | (PC.TDefineParam
(clt
,_
,_
,_
),q
) :: rest
->
955 loop (Common.Left
(clt2line clt
) :: seen_open
) rest
956 | (PC.TOPar0
(clt
),q
) :: rest
->
957 loop (Common.Right
(clt2line clt
) :: seen_open
) rest
958 | (PC.TCPar
(clt
),q
) :: rest
->
959 (match seen_open
with
963 "unexpected close parenthesis in line %d\n" (clt2line clt
))
964 | Common.Left _
:: seen_open
-> loop seen_open rest
965 | Common.Right open_line
:: _
->
968 "disjunction parenthesis in line %d column 0 matched to normal parenthesis on line %d\n" open_line
(clt2line clt
)))
969 | (PC.TCPar0
(clt
),q
) :: rest
->
970 (match seen_open
with
974 "unexpected close parenthesis in line %d\n" (clt2line clt
))
975 | Common.Right _
:: seen_open
-> loop seen_open rest
976 | Common.Left open_line
:: _
->
979 "normal parenthesis in line %d matched to disjunction parenthesis on line %d column 0\n" open_line
(clt2line clt
)))
980 | x
::rest
-> loop seen_open rest
in
983 (* ----------------------------------------------------------------------- *)
984 (* top level initializers: a sequence of braces followed by a dot *)
986 let find_top_init tokens
=
988 (PC.TOBrace
(clt
),q
) :: rest
->
989 let rec dot_start acc
= function
990 ((PC.TOBrace
(_
),_
) as x
) :: rest
->
991 dot_start (x
::acc
) rest
992 | ((PC.TDot
(_
),_
) :: rest
) as x
->
993 Some
((PC.TOInit
(clt
),q
) :: (List.rev acc
) @ x
)
995 let rec comma_end acc
= function
996 ((PC.TCBrace
(_
),_
) as x
) :: rest
->
997 comma_end (x
::acc
) rest
998 | ((PC.TComma
(_
),_
) :: rest
) as x
->
999 Some
((PC.TOInit
(clt
),q
) :: (List.rev x
) @ acc
)
1001 (match dot_start [] rest
with
1004 (match List.rev rest
with
1005 (* not super sure what this does, but EOF, @, and @@ should be
1006 the same, markind the end of a rule *)
1007 ((PC.EOF
,_
) as x
)::rest
| ((PC.TArob
,_
) as x
)::rest
1008 | ((PC.TArobArob
,_
) as x
)::rest
->
1009 (match comma_end [x
] rest
with
1013 failwith
"unexpected empty token list"))
1016 (* ----------------------------------------------------------------------- *)
1017 (* Integrate pragmas into some adjacent token. + tokens are preferred. Dots
1020 let rec collect_all_pragmas collected
= function
1021 (PC.TPragma
(s
,(_
,line
,logical_line
,offset
,col
,_
,_
,pos
)),_
)::rest
->
1023 { Ast0.line_start
= line
; Ast0.line_end
= line
;
1024 Ast0.logical_start
= logical_line
; Ast0.logical_end
= logical_line
;
1025 Ast0.column
= col
; Ast0.offset
= offset
; } in
1026 collect_all_pragmas ((s
,i)::collected
) rest
1027 | l
-> (List.rev collected
,l
)
1029 let rec collect_pass = function
1032 match plus_attachable false x
with
1034 let (pass
,rest
) = collect_pass xs
in
1038 let plus_attach strict
= function
1040 | Some x
-> plus_attachable strict x
1042 let add_bef = function Some x
-> [x
] | None
-> []
1044 (*skips should be things like line end
1045 skips is things before pragmas that can't be attached to, pass is things
1046 after. pass is used immediately. skips accumulates. *)
1047 let rec process_pragmas bef skips
= function
1048 [] -> add_bef bef
@ List.rev skips
1049 | ((PC.TPragma
(s
,i),_
)::_
) as l
->
1050 let (pragmas
,rest
) = collect_all_pragmas [] l
in
1051 let (pass
,rest0
) = collect_pass rest
in
1053 match rest0
with [] -> (None
,[]) | next
::rest
-> (Some next
,rest
) in
1054 (match (bef
,plus_attach true bef
,next
,plus_attach true next
) with
1055 (Some bef
,PLUS
,_
,_
) ->
1056 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt bef
in
1057 (update_clt bef
(a
,b
,c
,d
,e
,strbef
,pragmas
,pos
))::List.rev skips
@
1058 pass
@process_pragmas None
[] rest0
1059 | (_
,_
,Some next
,PLUS
) ->
1060 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt next
in
1061 (add_bef bef
) @ List.rev skips
@ pass
@
1063 (Some
(update_clt next
(a
,b
,c
,d
,e
,pragmas
,straft
,pos
)))
1066 (match (bef
,plus_attach false bef
,next
,plus_attach false next
) with
1067 (Some bef
,PLUS
,_
,_
) ->
1068 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt bef
in
1069 (update_clt bef
(a
,b
,c
,d
,e
,strbef
,pragmas
,pos
))::List.rev skips
@
1070 pass
@process_pragmas None
[] rest0
1071 | (_
,_
,Some next
,PLUS
) ->
1072 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt next
in
1073 (add_bef bef
) @ List.rev skips
@ pass
@
1075 (Some
(update_clt next
(a
,b
,c
,d
,e
,pragmas
,straft
,pos
)))
1077 | _
-> failwith
"nothing to attach pragma to"))
1079 (match plus_attachable false x
with
1080 SKIP
-> process_pragmas bef
(x
::skips
) xs
1081 | _
-> (add_bef bef
) @ List.rev skips
@ (process_pragmas (Some x
) [] xs
))
1083 (* ----------------------------------------------------------------------- *)
1084 (* Drop ... ... . This is only allowed in + code, and arises when there is
1085 some - code between the ... *)
1086 (* drop whens as well - they serve no purpose in + code and they cause
1087 problems for drop_double_dots *)
1089 let rec drop_when = function
1091 | (PC.TWhen
(clt
),info)::xs
->
1092 let rec loop = function
1094 | (PC.TLineEnd
(_
),info)::xs
-> drop_when xs
1095 | x
::xs
-> loop xs
in
1097 | x
::xs
-> x
::drop_when xs
1099 (* instead of dropping the double dots, we put TNothing in between them.
1100 these vanish after the parser, but keeping all the ...s in the + code makes
1101 it easier to align the + and - code in context_neg and in preparation for the
1102 isomorphisms. This shouldn't matter because the context code of the +
1103 slice is mostly ignored anyway *)
1104 let minus_to_nothing l
=
1105 (* for cases like | <..., which may or may not arise from removing minus
1106 code, depending on whether <... is a statement or expression *)
1109 let (d
,_
,_
,_
,_
,_
,_
,_
) = get_clt tok
in
1111 D.MINUS
| D.OPTMINUS
| D.UNIQUEMINUS
-> true
1112 | D.PLUS
| D.PLUSPLUS
-> false
1113 | D.CONTEXT
| D.UNIQUE
| D.OPT
-> false)
1115 let rec minus_loop = function
1117 | (d
::ds
) as l
-> if is_minus d
then minus_loop ds
else l
in
1118 let rec loop = function
1120 | ((PC.TMid0
(clt
),i) as x
)::t1
::ts
when is_minus t1
->
1121 (match minus_loop ts
with
1122 ((PC.TOEllipsis
(_
),_
)::_
) | ((PC.TPOEllipsis
(_
),_
)::_
)
1123 | ((PC.TEllipsis
(_
),_
)::_
) as l
-> x
::(PC.TNothing
,i)::(loop l
)
1125 | t
::ts
-> t
::(loop ts
) in
1128 let rec drop_double_dots l
=
1129 let start = function
1130 (PC.TOEllipsis
(_
),_
) | (PC.TPOEllipsis
(_
),_
)
1131 (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *) ->
1134 let middle = function
1135 (PC.TEllipsis
(_
),_
) (* | (PC.TCircles(_),_) | (PC.TStars(_),_) *) -> true
1137 let whenline = function
1138 (PC.TLineEnd
(_
),_
) -> true
1139 (*| (PC.TMid0(_),_) -> true*)
1141 let final = function
1142 (PC.TCEllipsis
(_
),_
) | (PC.TPCEllipsis
(_
),_
)
1143 (* | (PC.TCCircles(_),_) | (PC.TCStars(_),_) *) ->
1146 let any_before x
= start x
or middle x
or final x
or whenline x
in
1147 let any_after x
= start x
or middle x
or final x
in
1148 let rec loop ((_
,i) as prev
) = function
1150 | x
::rest
when any_before prev
&& any_after x
->
1151 (PC.TNothing
,i)::x
::(loop x rest
)
1152 | x
::rest
-> x
:: (loop x rest
) in
1155 | (x
::xs
) -> x
:: loop x xs
1159 if l
= cur then l
else fix f
cur
1161 (* ( | ... | ) also causes parsing problems *)
1165 let rec drop_empty_thing starter
middle ender
= function
1167 | hd
::rest
when starter hd
->
1168 let rec loop = function
1169 x
::rest
when middle x
-> loop rest
1170 | x
::rest
when ender x
-> rest
1171 | _
-> raise Not_empty
in
1172 (match try Some
(loop rest
) with Not_empty
-> None
with
1173 Some x
-> drop_empty_thing starter
middle ender x
1174 | None
-> hd
:: drop_empty_thing starter
middle ender rest
)
1175 | x
::rest
-> x
:: drop_empty_thing starter
middle ender rest
1179 (function (PC.TOPar0
(_
),_
) -> true | _
-> false)
1180 (function (PC.TMid0
(_
),_
) -> true | _
-> false)
1181 (function (PC.TCPar0
(_
),_
) -> true | _
-> false)
1183 let drop_empty_nest = drop_empty_thing
1185 (* ----------------------------------------------------------------------- *)
1188 let get_s_starts (_
, (s
,_
,(starts
, ends
))) =
1189 Printf.printf
"%d %d\n" starts ends
; (s
, starts
)
1192 let v = List.hd
!l
in
1197 PC.reinit (function _
-> PC.TArobArob
(* a handy token *))
1198 (Lexing.from_function
1199 (function buf
-> function n
-> raise
Common.Impossible
))
1201 let parse_one str parsefn file toks
=
1202 let all_tokens = ref toks
in
1203 let cur_tok = ref (List.hd
!all_tokens) in
1205 let lexer_function _
=
1206 let (v, info) = pop2 all_tokens in
1207 cur_tok := (v, info);
1211 Lexing.from_function
1212 (function buf
-> function n
-> raise
Common.Impossible
)
1217 try parsefn
lexer_function lexbuf_fake
1219 Lexer_cocci.Lexical s
->
1221 (Printf.sprintf
"%s: lexical error: %s\n =%s\n" str s
1222 (Common.error_message file
(get_s_starts !cur_tok) ))
1223 | Parser_cocci_menhir.Error
->
1225 (Printf.sprintf
"%s: parse error: \n = %s\n" str
1226 (Common.error_message file
(get_s_starts !cur_tok) ))
1227 | Semantic_cocci.Semantic s
->
1229 (Printf.sprintf
"%s: semantic error: %s\n =%s\n" str s
1230 (Common.error_message file
(get_s_starts !cur_tok) ))
1234 let prepare_tokens tokens
=
1236 (translate_when_true_false (* after insert_line_end *)
1239 (find_function_names (detect_attr (check_parentheses tokens
))))))
1241 let prepare_mv_tokens tokens
=
1242 detect_types false (detect_attr tokens
)
1244 let rec consume_minus_positions = function
1246 | ((PC.TOPar0
(_
),_
) as x
)::xs
| ((PC.TCPar0
(_
),_
) as x
)::xs
1247 | ((PC.TMid0
(_
),_
) as x
)::xs
-> x
::consume_minus_positions xs
1248 | x
::(PC.TPArob
,_
)::(PC.TMetaPos
(name
,constraints
,per
,clt
),_
)::xs
->
1249 let (arity
,ln
,lln
,offset
,col
,strbef
,straft
,_
) = get_clt x
in
1250 let name = Parse_aux.clt2mcode
name clt
in
1253 (arity
,ln
,lln
,offset
,col
,strbef
,straft
,
1254 Ast0.MetaPos
(name,constraints
,per
)) in
1255 x::(consume_minus_positions xs
)
1256 | x::xs
-> x::consume_minus_positions xs
1258 let any_modif rule
=
1260 match Ast0.get_mcode_mcodekind
x with
1261 Ast0.MINUS _
| Ast0.PLUS _
-> true
1263 let donothing r k e
= k e
in
1264 let bind x y
= x or y
in
1265 let option_default = false in
1267 V0.flat_combiner
bind option_default
1268 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1269 donothing donothing donothing donothing donothing donothing
1270 donothing donothing donothing donothing donothing donothing donothing
1271 donothing donothing in
1272 List.exists
fn.VT0.combiner_rec_top_level rule
1274 let eval_virt virt
=
1277 if not
(List.mem
x virt
)
1280 (Printf.sprintf
"unknown virtual rule %s\n" x))
1281 !Flag.defined_virtual_rules
1283 let drop_last extra l
= List.rev
(extra
@(List.tl
(List.rev l
)))
1285 let partition_either l
=
1286 let rec part_either left right
= function
1287 | [] -> (List.rev left
, List.rev right
)
1290 | Common.Left e
-> part_either (e
:: left
) right l
1291 | Common.Right e
-> part_either left
(e
:: right
) l
) in
1294 let get_metavars parse_fn table file lexbuf
=
1295 let rec meta_loop acc
(* read one decl at a time *) =
1299 tokens_all table file
true lexbuf
[PC.TArobArob
;PC.TMPtVirg
]) in
1300 let tokens = prepare_mv_tokens tokens in
1302 [(PC.TArobArob
,_
)] -> List.rev acc
1304 let metavars = parse_one "meta" parse_fn file
tokens in
1305 meta_loop (metavars@acc
) in
1306 partition_either (meta_loop [])
1308 let get_script_metavars parse_fn table file lexbuf
=
1309 let rec meta_loop acc
=
1311 tokens_all table file
true lexbuf
[PC.TArobArob
; PC.TMPtVirg
] in
1312 let tokens = prepare_tokens tokens in
1314 [(PC.TArobArob
, _
)] -> List.rev acc
1316 let metavar = parse_one "scriptmeta" parse_fn file
tokens in
1317 meta_loop (metavar :: acc
)
1321 let get_rule_name parse_fn starts_with_name get_tokens file prefix
=
1322 Data.in_rule_name
:= true;
1323 let mknm _
= make_name prefix
(!Lexer_cocci.line
) in
1327 let (_
,tokens) = get_tokens
[PC.TArob
] in
1328 let check_name = function
1329 None
-> Some
(mknm())
1331 (if List.mem nm
reserved_names
1332 then failwith
(Printf.sprintf
"invalid name %s\n" nm
));
1334 match parse_one "rule name" parse_fn file
tokens with
1335 Ast.CocciRulename
(nm
,a
,b
,c
,d
,e
) ->
1336 Ast.CocciRulename
(check_name nm
,a
,b
,c
,d
,e
)
1337 | Ast.GeneratedRulename
(nm
,a
,b
,c
,d
,e
) ->
1338 Ast.GeneratedRulename
(check_name nm
,a
,b
,c
,d
,e
)
1339 | Ast.ScriptRulename
(s
,deps
) -> Ast.ScriptRulename
(s
,deps
)
1340 | Ast.InitialScriptRulename
(s
,deps
) -> Ast.InitialScriptRulename
(s
,deps
)
1341 | Ast.FinalScriptRulename
(s
,deps
) -> Ast.FinalScriptRulename
(s
,deps
)
1343 Ast.CocciRulename
(Some
(mknm()),Ast.NoDep
,[],[],Ast.Undetermined
,false) in
1344 Data.in_rule_name
:= false;
1347 let parse_iso file
=
1348 let table = Common.full_charpos_to_pos file
in
1349 Common.with_open_infile file
(fun channel
->
1350 let lexbuf = Lexing.from_channel channel
in
1351 let get_tokens = tokens_all table file
false lexbuf in
1353 match get_tokens [PC.TArobArob
;PC.TArob
] with
1355 let parse_start start =
1356 let rev = List.rev start in
1357 let (arob
,_
) = List.hd
rev in
1358 (arob
= PC.TArob
,List.rev(List.tl
rev)) in
1359 let (starts_with_name
,start) = parse_start start in
1360 let rec loop starts_with_name
start =
1361 (!Data.init_rule
)();
1362 (* get metavariable declarations - have to be read before the
1364 let (rule_name
,_
,_
,_
,_
,_
) =
1365 match get_rule_name PC.iso_rule_name starts_with_name
get_tokens
1366 file
("iso file "^file
) with
1367 Ast.CocciRulename
(Some n
,a
,b
,c
,d
,e
) -> (n
,a
,b
,c
,d
,e
)
1368 | _
-> failwith
"Script rules cannot appear in isomorphism rules"
1370 Ast0.rule_name
:= rule_name
;
1372 match get_metavars PC.iso_meta_main
table file
lexbuf with
1373 (iso_metavars,[]) -> iso_metavars
1374 | _
-> failwith
"unexpected inheritance in iso" in
1378 [PC.TIsoStatement
;PC.TIsoExpression
;PC.TIsoArgExpression
;
1379 PC.TIsoTestExpression
; PC.TIsoToTestExpression
;
1380 PC.TIsoDeclaration
;PC.TIsoType
;PC.TIsoTopLevel
] in
1381 let next_start = List.hd
(List.rev tokens) in
1382 let dummy_info = ("",(-1,-1),(-1,-1)) in
1383 let tokens = drop_last [(PC.EOF
,dummy_info)] tokens in
1384 let tokens = prepare_tokens (start@tokens) in
1386 print_tokens "iso tokens" tokens;
1388 let entry = parse_one "iso main" PC.iso_main file
tokens in
1389 let entry = List.map
(List.map
Test_exps.process_anything
) entry in
1391 then (* The code below allows a header like Statement list,
1392 which is more than one word. We don't have that any more,
1393 but the code is left here in case it is put back. *)
1394 match get_tokens [PC.TArobArob
;PC.TArob
] with
1396 let (starts_with_name
,start) = parse_start start in
1397 (iso_metavars,entry,rule_name
) ::
1398 (loop starts_with_name
(next_start::start))
1399 | _
-> failwith
"isomorphism ends early"
1400 else [(iso_metavars,entry,rule_name
)] in
1401 loop starts_with_name
start
1402 | (false,_
) -> [] in
1405 let parse_iso_files existing_isos iso_files extra_path
=
1406 let get_names = List.map
(function (_
,_
,nm
) -> nm
) in
1407 let old_names = get_names existing_isos
in
1408 Data.in_iso
:= true;
1411 (function (prev
,names
) ->
1413 Lexer_cocci.init
();
1416 Common.Left
(fl
) -> Filename.concat extra_path fl
1417 | Common.Right
(fl
) -> Filename.concat
Config.path fl
in
1418 let current = parse_iso file in
1419 let new_names = get_names current in
1420 if List.exists
(function x -> List.mem
x names
) new_names
1421 then failwith
(Printf.sprintf
"repeated iso name found in %s" file);
1422 (current::prev
,new_names @ names
))
1423 ([],old_names) iso_files
in
1424 Data.in_iso
:= false;
1425 existing_isos
@(List.concat
(List.rev res))
1427 (* None = dependency not satisfied
1428 Some dep = dependency satisfied or unknown and dep has virts optimized
1430 let eval_depend dep virt
=
1433 Ast.Dep req
| Ast.EverDep req
->
1434 if List.mem req virt
1436 if List.mem req
!Flag.defined_virtual_rules
1440 | Ast.AntiDep antireq
| Ast.NeverDep antireq
->
1441 if List.mem antireq virt
1443 if not
(List.mem antireq
!Flag.defined_virtual_rules
)
1447 | Ast.AndDep
(d1
,d2
) ->
1448 (match (loop d1
, loop d2
) with
1449 (None
,_
) | (_
,None
) -> None
1450 | (Some
Ast.NoDep
,x) | (x,Some
Ast.NoDep
) -> x
1451 | (Some
x,Some y
) -> Some
(Ast.AndDep
(x,y
)))
1452 | Ast.OrDep
(d1
,d2
) ->
1453 (match (loop d1
, loop d2
) with
1455 | (Some
Ast.NoDep
,x) | (x,Some
Ast.NoDep
) -> Some
Ast.NoDep
1456 | (None
,x) | (x,None
) -> x
1457 | (Some
x,Some y
) -> Some
(Ast.OrDep
(x,y
)))
1458 | Ast.NoDep
| Ast.FailDep
-> Some dep
1464 let rec parse_loop file =
1465 let table = Common.full_charpos_to_pos
file in
1466 Common.with_open_infile
file (fun channel
->
1467 let lexbuf = Lexing.from_channel channel
in
1468 let get_tokens = tokens_all table file false lexbuf in
1469 Data.in_prolog
:= true;
1470 let initial_tokens = get_tokens [PC.TArobArob
;PC.TArob
] in
1471 Data.in_prolog
:= false;
1473 match initial_tokens with
1475 (match List.rev data
with
1476 ((PC.TArobArob
as x),_
)::_
| ((PC.TArob
as x),_
)::_
->
1477 let include_and_iso_files =
1478 parse_one "include and iso file names" PC.include_main
file data
in
1480 let (include_files
,iso_files
,virt
) =
1482 (function (include_files
,iso_files
,virt
) ->
1484 Data.Include s
-> (s
::include_files
,iso_files
,virt
)
1485 | Data.Iso s
-> (include_files
,s
::iso_files
,virt
)
1486 | Data.Virt l
-> (include_files
,iso_files
,l
@virt
))
1487 ([],[],[]) include_and_iso_files in
1489 List.iter
(function x -> Hashtbl.add
Lexer_cocci.rule_names
x ())
1492 let (extra_iso_files
, extra_rules
, extra_virt
) =
1493 let rec loop = function
1496 let (x,y
,z
) = loop rest
in
1498 loop (List.map
parse_loop include_files
) in
1500 let parse_cocci_rule ruletype old_metas
1501 (rule_name
, dependencies
, iso
, dropiso
, exists
, is_expression
) =
1502 Ast0.rule_name
:= rule_name
;
1503 Data.inheritable_positions
:=
1504 rule_name
:: !Data.inheritable_positions
;
1506 (* get metavariable declarations *)
1507 let (metavars, inherited_metavars
) =
1508 get_metavars PC.meta_main
table file lexbuf in
1509 Hashtbl.add
Data.all_metadecls rule_name
metavars;
1510 Hashtbl.add
Lexer_cocci.rule_names rule_name
();
1511 Hashtbl.add
Lexer_cocci.all_metavariables rule_name
1513 (fun key
v rest
-> (key
,v)::rest
)
1514 Lexer_cocci.metavariables
[]);
1516 (* get transformation rules *)
1517 let (more
, tokens) = get_tokens [PC.TArobArob
; PC.TArob
] in
1518 let (minus_tokens
, _
) = split_token_stream tokens in
1519 let (_
, plus_tokens
) =
1520 split_token_stream (minus_to_nothing tokens) in
1523 print_tokens "minus tokens" minus_tokens;
1524 print_tokens "plus tokens" plus_tokens;
1527 let minus_tokens = consume_minus_positions minus_tokens in
1528 let minus_tokens = prepare_tokens minus_tokens in
1529 let plus_tokens = prepare_tokens plus_tokens in
1532 print_tokens "minus tokens" minus_tokens;
1533 print_tokens "plus tokens" plus_tokens;
1537 process_pragmas None
[]
1538 (fix (function x -> drop_double_dots (drop_empty_or x))
1539 (drop_when plus_tokens)) in
1541 print_tokens "plus tokens" plus_tokens;
1542 Printf.printf "before minus parse\n";
1546 then parse_one "minus" PC.minus_exp_main
file minus_tokens
1547 else parse_one "minus" PC.minus_main
file minus_tokens in
1549 Unparse_ast0.unparse minus_res;
1550 Printf.printf "before plus parse\n";
1553 (* put ignore_patch_or_match with * case, which is less
1555 if !Flag.sgrep_mode2
or !D.ignore_patch_or_match
1556 then (* not actually used for anything, except context_neg *)
1558 (Iso_pattern.rebuild_mcode None
).VT0.rebuilder_rec_top_level
1562 then parse_one "plus" PC.plus_exp_main
file plus_tokens
1563 else parse_one "plus" PC.plus_main
file plus_tokens in
1565 Printf.printf "after plus parse\n";
1568 (if not
!Flag.sgrep_mode2
&&
1569 (any_modif minus_res or any_modif plus_res)
1570 then Data.inheritable_positions
:= []);
1572 Check_meta.check_meta rule_name old_metas inherited_metavars
1573 metavars minus_res plus_res;
1575 (more
, Ast0.CocciRule
((minus_res, metavars,
1576 (iso
, dropiso
, dependencies
, rule_name
, exists
)),
1577 (plus_res, metavars), ruletype
), metavars, tokens) in
1579 let rec collect_script_tokens = function
1580 [(PC.EOF
,_
)] | [(PC.TArobArob
,_
)] | [(PC.TArob
,_
)] -> ""
1581 | (PC.TScriptData
(s
),_
)::xs
-> s^
(collect_script_tokens xs
)
1585 Printf.printf
"%s\n" (token2c x))
1587 failwith
"Malformed script rule" in
1589 let parse_script_rule language old_metas deps
=
1590 let get_tokens = tokens_script_all table file false lexbuf in
1592 (* meta-variables *)
1596 get_script_metavars PC.script_meta_main
table file lexbuf) in
1598 let exists_in old_metas
(py
,(r
,m
)) =
1600 let test (rr
,mr
) x =
1601 let (ro
,vo
) = Ast.get_meta_name
x in
1602 ro
= rr
&& vo
= mr
in
1603 List.exists
(test (r
,m
)) old_metas
in
1607 let meta2c (r
,n
) = Printf.sprintf
"%s.%s" r n
in
1608 if not
(exists_in old_metas
x) then
1611 "Script references unknown meta-variable: %s"
1616 let (more
, tokens) = get_tokens [PC.TArobArob
; PC.TArob
] in
1617 let data = collect_script_tokens tokens in
1618 (more
,Ast0.ScriptRule
(language
, deps
, metavars, data),[],tokens) in
1620 let parse_if_script_rule k language _ deps
=
1621 let get_tokens = tokens_script_all table file false lexbuf in
1624 let (more
, tokens) = get_tokens [PC.TArobArob
; PC.TArob
] in
1625 let data = collect_script_tokens tokens in
1626 (more
,k
(language
, deps
, data),[],tokens) in
1628 let parse_iscript_rule =
1629 parse_if_script_rule
1630 (function (language
,deps
,data) ->
1631 Ast0.InitialScriptRule
(language
,deps
,data)) in
1633 let parse_fscript_rule =
1634 parse_if_script_rule
1635 (function (language
,deps
,data) ->
1636 Ast0.FinalScriptRule
(language
,deps
,data)) in
1638 let do_parse_script_rule fn l old_metas deps
=
1639 match eval_depend deps virt
with
1640 Some deps
-> fn l old_metas deps
1641 | None
-> fn l old_metas
Ast.FailDep
in
1643 let parse_rule old_metas starts_with_name
=
1645 get_rule_name PC.rule_name starts_with_name
get_tokens file
1648 Ast.CocciRulename
(Some s
, dep
, b
, c
, d
, e
) ->
1649 (match eval_depend dep virt
with
1651 parse_cocci_rule Ast.Normal old_metas
(s
,dep
,b
,c
,d
,e
)
1653 D.ignore_patch_or_match
:= true;
1655 parse_cocci_rule Ast.Normal old_metas
1656 (s
, Ast.FailDep
, b
, c
, d
, e
) in
1657 D.ignore_patch_or_match
:= false;
1659 | Ast.GeneratedRulename
(Some s
, dep
, b
, c
, d
, e
) ->
1660 (match eval_depend dep virt
with
1662 Data.in_generating
:= true;
1664 parse_cocci_rule Ast.Normal old_metas
(s
,dep
,b
,c
,d
,e
) in
1665 Data.in_generating
:= false;
1668 D.ignore_patch_or_match
:= true;
1669 Data.in_generating
:= true;
1671 parse_cocci_rule Ast.Normal old_metas
1672 (s
, Ast.FailDep
, b
, c
, d
, e
) in
1673 D.ignore_patch_or_match
:= false;
1674 Data.in_generating
:= false;
1676 | Ast.ScriptRulename
(l
,deps
) ->
1677 do_parse_script_rule parse_script_rule l old_metas deps
1678 | Ast.InitialScriptRulename
(l
,deps
) ->
1679 do_parse_script_rule parse_iscript_rule l old_metas deps
1680 | Ast.FinalScriptRulename
(l
,deps
) ->
1681 do_parse_script_rule parse_fscript_rule l old_metas deps
1682 | _
-> failwith
"Malformed rule name" in
1684 let rec loop old_metas starts_with_name
=
1685 (!Data.init_rule
)();
1687 let gen_starts_with_name more
tokens =
1689 (match List.hd
(List.rev tokens) with
1690 (PC.TArobArob
,_
) -> false
1691 | (PC.TArob
,_
) -> true
1692 | _
-> failwith
"unexpected token")
1695 let (more
, rule
, metavars, tokens) =
1696 parse_rule old_metas starts_with_name
in
1699 (loop (metavars @ old_metas
) (gen_starts_with_name more
tokens))
1703 (function prev
-> function cur -> Common.union_set
cur prev
)
1704 iso_files extra_iso_files
,
1705 (* included rules first *)
1706 List.fold_left
(function prev
-> function cur -> cur@prev
)
1707 (loop [] (x = PC.TArob
)) (List.rev extra_rules
),
1708 List.fold_left
(@) virt extra_virt
(*no dups allowed*))
1709 | _
-> failwith
"unexpected code before the first rule\n")
1710 | (false,[(PC.TArobArob
,_
)]) | (false,[(PC.TArob
,_
)]) ->
1711 ([],([] : Ast0.parsed_rule list
),[] (*virtual rules*))
1712 | _
-> failwith
"unexpected code before the first rule\n" in
1716 (* parse to ast0 and then convert to ast *)
1717 let process file isofile verbose
=
1718 let extra_path = Filename.dirname
file in
1719 let (iso_files
, rules
, virt
) = parse file in
1724 | Some iso_file
-> parse_iso_files [] [Common.Left iso_file
] "" in
1725 let global_isos = parse_iso_files std_isos iso_files
extra_path in
1726 let rules = Unitary_ast0.do_unitary
rules in
1730 Ast0.ScriptRule
(a
,b
,c
,d
) -> [([],Ast.ScriptRule
(a
,b
,c
,d
))]
1731 | Ast0.InitialScriptRule
(a
,b
,c
) -> [([],Ast.InitialScriptRule
(a
,b
,c
))]
1732 | Ast0.FinalScriptRule
(a
,b
,c
) -> [([],Ast.FinalScriptRule
(a
,b
,c
))]
1735 (iso
, dropiso
, dependencies
, rule_name
, exists
)),
1736 (plus
, metavars),ruletype
) ->
1738 parse_iso_files global_isos
1739 (List.map
(function x -> Common.Left
x) iso
)
1742 (* check that dropped isos are actually available *)
1745 List.map
(function (_
,_
,nm
) -> nm
) chosen_isos in
1746 let local_iso_names = reserved_names @ iso_names in
1749 (function dropped
->
1750 not
(List.mem dropped
local_iso_names))
1753 ("invalid iso name " ^
bad_dropped ^
" in " ^ rule_name
)
1754 with Not_found
-> ());
1755 if List.mem
"all" dropiso
1757 if List.length dropiso
= 1
1759 else failwith
"disable all should only be by itself"
1760 else (* drop those isos *)
1762 (function (_
,_
,nm
) -> not
(List.mem nm dropiso
))
1764 List.iter
Iso_compile.process chosen_isos;
1766 match reserved_names with
1771 List.filter
(function x -> List.mem
x dropiso
) others
)
1774 "bad list of reserved names - all must be at start" in
1775 let minus = Test_exps.process minus in
1776 let minus = Compute_lines.compute_lines
false minus in
1777 let plus = Compute_lines.compute_lines
false plus in
1779 (* only relevant to Flag.make_hrule *)
1780 (* doesn't handle multiple minirules properly, but since
1781 we don't really handle them in lots of other ways, it
1782 doesn't seem very important *)
1786 [match Ast0.unwrap p
with
1788 (match List.map
Ast0.unwrap
(Ast0.undots c
) with
1789 [Ast0.Exp e
] -> true | _
-> false)
1791 let minus = Arity.minus_arity
minus in
1792 let ((metavars,minus),function_prototypes
) =
1793 Function_prototypes.process
1794 rule_name
metavars dropped_isos minus plus ruletype
in
1795 let plus = Adjust_pragmas.process plus in
1796 (* warning! context_neg side-effects its arguments *)
1797 let (m
,p
) = List.split (Context_neg.context_neg
minus plus) in
1798 Type_infer.type_infer p
;
1799 (if not
!Flag.sgrep_mode2
1800 then Insert_plus.insert_plus m p
(chosen_isos = []));
1801 Type_infer.type_infer
minus;
1802 let (extra_meta
, minus) =
1803 match (chosen_isos,ruletype
) with
1804 (* separate case for [] because applying isos puts
1805 some restrictions on the -+ code *)
1806 ([],_
) | (_
,Ast.Generated
) -> ([],minus)
1807 | _
-> Iso_pattern.apply_isos
chosen_isos minus rule_name
in
1808 (* after iso, because iso can intro ... *)
1809 let minus = Adjacency.compute_adjacency
minus in
1810 let minus = Comm_assoc.comm_assoc
minus rule_name dropiso
in
1812 if !Flag.sgrep_mode2
then minus
1813 else Single_statement.single_statement
minus in
1814 let minus = Simple_assignments.simple_assignments
minus in
1816 Ast0toast.ast0toast rule_name dependencies
dropped_isos
1817 exists
minus is_exp ruletype
in
1819 match function_prototypes
with
1820 None
-> [(extra_meta
@ metavars, minus_ast)]
1821 | Some mv_fp
-> [(extra_meta
@ metavars, minus_ast); mv_fp
])
1822 (* Ast0.CocciRule ((minus, metavarsm, (iso, dropiso, dependencies, rule_name, exists)), (plus, metavars))*)
1824 let parsed = List.concat
parsed in
1825 let disjd = Disjdistr.disj
parsed in
1827 let (metavars,code
,fvs
,neg_pos
,ua
,pos
) = Free_vars.free_vars
disjd in
1828 if !Flag_parsing_cocci.show_SP
1829 then List.iter
Pretty_print_cocci.unparse code
;
1832 Common.profile_code
"get_constants" (* for grep *)
1833 (fun () -> Get_constants.get_constants code
) in
1834 let glimpse_tokens2 =
1835 Common.profile_code
"get_glimpse_constants" (* for glimpse *)
1836 (fun () -> Get_constants2.get_constants code neg_pos
) in
1838 (metavars,code
,fvs
,neg_pos
,ua
,pos
,grep_tokens,glimpse_tokens2)