2 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
3 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
4 * This file is part of Coccinelle.
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
-> ":-"
49 | D.CONTEXT
| D.UNIQUE
| D.OPT
-> ""
53 PC.TIdentifier
-> "identifier"
55 | PC.TParameter
-> "parameter"
56 | PC.TConstant
-> "constant"
57 | PC.TExpression
-> "expression"
58 | PC.TIdExpression
-> "idexpression"
59 | PC.TInitialiser
-> "initialiser"
60 | PC.TStatement
-> "statement"
61 | PC.TPosition
-> "position"
63 | PC.TFunction
-> "function"
64 | PC.TLocal
-> "local"
66 | PC.TFresh
-> "fresh"
68 | PC.TContext
-> "context"
69 | PC.TTypedef
-> "typedef"
70 | PC.TDeclarer
-> "declarer"
71 | PC.TIterator
-> "iterator"
73 | PC.TRuleName str
-> "rule_name-"^str
74 | PC.TUsing
-> "using"
75 | PC.TPathIsoFile str
-> "path_iso_file-"^str
76 | PC.TDisable
-> "disable"
77 | PC.TExtends
-> "extends"
78 | PC.TDepends
-> "depends"
81 | PC.TNever
-> "never"
82 | PC.TExists
-> "exists"
83 | PC.TForall
-> "forall"
84 | PC.TReverse
-> "reverse"
85 | PC.TError
-> "error"
86 | PC.TWords
-> "words"
87 | PC.TGenerated
-> "generated"
89 | PC.TNothing
-> "nothing"
91 | PC.Tchar
(clt
) -> "char"^
(line_type2c clt
)
92 | PC.Tshort
(clt
) -> "short"^
(line_type2c clt
)
93 | PC.Tint
(clt
) -> "int"^
(line_type2c clt
)
94 | PC.Tdouble
(clt
) -> "double"^
(line_type2c clt
)
95 | PC.Tfloat
(clt
) -> "float"^
(line_type2c clt
)
96 | PC.Tlong
(clt
) -> "long"^
(line_type2c clt
)
97 | PC.Tvoid
(clt
) -> "void"^
(line_type2c clt
)
98 | PC.Tstruct
(clt
) -> "struct"^
(line_type2c clt
)
99 | PC.Tunion
(clt
) -> "union"^
(line_type2c clt
)
100 | PC.Tenum
(clt
) -> "enum"^
(line_type2c clt
)
101 | PC.Tunsigned
(clt
) -> "unsigned"^
(line_type2c clt
)
102 | PC.Tsigned
(clt
) -> "signed"^
(line_type2c clt
)
103 | PC.Tstatic
(clt
) -> "static"^
(line_type2c clt
)
104 | PC.Tinline
(clt
) -> "inline"^
(line_type2c clt
)
105 | PC.Ttypedef
(clt
) -> "typedef"^
(line_type2c clt
)
106 | PC.Tattr
(s
,clt
) -> s^
(line_type2c clt
)
107 | PC.Tauto
(clt
) -> "auto"^
(line_type2c clt
)
108 | PC.Tregister
(clt
) -> "register"^
(line_type2c clt
)
109 | PC.Textern
(clt
) -> "extern"^
(line_type2c clt
)
110 | PC.Tconst
(clt
) -> "const"^
(line_type2c clt
)
111 | PC.Tvolatile
(clt
) -> "volatile"^
(line_type2c clt
)
113 | PC.TPragma
(s
,_
) -> s
114 | PC.TIncludeL
(s
,clt
) -> (pr "#include \"%s\"" s
)^
(line_type2c clt
)
115 | PC.TIncludeNL
(s
,clt
) -> (pr "#include <%s>" s
)^
(line_type2c clt
)
116 | PC.TDefine
(clt
,_
) -> "#define"^
(line_type2c clt
)
117 | PC.TDefineParam
(clt
,_
,_
,_
) -> "#define_param"^
(line_type2c clt
)
118 | PC.TMinusFile
(s
,clt
) -> (pr "--- %s" s
)^
(line_type2c clt
)
119 | PC.TPlusFile
(s
,clt
) -> (pr "+++ %s" s
)^
(line_type2c clt
)
121 | PC.TInc
(clt
) -> "++"^
(line_type2c clt
)
122 | PC.TDec
(clt
) -> "--"^
(line_type2c clt
)
124 | PC.TIf
(clt
) -> "if"^
(line_type2c clt
)
125 | PC.TElse
(clt
) -> "else"^
(line_type2c clt
)
126 | PC.TWhile
(clt
) -> "while"^
(line_type2c clt
)
127 | PC.TFor
(clt
) -> "for"^
(line_type2c clt
)
128 | PC.TDo
(clt
) -> "do"^
(line_type2c clt
)
129 | PC.TSwitch
(clt
) -> "switch"^
(line_type2c clt
)
130 | PC.TCase
(clt
) -> "case"^
(line_type2c clt
)
131 | PC.TDefault
(clt
) -> "default"^
(line_type2c clt
)
132 | PC.TReturn
(clt
) -> "return"^
(line_type2c clt
)
133 | PC.TBreak
(clt
) -> "break"^
(line_type2c clt
)
134 | PC.TContinue
(clt
) -> "continue"^
(line_type2c clt
)
135 | PC.TGoto
(clt
) -> "goto"^
(line_type2c clt
)
136 | PC.TIdent
(s
,clt
) -> (pr "ident-%s" s
)^
(line_type2c clt
)
137 | PC.TTypeId
(s
,clt
) -> (pr "typename-%s" s
)^
(line_type2c clt
)
138 | PC.TDeclarerId
(s
,clt
) -> (pr "declarername-%s" s
)^
(line_type2c clt
)
139 | PC.TIteratorId
(s
,clt
) -> (pr "iteratorname-%s" s
)^
(line_type2c clt
)
140 | PC.TMetaDeclarer
(_
,_
,_
,clt
) -> "declmeta"^
(line_type2c clt
)
141 | PC.TMetaIterator
(_
,_
,_
,clt
) -> "itermeta"^
(line_type2c clt
)
143 | PC.TSizeof
(clt
) -> "sizeof"^
(line_type2c clt
)
145 | PC.TString
(x
,clt
) -> x^
(line_type2c clt
)
146 | PC.TChar
(x
,clt
) -> x^
(line_type2c clt
)
147 | PC.TFloat
(x
,clt
) -> x^
(line_type2c clt
)
148 | PC.TInt
(x
,clt
) -> x^
(line_type2c clt
)
150 | PC.TOrLog
(clt
) -> "||"^
(line_type2c clt
)
151 | PC.TAndLog
(clt
) -> "&&"^
(line_type2c clt
)
152 | PC.TOr
(clt
) -> "|"^
(line_type2c clt
)
153 | PC.TXor
(clt
) -> "^"^
(line_type2c clt
)
154 | PC.TAnd
(clt
) -> "&"^
(line_type2c clt
)
155 | PC.TEqEq
(clt
) -> "=="^
(line_type2c clt
)
156 | PC.TNotEq
(clt
) -> "!="^
(line_type2c clt
)
157 | PC.TLogOp
(op
,clt
) ->
163 | _
-> failwith
"not possible")
165 | PC.TShOp
(op
,clt
) ->
168 | Ast.DecRight
-> ">>"
169 | _
-> failwith
"not possible")
171 | PC.TPlus
(clt
) -> "+"^
(line_type2c clt
)
172 | PC.TMinus
(clt
) -> "-"^
(line_type2c clt
)
173 | PC.TMul
(clt
) -> "*"^
(line_type2c clt
)
174 | PC.TDmOp
(op
,clt
) ->
178 | _
-> failwith
"not possible")
180 | PC.TTilde
(clt
) -> "~"^
(line_type2c clt
)
182 | PC.TMetaParam
(_
,_
,clt
) -> "parammeta"^
(line_type2c clt
)
183 | PC.TMetaParamList
(_
,_
,_
,clt
) -> "paramlistmeta"^
(line_type2c clt
)
184 | PC.TMetaConst
(_
,_
,_
,_
,clt
) -> "constmeta"^
(line_type2c clt
)
185 | PC.TMetaErr
(_
,_
,_
,clt
) -> "errmeta"^
(line_type2c clt
)
186 | PC.TMetaExp
(_
,_
,_
,_
,clt
) -> "expmeta"^
(line_type2c clt
)
187 | PC.TMetaIdExp
(_
,_
,_
,_
,clt
) -> "idexpmeta"^
(line_type2c clt
)
188 | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
) -> "localidexpmeta"^
(line_type2c clt
)
189 | PC.TMetaExpList
(_
,_
,_
,clt
) -> "explistmeta"^
(line_type2c clt
)
190 | PC.TMetaId
(_
,_
,_
,clt
) -> "idmeta"^
(line_type2c clt
)
191 | PC.TMetaType
(_
,_
,clt
) -> "typemeta"^
(line_type2c clt
)
192 | PC.TMetaInit
(_
,_
,clt
) -> "initmeta"^
(line_type2c clt
)
193 | PC.TMetaStm
(_
,_
,clt
) -> "stmmeta"^
(line_type2c clt
)
194 | PC.TMetaStmList
(_
,_
,clt
) -> "stmlistmeta"^
(line_type2c clt
)
195 | PC.TMetaFunc
(_
,_
,_
,clt
) -> "funcmeta"^
(line_type2c clt
)
196 | PC.TMetaLocalFunc
(_
,_
,_
,clt
) -> "funcmeta"^
(line_type2c clt
)
197 | PC.TMetaPos
(_
,_
,_
,clt
) -> "posmeta"
199 | PC.TArobArob
-> "@@"
202 | PC.TScript
-> "script"
203 | PC.TInitialize
-> "initialize"
204 | PC.TFinalize
-> "finalize"
206 | PC.TWhen
(clt
) -> "WHEN"^
(line_type2c clt
)
207 | PC.TWhenTrue
(clt
) -> "WHEN TRUE"^
(line_type2c clt
)
208 | PC.TWhenFalse
(clt
) -> "WHEN FALSE"^
(line_type2c clt
)
209 | PC.TAny
(clt
) -> "ANY"^
(line_type2c clt
)
210 | PC.TStrict
(clt
) -> "STRICT"^
(line_type2c clt
)
211 | PC.TEllipsis
(clt
) -> "..."^
(line_type2c clt
)
213 | PC.TCircles(clt) -> "ooo"^(line_type2c clt)
214 | PC.TStars(clt) -> "***"^(line_type2c clt)
217 | PC.TOEllipsis
(clt
) -> "<..."^
(line_type2c clt
)
218 | PC.TCEllipsis
(clt
) -> "...>"^
(line_type2c clt
)
219 | PC.TPOEllipsis
(clt
) -> "<+..."^
(line_type2c clt
)
220 | PC.TPCEllipsis
(clt
) -> "...+>"^
(line_type2c clt
)
222 | PC.TOCircles(clt) -> "<ooo"^(line_type2c clt)
223 | PC.TCCircles(clt) -> "ooo>"^(line_type2c clt)
224 | PC.TOStars(clt) -> "<***"^(line_type2c clt)
225 | PC.TCStars(clt) -> "***>"^(line_type2c clt)
231 | PC.TWhy
(clt
) -> "?"^
(line_type2c clt
)
232 | PC.TDotDot
(clt
) -> ":"^
(line_type2c clt
)
233 | PC.TBang
(clt
) -> "!"^
(line_type2c clt
)
234 | PC.TOPar
(clt
) -> "("^
(line_type2c clt
)
235 | PC.TOPar0
(clt
) -> "("^
(line_type2c clt
)
236 | PC.TMid0
(clt
) -> "|"^
(line_type2c clt
)
237 | PC.TCPar
(clt
) -> ")"^
(line_type2c clt
)
238 | PC.TCPar0
(clt
) -> ")"^
(line_type2c clt
)
240 | PC.TOBrace
(clt
) -> "{"^
(line_type2c clt
)
241 | PC.TCBrace
(clt
) -> "}"^
(line_type2c clt
)
242 | PC.TOCro
(clt
) -> "["^
(line_type2c clt
)
243 | PC.TCCro
(clt
) -> "]"^
(line_type2c clt
)
244 | PC.TOInit
(clt
) -> "{"^
(line_type2c clt
)
246 | PC.TPtrOp
(clt
) -> "->"^
(line_type2c clt
)
248 | PC.TEq
(clt
) -> "="^
(line_type2c clt
)
249 | PC.TAssign
(_
,clt
) -> "=op"^
(line_type2c clt
)
250 | PC.TDot
(clt
) -> "."^
(line_type2c clt
)
251 | PC.TComma
(clt
) -> ","^
(line_type2c clt
)
252 | PC.TPtVirg
(clt
) -> ";"^
(line_type2c clt
)
255 | PC.TLineEnd
(clt
) -> "line end"
256 | PC.TInvalid
-> "invalid"
257 | PC.TFunDecl
(clt
) -> "fundecl"
260 | PC.TRightIso
-> "=>"
261 | PC.TIsoTopLevel
-> "TopLevel"
262 | PC.TIsoExpression
-> "Expression"
263 | PC.TIsoArgExpression
-> "ArgExpression"
264 | PC.TIsoTestExpression
-> "TestExpression"
265 | PC.TIsoStatement
-> "Statement"
266 | PC.TIsoDeclaration
-> "Declaration"
267 | PC.TIsoType
-> "Type"
268 | PC.TScriptData s
-> s
270 let print_tokens s tokens
=
271 Printf.printf
"%s\n" s
;
272 List.iter
(function x
-> Printf.printf
"%s " (token2c x
)) tokens
;
273 Printf.printf
"\n\n";
276 type plus
= PLUS
| NOTPLUS
| SKIP
278 let plus_attachable only_plus
(tok
,_
) =
280 PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
281 | PC.Tfloat
(clt
) | PC.Tlong
(clt
) | PC.Tvoid
(clt
) | PC.Tstruct
(clt
)
282 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
284 | PC.Tinline
(clt
) | PC.Ttypedef
(clt
) | PC.Tattr
(_
,clt
)
285 | PC.Tauto
(clt
) | PC.Tregister
(clt
)
286 | PC.Textern
(clt
) | PC.Tconst
(clt
) | PC.Tvolatile
(clt
)
288 | PC.TIncludeL
(_
,clt
) | PC.TIncludeNL
(_
,clt
) | PC.TDefine
(clt
,_
)
289 | PC.TDefineParam
(clt
,_
,_
,_
) | PC.TMinusFile
(_
,clt
) | PC.TPlusFile
(_
,clt
)
291 | PC.TInc
(clt
) | PC.TDec
(clt
)
293 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
294 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
) | PC.TReturn
(clt
)
295 | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
) | PC.TIdent
(_
,clt
)
296 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
300 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
)
302 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
303 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TLogOp
(_
,clt
)
304 | PC.TShOp
(_
,clt
) | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
305 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
)
307 | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
308 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaErr
(_
,_
,_
,clt
)
309 | PC.TMetaExp
(_
,_
,_
,_
,clt
) | PC.TMetaIdExp
(_
,_
,_
,_
,clt
)
310 | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
311 | PC.TMetaExpList
(_
,_
,_
,clt
)
312 | PC.TMetaId
(_
,_
,_
,clt
)
313 | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
) | PC.TMetaStm
(_
,_
,clt
)
314 | PC.TMetaStmList
(_
,_
,clt
) | PC.TMetaFunc
(_
,_
,_
,clt
)
315 | PC.TMetaLocalFunc
(_
,_
,_
,clt
)
317 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
)
318 | PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TEllipsis
(clt
)
319 (* | PC.TCircles(clt) | PC.TStars(clt) *)
321 | PC.TWhy
(clt
) | PC.TDotDot
(clt
) | PC.TBang
(clt
) | PC.TOPar
(clt
)
324 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOCro
(clt
) | PC.TCCro
(clt
)
329 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
331 if line_type clt
= D.PLUS
333 else if only_plus
then NOTPLUS
334 else if line_type clt
= D.CONTEXT
then PLUS
else NOTPLUS
336 | PC.TOPar0
(clt
) | PC.TMid0
(clt
) | PC.TCPar0
(clt
)
337 | PC.TOEllipsis
(clt
) | PC.TCEllipsis
(clt
)
338 | PC.TPOEllipsis
(clt
) | PC.TPCEllipsis
(clt
) (* | PC.TOCircles(clt)
339 | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *) -> NOTPLUS
340 | PC.TMetaPos
(nm
,_
,_
,_
) -> NOTPLUS
344 let get_clt (tok
,_
) =
346 PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
347 | PC.Tfloat
(clt
) | PC.Tlong
(clt
) | PC.Tvoid
(clt
) | PC.Tstruct
(clt
)
348 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
350 | PC.Tinline
(clt
) | PC.Tattr
(_
,clt
) | PC.Tauto
(clt
) | PC.Tregister
(clt
)
351 | PC.Textern
(clt
) | PC.Tconst
(clt
) | PC.Tvolatile
(clt
)
353 | PC.TIncludeL
(_
,clt
) | PC.TIncludeNL
(_
,clt
) | PC.TDefine
(clt
,_
)
354 | PC.TDefineParam
(clt
,_
,_
,_
) | PC.TMinusFile
(_
,clt
) | PC.TPlusFile
(_
,clt
)
356 | PC.TInc
(clt
) | PC.TDec
(clt
)
358 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
359 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
) | PC.TReturn
(clt
)
360 | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
) | PC.TIdent
(_
,clt
)
361 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
365 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
)
367 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
368 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TLogOp
(_
,clt
)
369 | PC.TShOp
(_
,clt
) | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
370 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
)
372 | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
373 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaErr
(_
,_
,_
,clt
)
374 | PC.TMetaExp
(_
,_
,_
,_
,clt
) | PC.TMetaIdExp
(_
,_
,_
,_
,clt
)
375 | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
376 | PC.TMetaExpList
(_
,_
,_
,clt
)
377 | PC.TMetaId
(_
,_
,_
,clt
)
378 | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
) | PC.TMetaStm
(_
,_
,clt
)
379 | PC.TMetaStmList
(_
,_
,clt
) | PC.TMetaFunc
(_
,_
,_
,clt
)
380 | PC.TMetaLocalFunc
(_
,_
,_
,clt
) | PC.TMetaPos
(_
,_
,_
,clt
)
382 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
) |
383 PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TEllipsis
(clt
)
384 (* | PC.TCircles(clt) | PC.TStars(clt) *)
386 | PC.TWhy
(clt
) | PC.TDotDot
(clt
) | PC.TBang
(clt
) | PC.TOPar
(clt
)
389 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOCro
(clt
) | PC.TCCro
(clt
)
394 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
397 | PC.TOPar0
(clt
) | PC.TMid0
(clt
) | PC.TCPar0
(clt
)
398 | PC.TOEllipsis
(clt
) | PC.TCEllipsis
(clt
)
399 | PC.TPOEllipsis
(clt
) | PC.TPCEllipsis
(clt
) (* | PC.TOCircles(clt)
400 | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *) -> clt
402 | _
-> failwith
"no clt"
404 let update_clt (tok
,x
) clt
=
406 PC.Tchar
(_
) -> (PC.Tchar
(clt
),x
)
407 | PC.Tshort
(_
) -> (PC.Tshort
(clt
),x
)
408 | PC.Tint
(_
) -> (PC.Tint
(clt
),x
)
409 | PC.Tdouble
(_
) -> (PC.Tdouble
(clt
),x
)
410 | PC.Tfloat
(_
) -> (PC.Tfloat
(clt
),x
)
411 | PC.Tlong
(_
) -> (PC.Tlong
(clt
),x
)
412 | PC.Tvoid
(_
) -> (PC.Tvoid
(clt
),x
)
413 | PC.Tstruct
(_
) -> (PC.Tstruct
(clt
),x
)
414 | PC.Tunion
(_
) -> (PC.Tunion
(clt
),x
)
415 | PC.Tenum
(_
) -> (PC.Tenum
(clt
),x
)
416 | PC.Tunsigned
(_
) -> (PC.Tunsigned
(clt
),x
)
417 | PC.Tsigned
(_
) -> (PC.Tsigned
(clt
),x
)
418 | PC.Tstatic
(_
) -> (PC.Tstatic
(clt
),x
)
419 | PC.Tinline
(_
) -> (PC.Tinline
(clt
),x
)
420 | PC.Ttypedef
(_
) -> (PC.Ttypedef
(clt
),x
)
421 | PC.Tattr
(s
,_
) -> (PC.Tattr
(s
,clt
),x
)
422 | PC.Tauto
(_
) -> (PC.Tauto
(clt
),x
)
423 | PC.Tregister
(_
) -> (PC.Tregister
(clt
),x
)
424 | PC.Textern
(_
) -> (PC.Textern
(clt
),x
)
425 | PC.Tconst
(_
) -> (PC.Tconst
(clt
),x
)
426 | PC.Tvolatile
(_
) -> (PC.Tvolatile
(clt
),x
)
428 | PC.TIncludeL
(s
,_
) -> (PC.TIncludeL
(s
,clt
),x
)
429 | PC.TIncludeNL
(s
,_
) -> (PC.TIncludeNL
(s
,clt
),x
)
430 | PC.TDefine
(_
,a
) -> (PC.TDefine
(clt
,a
),x
)
431 | PC.TDefineParam
(_
,a
,b
,c
) -> (PC.TDefineParam
(clt
,a
,b
,c
),x
)
432 | PC.TMinusFile
(s
,_
) -> (PC.TMinusFile
(s
,clt
),x
)
433 | PC.TPlusFile
(s
,_
) -> (PC.TPlusFile
(s
,clt
),x
)
435 | PC.TInc
(_
) -> (PC.TInc
(clt
),x
)
436 | PC.TDec
(_
) -> (PC.TDec
(clt
),x
)
438 | PC.TIf
(_
) -> (PC.TIf
(clt
),x
)
439 | PC.TElse
(_
) -> (PC.TElse
(clt
),x
)
440 | PC.TWhile
(_
) -> (PC.TWhile
(clt
),x
)
441 | PC.TFor
(_
) -> (PC.TFor
(clt
),x
)
442 | PC.TDo
(_
) -> (PC.TDo
(clt
),x
)
443 | PC.TSwitch
(_
) -> (PC.TSwitch
(clt
),x
)
444 | PC.TCase
(_
) -> (PC.TCase
(clt
),x
)
445 | PC.TDefault
(_
) -> (PC.TDefault
(clt
),x
)
446 | PC.TReturn
(_
) -> (PC.TReturn
(clt
),x
)
447 | PC.TBreak
(_
) -> (PC.TBreak
(clt
),x
)
448 | PC.TContinue
(_
) -> (PC.TContinue
(clt
),x
)
449 | PC.TGoto
(_
) -> (PC.TGoto
(clt
),x
)
450 | PC.TIdent
(s
,_
) -> (PC.TIdent
(s
,clt
),x
)
451 | PC.TTypeId
(s
,_
) -> (PC.TTypeId
(s
,clt
),x
)
452 | PC.TDeclarerId
(s
,_
) -> (PC.TDeclarerId
(s
,clt
),x
)
453 | PC.TIteratorId
(s
,_
) -> (PC.TIteratorId
(s
,clt
),x
)
455 | PC.TSizeof
(_
) -> (PC.TSizeof
(clt
),x
)
457 | PC.TString
(s
,_
) -> (PC.TString
(s
,clt
),x
)
458 | PC.TChar
(s
,_
) -> (PC.TChar
(s
,clt
),x
)
459 | PC.TFloat
(s
,_
) -> (PC.TFloat
(s
,clt
),x
)
460 | PC.TInt
(s
,_
) -> (PC.TInt
(s
,clt
),x
)
462 | PC.TOrLog
(_
) -> (PC.TOrLog
(clt
),x
)
463 | PC.TAndLog
(_
) -> (PC.TAndLog
(clt
),x
)
464 | PC.TOr
(_
) -> (PC.TOr
(clt
),x
)
465 | PC.TXor
(_
) -> (PC.TXor
(clt
),x
)
466 | PC.TAnd
(_
) -> (PC.TAnd
(clt
),x
)
467 | PC.TEqEq
(_
) -> (PC.TEqEq
(clt
),x
)
468 | PC.TNotEq
(_
) -> (PC.TNotEq
(clt
),x
)
469 | PC.TLogOp
(op
,_
) -> (PC.TLogOp
(op
,clt
),x
)
470 | PC.TShOp
(op
,_
) -> (PC.TShOp
(op
,clt
),x
)
471 | PC.TPlus
(_
) -> (PC.TPlus
(clt
),x
)
472 | PC.TMinus
(_
) -> (PC.TMinus
(clt
),x
)
473 | PC.TMul
(_
) -> (PC.TMul
(clt
),x
)
474 | PC.TDmOp
(op
,_
) -> (PC.TDmOp
(op
,clt
),x
)
475 | PC.TTilde
(_
) -> (PC.TTilde
(clt
),x
)
477 | PC.TMetaParam
(a
,b
,_
) -> (PC.TMetaParam
(a
,b
,clt
),x
)
478 | PC.TMetaParamList
(a
,b
,c
,_
) -> (PC.TMetaParamList
(a
,b
,c
,clt
),x
)
479 | PC.TMetaConst
(a
,b
,c
,d
,_
) -> (PC.TMetaConst
(a
,b
,c
,d
,clt
),x
)
480 | PC.TMetaErr
(a
,b
,c
,_
) -> (PC.TMetaErr
(a
,b
,c
,clt
),x
)
481 | PC.TMetaExp
(a
,b
,c
,d
,_
) -> (PC.TMetaExp
(a
,b
,c
,d
,clt
),x
)
482 | PC.TMetaIdExp
(a
,b
,c
,d
,_
) -> (PC.TMetaIdExp
(a
,b
,c
,d
,clt
),x
)
483 | PC.TMetaLocalIdExp
(a
,b
,c
,d
,_
) -> (PC.TMetaLocalIdExp
(a
,b
,c
,d
,clt
),x
)
484 | PC.TMetaExpList
(a
,b
,c
,_
) -> (PC.TMetaExpList
(a
,b
,c
,clt
),x
)
485 | PC.TMetaId
(a
,b
,c
,_
) -> (PC.TMetaId
(a
,b
,c
,clt
),x
)
486 | PC.TMetaType
(a
,b
,_
) -> (PC.TMetaType
(a
,b
,clt
),x
)
487 | PC.TMetaInit
(a
,b
,_
) -> (PC.TMetaInit
(a
,b
,clt
),x
)
488 | PC.TMetaStm
(a
,b
,_
) -> (PC.TMetaStm
(a
,b
,clt
),x
)
489 | PC.TMetaStmList
(a
,b
,_
) -> (PC.TMetaStmList
(a
,b
,clt
),x
)
490 | PC.TMetaFunc
(a
,b
,c
,_
) -> (PC.TMetaFunc
(a
,b
,c
,clt
),x
)
491 | PC.TMetaLocalFunc
(a
,b
,c
,_
) -> (PC.TMetaLocalFunc
(a
,b
,c
,clt
),x
)
493 | PC.TWhen
(_
) -> (PC.TWhen
(clt
),x
)
494 | PC.TWhenTrue
(_
) -> (PC.TWhenTrue
(clt
),x
)
495 | PC.TWhenFalse
(_
) -> (PC.TWhenFalse
(clt
),x
)
496 | PC.TAny
(_
) -> (PC.TAny
(clt
),x
)
497 | PC.TStrict
(_
) -> (PC.TStrict
(clt
),x
)
498 | PC.TEllipsis
(_
) -> (PC.TEllipsis
(clt
),x
)
500 | PC.TCircles(_) -> (PC.TCircles(clt),x)
501 | PC.TStars(_) -> (PC.TStars(clt),x)
504 | PC.TOEllipsis
(_
) -> (PC.TOEllipsis
(clt
),x
)
505 | PC.TCEllipsis
(_
) -> (PC.TCEllipsis
(clt
),x
)
506 | PC.TPOEllipsis
(_
) -> (PC.TPOEllipsis
(clt
),x
)
507 | PC.TPCEllipsis
(_
) -> (PC.TPCEllipsis
(clt
),x
)
509 | PC.TOCircles(_) -> (PC.TOCircles(clt),x)
510 | PC.TCCircles(_) -> (PC.TCCircles(clt),x)
511 | PC.TOStars(_) -> (PC.TOStars(clt),x)
512 | PC.TCStars(_) -> (PC.TCStars(clt),x)
515 | PC.TWhy
(_
) -> (PC.TWhy
(clt
),x
)
516 | PC.TDotDot
(_
) -> (PC.TDotDot
(clt
),x
)
517 | PC.TBang
(_
) -> (PC.TBang
(clt
),x
)
518 | PC.TOPar
(_
) -> (PC.TOPar
(clt
),x
)
519 | PC.TOPar0
(_
) -> (PC.TOPar0
(clt
),x
)
520 | PC.TMid0
(_
) -> (PC.TMid0
(clt
),x
)
521 | PC.TCPar
(_
) -> (PC.TCPar
(clt
),x
)
522 | PC.TCPar0
(_
) -> (PC.TCPar0
(clt
),x
)
524 | PC.TOBrace
(_
) -> (PC.TOBrace
(clt
),x
)
525 | PC.TCBrace
(_
) -> (PC.TCBrace
(clt
),x
)
526 | PC.TOCro
(_
) -> (PC.TOCro
(clt
),x
)
527 | PC.TCCro
(_
) -> (PC.TCCro
(clt
),x
)
528 | PC.TOInit
(_
) -> (PC.TOInit
(clt
),x
)
530 | PC.TPtrOp
(_
) -> (PC.TPtrOp
(clt
),x
)
532 | PC.TEq
(_
) -> (PC.TEq
(clt
),x
)
533 | PC.TAssign
(s
,_
) -> (PC.TAssign
(s
,clt
),x
)
534 | PC.TDot
(_
) -> (PC.TDot
(clt
),x
)
535 | PC.TComma
(_
) -> (PC.TComma
(clt
),x
)
536 | PC.TPtVirg
(_
) -> (PC.TPtVirg
(clt
),x
)
538 | PC.TLineEnd
(_
) -> (PC.TLineEnd
(clt
),x
)
539 | PC.TFunDecl
(_
) -> (PC.TFunDecl
(clt
),x
)
541 | _
-> failwith
"no clt"
544 (* ----------------------------------------------------------------------- *)
546 let make_name prefix ln
= Printf.sprintf
"%s starting on line %d" prefix ln
548 (* ----------------------------------------------------------------------- *)
551 let wrap_lexbuf_info lexbuf
=
552 (Lexing.lexeme lexbuf
, Lexing.lexeme_start lexbuf
)
554 let tokens_all_full token table file get_ats lexbuf end_markers
:
555 (bool * ((PC.token
* (string * (int * int) * (int * int))) list
)) =
558 let result = token lexbuf
in
559 let info = (Lexing.lexeme lexbuf
,
560 (table
.(Lexing.lexeme_start lexbuf
)),
561 (Lexing.lexeme_start lexbuf
, Lexing.lexeme_end lexbuf
)) in
565 then failwith
"unexpected end of file in a metavariable declaration"
566 else (false,[(result,info)])
567 else if List.mem
result end_markers
568 then (true,[(result,info)])
570 let (more
,rest
) = aux() in
571 (more
,(result, info)::rest
)
574 e
-> pr2 (Common.error_message file
(wrap_lexbuf_info lexbuf
) ); raise e
576 let tokens_all table file get_ats lexbuf end_markers
:
577 (bool * ((PC.token
* (string * (int * int) * (int * int))) list
)) =
578 tokens_all_full Lexer_cocci.token table file get_ats lexbuf end_markers
580 let tokens_script_all table file get_ats lexbuf end_markers
:
581 (bool * ((PC.token
* (string * (int * int) * (int * int))) list
)) =
582 tokens_all_full Lexer_script.token table file get_ats lexbuf end_markers
584 (* ----------------------------------------------------------------------- *)
585 (* Split tokens into minus and plus fragments *)
588 let (d
,_
,_
,_
,_
,_
,_
,_
) = clt
in
590 D.MINUS
| D.OPTMINUS
| D.UNIQUEMINUS
-> ([t
],[])
592 | D.CONTEXT
| D.UNIQUE
| D.OPT
-> ([t
],[t
])
594 let split_token ((tok
,_
) as t
) =
596 PC.TIdentifier
| PC.TConstant
| PC.TExpression
| PC.TIdExpression
597 | PC.TStatement
| PC.TPosition
| PC.TPosAny
| PC.TInitialiser
598 | PC.TFunction
| PC.TTypedef
| PC.TDeclarer
| PC.TIterator
| PC.TName
599 | PC.TType
| PC.TParameter
| PC.TLocal
| PC.Tlist
| PC.TFresh
| PC.TPure
600 | PC.TContext
| PC.TRuleName
(_
) | PC.TUsing
| PC.TDisable
| PC.TExtends
602 | PC.TDepends
| PC.TOn
| PC.TEver
| PC.TNever
| PC.TExists
| PC.TForall
604 | PC.TError
| PC.TWords
| PC.TGenerated
| PC.TNothing
-> ([t
],[t
])
606 | PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
607 | PC.Tfloat
(clt
) | PC.Tlong
(clt
) | PC.Tvoid
(clt
) | PC.Tstruct
(clt
)
608 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
609 | PC.Tstatic
(clt
) | PC.Tauto
(clt
) | PC.Tregister
(clt
) | PC.Textern
(clt
)
610 | PC.Tinline
(clt
) | PC.Ttypedef
(clt
) | PC.Tattr
(_
,clt
)
611 | PC.Tconst
(clt
) | PC.Tvolatile
(clt
) -> split t clt
613 | PC.TPragma
(s
,_
) -> ([],[t
]) (* only allowed in + *)
614 | PC.TPlusFile
(s
,clt
) | PC.TMinusFile
(s
,clt
)
615 | PC.TIncludeL
(s
,clt
) | PC.TIncludeNL
(s
,clt
) ->
617 | PC.TDefine
(clt
,_
) | PC.TDefineParam
(clt
,_
,_
,_
) -> split t clt
619 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
620 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
)
622 | PC.TReturn
(clt
) | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
)
624 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
625 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaExp
(_
,_
,_
,_
,clt
)
626 | PC.TMetaIdExp
(_
,_
,_
,_
,clt
) | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
627 | PC.TMetaExpList
(_
,_
,_
,clt
)
628 | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
629 | PC.TMetaId
(_
,_
,_
,clt
) | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
)
630 | PC.TMetaStm
(_
,_
,clt
) | PC.TMetaStmList
(_
,_
,clt
) | PC.TMetaErr
(_
,_
,_
,clt
)
631 | PC.TMetaFunc
(_
,_
,_
,clt
) | PC.TMetaLocalFunc
(_
,_
,_
,clt
)
632 | PC.TMetaDeclarer
(_
,_
,_
,clt
) | PC.TMetaIterator
(_
,_
,_
,clt
) -> split t clt
633 | PC.TMPtVirg
| PC.TArob
| PC.TArobArob
| PC.TScript
634 | PC.TInitialize
| PC.TFinalize
-> ([t
],[t
])
635 | PC.TPArob
| PC.TMetaPos
(_
,_
,_
,_
) -> ([t
],[])
638 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
)
639 | PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TLineEnd
(clt
)
640 | PC.TEllipsis
(clt
) (* | PC.TCircles(clt) | PC.TStars(clt) *) -> split t clt
642 | PC.TOEllipsis
(_
) | PC.TCEllipsis
(_
) (* clt must be context *)
643 | PC.TPOEllipsis
(_
) | PC.TPCEllipsis
(_
) (* clt must be context *)
645 | PC.TOCircles(_) | PC.TCCircles(_) (* clt must be context *)
646 | PC.TOStars
(_
) | PC.TCStars
(_
) (* clt must be context *)
648 | PC.TBang0
| PC.TPlus0
| PC.TWhy0
->
651 | PC.TWhy
(clt
) | PC.TDotDot
(clt
)
652 | PC.TBang
(clt
) | PC.TOPar
(clt
) | PC.TOPar0
(clt
)
653 | PC.TMid0
(clt
) | PC.TCPar
(clt
) | PC.TCPar0
(clt
) -> split t clt
655 | PC.TInc
(clt
) | PC.TDec
(clt
) -> split t clt
657 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
) ->
660 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
661 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TLogOp
(_
,clt
)
662 | PC.TShOp
(_
,clt
) | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
663 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
) -> split t clt
665 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOInit
(clt
) -> split t clt
666 | PC.TOCro
(clt
) | PC.TCCro
(clt
) -> split t clt
668 | PC.TPtrOp
(clt
) -> split t clt
670 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
671 | PC.TPtVirg
(clt
) -> split t clt
673 | PC.EOF
| PC.TInvalid
-> ([t
],[t
])
675 | PC.TIso
| PC.TRightIso
676 | PC.TIsoExpression
| PC.TIsoStatement
| PC.TIsoDeclaration
| PC.TIsoType
677 | PC.TIsoTopLevel
| PC.TIsoArgExpression
| PC.TIsoTestExpression
->
678 failwith
"unexpected tokens"
679 | PC.TScriptData s
-> ([t
],[t
])
681 let split_token_stream tokens
=
682 let rec loop = function
685 let (minus
,plus
) = split_token token
in
686 let (minus_stream
,plus_stream
) = loop tokens
in
687 (minus
@minus_stream
,plus
@plus_stream
) in
690 (* ----------------------------------------------------------------------- *)
691 (* Find function names *)
692 (* This addresses a shift-reduce problem in the parser, allowing us to
693 distinguish a function declaration from a function call even if the latter
694 has no return type. Undoubtedly, this is not very nice, but it doesn't
695 seem very convenient to refactor the grammar to get around the problem. *)
697 let rec find_function_names = function
699 | ((PC.TIdent
(_
,clt
),info) as t1
) :: ((PC.TOPar
(_
),_
) as t2
) :: rest
700 | ((PC.TMetaId
(_
,_
,_
,clt
),info) as t1
) :: ((PC.TOPar
(_
),_
) as t2
) :: rest
701 | ((PC.TMetaFunc
(_
,_
,_
,clt
),info) as t1
) :: ((PC.TOPar
(_
),_
) as t2
) :: rest
702 | ((PC.TMetaLocalFunc
(_
,_
,_
,clt
),info) as t1
)::((PC.TOPar
(_
),_
) as t2
)::rest
704 let rec skip level
= function
706 | ((PC.TCPar
(_
),_
) as t
)::rest
->
707 let level = level - 1 in
710 else let (pre
,found
,post
) = skip level rest
in (t
::pre
,found
,post
)
711 | ((PC.TOPar
(_
),_
) as t
)::rest
->
712 let level = level + 1 in
713 let (pre
,found
,post
) = skip level rest
in (t
::pre
,found
,post
)
714 | ((PC.TArobArob
,_
) as t
)::rest
715 | ((PC.TArob
,_
) as t
)::rest
716 | ((PC.EOF
,_
) as t
)::rest
-> ([t
],false,rest
)
718 let (pre
,found
,post
) = skip level rest
in (t
::pre
,found
,post
) in
719 let (pre
,found
,post
) = skip 1 rest
in
720 (match (found
,post
) with
721 (true,((PC.TOBrace
(_
),_
) as t3
)::rest
) ->
722 (PC.TFunDecl
(clt
),info) :: t1
:: t2
:: pre
@
723 t3
:: (find_function_names rest
)
724 | _
-> t1
:: t2
:: pre
@ find_function_names post
)
725 | t
:: rest
-> t
:: find_function_names rest
727 (* ----------------------------------------------------------------------- *)
728 (* an attribute is an identifier that preceeds another identifier and
731 let rec detect_attr l
=
733 (PC.TIdent
(_
,_
),_
) | (PC.TMetaId
(_
,_
,_
,_
),_
) | (PC.TMetaFunc
(_
,_
,_
,_
),_
)
734 | (PC.TMetaLocalFunc
(_
,_
,_
,_
),_
) -> true
736 let rec loop = function
739 | ((PC.TIdent
(nm
,clt
),info) as t1
)::id
::rest
when is_id id
->
740 if String.length nm
> 2 && String.sub nm
0 2 = "__"
741 then (PC.Tattr
(nm
,clt
),info)::(loop (id
::rest
))
742 else t1
::(loop (id
::rest
))
743 | x
::xs
-> x
::(loop xs
) in
746 (* ----------------------------------------------------------------------- *)
747 (* Look for variable declarations where the name is a typedef name.
748 We assume that C code does not contain a multiplication as a top-level
751 (* bug: once a type, always a type, even if the same name is later intended
752 to be used as a real identifier *)
753 let detect_types in_meta_decls l
=
754 let is_delim infn
= function
755 (PC.TOEllipsis
(_
),_
) (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *)
756 | (PC.TPOEllipsis
(_
),_
) (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *)
757 | (PC.TEllipsis
(_
),_
) (* | (PC.TCircles(_),_) | (PC.TStars(_),_) *)
758 | (PC.TPtVirg
(_
),_
) | (PC.TOBrace
(_
),_
) | (PC.TOInit
(_
),_
)
760 | (PC.TPure
,_
) | (PC.TContext
,_
)
761 | (PC.Tstatic
(_
),_
) | (PC.Textern
(_
),_
)
762 | (PC.Tinline
(_
),_
) | (PC.Ttypedef
(_
),_
) | (PC.Tattr
(_
),_
) -> true
763 | (PC.TComma
(_
),_
) when infn
> 0 or in_meta_decls
-> true
764 | (PC.TDotDot
(_
),_
) when in_meta_decls
-> true
766 let is_choices_delim = function
767 (PC.TOBrace
(_
),_
) | (PC.TComma
(_
),_
) -> true | _
-> false in
769 (PC.TIdent
(_
,_
),_
) | (PC.TMetaId
(_
,_
,_
,_
),_
) | (PC.TMetaFunc
(_
,_
,_
,_
),_
)
770 | (PC.TMetaLocalFunc
(_
,_
,_
,_
),_
) -> true
771 | (PC.TMetaParam
(_
,_
,_
),_
)
772 | (PC.TMetaParamList
(_
,_
,_
,_
),_
)
773 | (PC.TMetaConst
(_
,_
,_
,_
,_
),_
)
774 | (PC.TMetaErr
(_
,_
,_
,_
),_
)
775 | (PC.TMetaExp
(_
,_
,_
,_
,_
),_
)
776 | (PC.TMetaIdExp
(_
,_
,_
,_
,_
),_
)
777 | (PC.TMetaLocalIdExp
(_
,_
,_
,_
,_
),_
)
778 | (PC.TMetaExpList
(_
,_
,_
,_
),_
)
779 | (PC.TMetaType
(_
,_
,_
),_
)
780 | (PC.TMetaInit
(_
,_
,_
),_
)
781 | (PC.TMetaStm
(_
,_
,_
),_
)
782 | (PC.TMetaStmList
(_
,_
,_
),_
)
783 | (PC.TMetaPos
(_
,_
,_
,_
),_
) -> in_meta_decls
785 let redo_id ident clt v
=
786 !Data.add_type_name ident
;
787 (PC.TTypeId
(ident
,clt
),v
) in
788 let rec loop start infn type_names
= function
789 (* infn: 0 means not in a function header
790 > 0 means in a function header, after infn - 1 unmatched open parens*)
792 | ((PC.TOBrace
(clt
),v
)::_
) as all
when in_meta_decls
->
793 collect_choices type_names all
(* never a function header *)
794 | delim
::(PC.TIdent
(ident
,clt
),v
)::((PC.TMul
(_
),_
) as x
)::rest
795 when is_delim infn delim
->
796 let newid = redo_id ident clt v
in
797 delim
::newid::x
::(loop false infn
(ident
::type_names
) rest
)
798 | delim
::(PC.TIdent
(ident
,clt
),v
)::id
::rest
799 when is_delim infn delim
&& is_id id
->
800 let newid = redo_id ident clt v
in
801 delim
::newid::id
::(loop false infn
(ident
::type_names
) rest
)
802 | ((PC.TFunDecl
(_
),_
) as fn
)::rest
->
803 fn
::(loop false 1 type_names rest
)
804 | ((PC.TOPar
(_
),_
) as lp
)::rest
when infn
> 0 ->
805 lp
::(loop false (infn
+ 1) type_names rest
)
806 | ((PC.TCPar
(_
),_
) as rp
)::rest
when infn
> 0 ->
808 then rp
::(loop false 0 type_names rest
) (* 0 means not in fn header *)
809 else rp
::(loop false (infn
- 1) type_names rest
)
810 | (PC.TIdent
(ident
,clt
),v
)::((PC.TMul
(_
),_
) as x
)::rest
when start
->
811 let newid = redo_id ident clt v
in
812 newid::x
::(loop false infn
(ident
::type_names
) rest
)
813 | (PC.TIdent
(ident
,clt
),v
)::id
::rest
when start
&& is_id id
->
814 let newid = redo_id ident clt v
in
815 newid::id
::(loop false infn
(ident
::type_names
) rest
)
816 | (PC.TIdent
(ident
,clt
),v
)::rest
when List.mem ident type_names
->
817 (PC.TTypeId
(ident
,clt
),v
)::(loop false infn type_names rest
)
818 | ((PC.TIdent
(ident
,clt
),v
) as x
)::rest
->
819 x
::(loop false infn type_names rest
)
820 | x
::rest
-> x
::(loop false infn type_names rest
)
821 and collect_choices type_names
= function
822 [] -> [] (* should happen, but let the parser detect that *)
823 | (PC.TCBrace
(clt
),v
)::rest
->
824 (PC.TCBrace
(clt
),v
)::(loop false 0 type_names rest
)
825 | delim
::(PC.TIdent
(ident
,clt
),v
)::rest
826 when is_choices_delim delim
->
827 let newid = redo_id ident clt v
in
828 delim
::newid::(collect_choices
(ident
::type_names
) rest
)
829 | x
::rest
-> x
::(collect_choices type_names rest
) in
833 (* ----------------------------------------------------------------------- *)
834 (* Insert TLineEnd tokens at the end of a line that contains a WHEN.
835 WHEN is restricted to a single line, to avoid ambiguity in eg:
839 let token2line (tok
,_
) =
841 PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
842 | PC.Tfloat
(clt
) | PC.Tlong
(clt
) | PC.Tvoid
(clt
) | PC.Tstruct
(clt
)
843 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
844 | PC.Tstatic
(clt
) | PC.Tauto
(clt
) | PC.Tregister
(clt
) | PC.Textern
(clt
)
845 | PC.Tinline
(clt
) | PC.Ttypedef
(clt
) | PC.Tattr
(_
,clt
) | PC.Tconst
(clt
)
848 | PC.TInc
(clt
) | PC.TDec
(clt
)
850 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
851 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
) | PC.TSizeof
(clt
)
852 | PC.TReturn
(clt
) | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
)
854 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
855 | PC.TMetaDeclarer
(_
,_
,_
,clt
) | PC.TMetaIterator
(_
,_
,_
,clt
)
857 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
)
859 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
860 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TLogOp
(_
,clt
)
861 | PC.TShOp
(_
,clt
) | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
862 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
)
864 | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
865 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaExp
(_
,_
,_
,_
,clt
)
866 | PC.TMetaIdExp
(_
,_
,_
,_
,clt
) | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
867 | PC.TMetaExpList
(_
,_
,_
,clt
)
868 | PC.TMetaId
(_
,_
,_
,clt
) | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
)
869 | PC.TMetaStm
(_
,_
,clt
) | PC.TMetaStmList
(_
,_
,clt
) | PC.TMetaFunc
(_
,_
,_
,clt
)
870 | PC.TMetaLocalFunc
(_
,_
,_
,clt
) | PC.TMetaPos
(_
,_
,_
,clt
)
873 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
)
874 | PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TEllipsis
(clt
)
875 (* | PC.TCircles(clt) | PC.TStars(clt) *)
877 | PC.TOEllipsis
(clt
) | PC.TCEllipsis
(clt
)
878 | PC.TPOEllipsis
(clt
) | PC.TPCEllipsis
(clt
) (*| PC.TOCircles(clt)
879 | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *)
881 | PC.TWhy
(clt
) | PC.TDotDot
(clt
) | PC.TBang
(clt
) | PC.TOPar
(clt
)
882 | PC.TOPar0
(clt
) | PC.TMid0
(clt
) | PC.TCPar
(clt
)
885 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOCro
(clt
) | PC.TCCro
(clt
)
890 | PC.TDefine
(clt
,_
) | PC.TDefineParam
(clt
,_
,_
,_
)
891 | PC.TIncludeL
(_
,clt
) | PC.TIncludeNL
(_
,clt
)
893 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
895 let (_
,line
,_
,_
,_
,_
,_
,_
) = clt
in Some line
899 let rec insert_line_end = function
901 | (((PC.TWhen
(clt
),q
) as x
)::xs
) ->
902 x
::(find_line_end
true (token2line x
) clt q xs
)
903 | (((PC.TDefine
(clt
,_
),q
) as x
)::xs
)
904 | (((PC.TDefineParam
(clt
,_
,_
,_
),q
) as x
)::xs
) ->
905 x
::(find_line_end
false (token2line x
) clt q xs
)
906 | x
::xs
-> x
::(insert_line_end xs
)
908 and find_line_end inwhen line clt q
= function
909 (* don't know what 2nd component should be so just use the info of
910 the When. Also inherit - of when, if any *)
911 [] -> [(PC.TLineEnd
(clt
),q
)]
912 | ((PC.TIdent
("strict",clt
),a
) as x
)::xs
when token2line x
= line
->
913 (PC.TStrict
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
914 | ((PC.TIdent
("STRICT",clt
),a
) as x
)::xs
when token2line x
= line
->
915 (PC.TStrict
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
916 | ((PC.TIdent
("any",clt
),a
) as x
)::xs
when token2line x
= line
->
917 (PC.TAny
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
918 | ((PC.TIdent
("ANY",clt
),a
) as x
)::xs
when token2line x
= line
->
919 (PC.TAny
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
920 | ((PC.TIdent
("forall",clt
),a
) as x
)::xs
when token2line x
= line
->
921 (PC.TForall
,a
) :: (find_line_end inwhen line clt q xs
)
922 | ((PC.TIdent
("exists",clt
),a
) as x
)::xs
when token2line x
= line
->
923 (PC.TExists
,a
) :: (find_line_end inwhen line clt q xs
)
924 | ((PC.TComma
(clt
),a
) as x
)::xs
when token2line x
= line
->
925 (PC.TComma
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
926 | ((PC.TPArob
,a
) as x
)::xs
-> (* no line #, just assume on the same line *)
927 x
:: (find_line_end inwhen line clt q xs
)
928 | x
::xs
when token2line x
= line
-> x
:: (find_line_end inwhen line clt q xs
)
929 | xs
-> (PC.TLineEnd
(clt
),q
)::(insert_line_end xs
)
931 let rec translate_when_true_false = function
933 | (PC.TWhen
(clt
),q
)::((PC.TNotEq
(_
),_
) as x
)::(PC.TIdent
("true",_
),_
)::xs
->
934 (PC.TWhenTrue
(clt
),q
)::x
::(translate_when_true_false xs
)
935 | (PC.TWhen
(clt
),q
)::((PC.TNotEq
(_
),_
) as x
)::(PC.TIdent
("false",_
),_
)::xs
->
936 (PC.TWhenFalse
(clt
),q
)::x
::(translate_when_true_false xs
)
937 | x
::xs
-> x
:: (translate_when_true_false xs
)
939 (* ----------------------------------------------------------------------- *)
940 (* top level initializers: a sequence of braces followed by a dot *)
942 let find_top_init tokens
=
944 (PC.TOBrace
(clt
),q
) :: rest
->
945 let rec dot_start acc
= function
946 ((PC.TOBrace
(_
),_
) as x
) :: rest
->
947 dot_start (x
::acc
) rest
948 | ((PC.TDot
(_
),_
) :: rest
) as x
->
949 Some
((PC.TOInit
(clt
),q
) :: (List.rev acc
) @ x
)
951 let rec comma_end acc
= function
952 ((PC.TCBrace
(_
),_
) as x
) :: rest
->
953 comma_end (x
::acc
) rest
954 | ((PC.TComma
(_
),_
) :: rest
) as x
->
955 Some
((PC.TOInit
(clt
),q
) :: (List.rev x
) @ acc
)
957 (match dot_start [] rest
with
960 (match List.rev rest
with
961 (* not super sure what this does, but EOF, @, and @@ should be
962 the same, markind the end of a rule *)
963 ((PC.EOF
,_
) as x
)::rest
| ((PC.TArob
,_
) as x
)::rest
964 | ((PC.TArobArob
,_
) as x
)::rest
->
965 (match comma_end [x
] rest
with
969 failwith
"unexpected empty token list"))
972 (* ----------------------------------------------------------------------- *)
973 (* Integrate pragmas into some adjacent token. + tokens are preferred. Dots
976 let rec collect_all_pragmas collected
= function
977 (PC.TPragma
(s
,(_
,line
,logical_line
,offset
,col
,_
,_
,pos
)),_
)::rest
->
979 { Ast0.line_start
= line
; Ast0.line_end
= line
;
980 Ast0.logical_start
= logical_line
; Ast0.logical_end
= logical_line
;
981 Ast0.column
= col
; Ast0.offset
= offset
; } in
982 collect_all_pragmas ((s
,i)::collected
) rest
983 | l
-> (List.rev collected
,l
)
985 let rec collect_pass = function
988 match plus_attachable false x
with
990 let (pass
,rest
) = collect_pass xs
in
994 let plus_attach strict
= function
996 | Some x
-> plus_attachable strict x
998 let add_bef = function Some x
-> [x
] | None
-> []
1000 (*skips should be things like line end
1001 skips is things before pragmas that can't be attached to, pass is things
1002 after. pass is used immediately. skips accumulates. *)
1003 let rec process_pragmas bef skips
= function
1004 [] -> add_bef bef
@ List.rev skips
1005 | ((PC.TPragma
(s
,i),_
)::_
) as l
->
1006 let (pragmas
,rest
) = collect_all_pragmas [] l
in
1007 let (pass
,rest0
) = collect_pass rest
in
1009 match rest0
with [] -> (None
,[]) | next
::rest
-> (Some next
,rest
) in
1010 (match (bef
,plus_attach true bef
,next
,plus_attach true next
) with
1011 (Some bef
,PLUS
,_
,_
) ->
1012 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt bef
in
1013 (update_clt bef
(a
,b
,c
,d
,e
,strbef
,pragmas
,pos
))::List.rev skips
@
1014 pass
@process_pragmas None
[] rest0
1015 | (_
,_
,Some next
,PLUS
) ->
1016 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt next
in
1017 (add_bef bef
) @ List.rev skips
@ pass
@
1019 (Some
(update_clt next
(a
,b
,c
,d
,e
,pragmas
,straft
,pos
)))
1022 (match (bef
,plus_attach false bef
,next
,plus_attach false next
) with
1023 (Some bef
,PLUS
,_
,_
) ->
1024 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt bef
in
1025 (update_clt bef
(a
,b
,c
,d
,e
,strbef
,pragmas
,pos
))::List.rev skips
@
1026 pass
@process_pragmas None
[] rest0
1027 | (_
,_
,Some next
,PLUS
) ->
1028 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt next
in
1029 (add_bef bef
) @ List.rev skips
@ pass
@
1031 (Some
(update_clt next
(a
,b
,c
,d
,e
,pragmas
,straft
,pos
)))
1033 | _
-> failwith
"nothing to attach pragma to"))
1035 (match plus_attachable false x
with
1036 SKIP
-> process_pragmas bef
(x
::skips
) xs
1037 | _
-> (add_bef bef
) @ List.rev skips
@ (process_pragmas (Some x
) [] xs
))
1039 (* ----------------------------------------------------------------------- *)
1040 (* Drop ... ... . This is only allowed in + code, and arises when there is
1041 some - code between the ... *)
1042 (* drop whens as well - they serve no purpose in + code and they cause
1043 problems for drop_double_dots *)
1045 let rec drop_when = function
1047 | (PC.TWhen
(clt
),info)::xs
->
1048 let rec loop = function
1050 | (PC.TLineEnd
(_
),info)::xs
-> drop_when xs
1051 | x
::xs
-> loop xs
in
1053 | x
::xs
-> x
::drop_when xs
1055 (* instead of dropping the double dots, we put TNothing in between them.
1056 these vanish after the parser, but keeping all the ...s in the + code makes
1057 it easier to align the + and - code in context_neg and in preparation for the
1058 isomorphisms. This shouldn't matter because the context code of the +
1059 slice is mostly ignored anyway *)
1060 let minus_to_nothing l
=
1061 (* for cases like | <..., which may or may not arise from removing minus
1062 code, depending on whether <... is a statement or expression *)
1065 let (d
,_
,_
,_
,_
,_
,_
,_
) = get_clt tok
in
1067 D.MINUS
| D.OPTMINUS
| D.UNIQUEMINUS
-> true
1069 | D.CONTEXT
| D.UNIQUE
| D.OPT
-> false)
1071 let rec minus_loop = function
1073 | (d
::ds
) as l
-> if is_minus d
then minus_loop ds
else l
in
1074 let rec loop = function
1076 | ((PC.TMid0
(clt
),i) as x
)::t1
::ts
when is_minus t1
->
1077 (match minus_loop ts
with
1078 ((PC.TOEllipsis
(_
),_
)::_
) | ((PC.TPOEllipsis
(_
),_
)::_
)
1079 | ((PC.TEllipsis
(_
),_
)::_
) as l
-> x
::(PC.TNothing
,i)::(loop l
)
1081 | t
::ts
-> t
::(loop ts
) in
1084 let rec drop_double_dots l
=
1085 let start = function
1086 (PC.TOEllipsis
(_
),_
) | (PC.TPOEllipsis
(_
),_
)
1087 (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *) ->
1090 let middle = function
1091 (PC.TEllipsis
(_
),_
) (* | (PC.TCircles(_),_) | (PC.TStars(_),_) *) -> true
1093 let whenline = function
1094 (PC.TLineEnd
(_
),_
) -> true
1095 (*| (PC.TMid0(_),_) -> true*)
1097 let final = function
1098 (PC.TCEllipsis
(_
),_
) | (PC.TPCEllipsis
(_
),_
)
1099 (* | (PC.TCCircles(_),_) | (PC.TCStars(_),_) *) ->
1102 let any_before x
= start x
or middle x
or final x
or whenline x
in
1103 let any_after x
= start x
or middle x
or final x
in
1104 let rec loop ((_
,i) as prev
) = function
1106 | x
::rest
when any_before prev
&& any_after x
->
1107 (PC.TNothing
,i)::x
::(loop x rest
)
1108 | x
::rest
-> x
:: (loop x rest
) in
1111 | (x
::xs
) -> x
:: loop x xs
1115 if l
= cur then l
else fix f
cur
1117 (* ( | ... | ) also causes parsing problems *)
1121 let rec drop_empty_thing starter
middle ender
= function
1123 | hd
::rest
when starter hd
->
1124 let rec loop = function
1125 x
::rest
when middle x
-> loop rest
1126 | x
::rest
when ender x
-> rest
1127 | _
-> raise Not_empty
in
1128 (match try Some
(loop rest
) with Not_empty
-> None
with
1129 Some x
-> drop_empty_thing starter
middle ender x
1130 | None
-> hd
:: drop_empty_thing starter
middle ender rest
)
1131 | x
::rest
-> x
:: drop_empty_thing starter
middle ender rest
1135 (function (PC.TOPar0
(_
),_
) -> true | _
-> false)
1136 (function (PC.TMid0
(_
),_
) -> true | _
-> false)
1137 (function (PC.TCPar0
(_
),_
) -> true | _
-> false)
1139 let drop_empty_nest = drop_empty_thing
1141 (* ----------------------------------------------------------------------- *)
1144 let get_s_starts (_
, (s
,_
,(starts
, ends
))) =
1145 Printf.printf
"%d %d\n" starts ends
; (s
, starts
)
1148 let v = List.hd
!l
in
1153 PC.reinit (function _
-> PC.TArobArob
(* a handy token *))
1154 (Lexing.from_function
1155 (function buf
-> function n
-> raise
Common.Impossible
))
1157 let parse_one str parsefn file toks
=
1158 let all_tokens = ref toks
in
1159 let cur_tok = ref (List.hd
!all_tokens) in
1161 let lexer_function _
=
1162 let (v, info) = pop2 all_tokens in
1163 cur_tok := (v, info);
1167 Lexing.from_function
1168 (function buf
-> function n
-> raise
Common.Impossible
)
1173 try parsefn
lexer_function lexbuf_fake
1175 Lexer_cocci.Lexical s
->
1177 (Printf.sprintf
"%s: lexical error: %s\n =%s\n" str s
1178 (Common.error_message file
(get_s_starts !cur_tok) ))
1179 | Parser_cocci_menhir.Error
->
1181 (Printf.sprintf
"%s: parse error: \n = %s\n" str
1182 (Common.error_message file
(get_s_starts !cur_tok) ))
1183 | Semantic_cocci.Semantic s
->
1185 (Printf.sprintf
"%s: semantic error: %s\n =%s\n" str s
1186 (Common.error_message file
(get_s_starts !cur_tok) ))
1190 let prepare_tokens tokens
=
1192 (translate_when_true_false (* after insert_line_end *)
1194 (detect_types false (find_function_names (detect_attr tokens
)))))
1196 let prepare_mv_tokens tokens
=
1197 detect_types false (detect_attr tokens
)
1199 let rec consume_minus_positions = function
1201 | ((PC.TOPar0
(_
),_
) as x
)::xs
| ((PC.TCPar0
(_
),_
) as x
)::xs
1202 | ((PC.TMid0
(_
),_
) as x
)::xs
-> x
::consume_minus_positions xs
1203 | x
::(PC.TPArob
,_
)::(PC.TMetaPos
(name
,constraints
,per
,clt
),_
)::xs
->
1204 let (arity
,ln
,lln
,offset
,col
,strbef
,straft
,_
) = get_clt x
in
1205 let name = Parse_aux.clt2mcode
name clt
in
1208 (arity
,ln
,lln
,offset
,col
,strbef
,straft
,
1209 Ast0.MetaPos
(name,constraints
,per
)) in
1210 x::(consume_minus_positions xs
)
1211 | x::xs
-> x::consume_minus_positions xs
1213 let any_modif rule
=
1215 match Ast0.get_mcode_mcodekind
x with
1216 Ast0.MINUS _
| Ast0.PLUS
-> true
1218 let donothing r k e
= k e
in
1219 let bind x y
= x or y
in
1220 let option_default = false in
1222 V0.flat_combiner
bind option_default
1223 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1224 donothing donothing donothing donothing donothing donothing
1225 donothing donothing donothing donothing donothing donothing donothing
1226 donothing donothing in
1227 List.exists
fn.VT0.combiner_rec_top_level rule
1229 let drop_last extra l
= List.rev
(extra
@(List.tl
(List.rev l
)))
1231 let partition_either l
=
1232 let rec part_either left right
= function
1233 | [] -> (List.rev left
, List.rev right
)
1236 | Common.Left e
-> part_either (e
:: left
) right l
1237 | Common.Right e
-> part_either left
(e
:: right
) l
) in
1240 let get_metavars parse_fn table file lexbuf
=
1241 let rec meta_loop acc
(* read one decl at a time *) =
1243 tokens_all table file
true lexbuf
[PC.TArobArob
;PC.TMPtVirg
] in
1244 let tokens = prepare_mv_tokens tokens in
1246 [(PC.TArobArob
,_
)] -> List.rev acc
1248 let metavars = parse_one "meta" parse_fn file
tokens in
1249 meta_loop (metavars@acc
) in
1250 partition_either (meta_loop [])
1252 let get_script_metavars parse_fn table file lexbuf
=
1253 let rec meta_loop acc
=
1255 tokens_all table file
true lexbuf
[PC.TArobArob
; PC.TMPtVirg
] in
1256 let tokens = prepare_tokens tokens in
1258 [(PC.TArobArob
, _
)] -> List.rev acc
1260 let metavar = parse_one "scriptmeta" parse_fn file
tokens in
1261 meta_loop (metavar :: acc
)
1265 let get_rule_name parse_fn starts_with_name get_tokens file prefix
=
1266 Data.in_rule_name
:= true;
1267 let mknm _
= make_name prefix
(!Lexer_cocci.line
) in
1271 let (_
,tokens) = get_tokens
[PC.TArob
] in
1272 let check_name = function
1273 None
-> Some
(mknm())
1275 (if List.mem nm
reserved_names
1276 then failwith
(Printf.sprintf
"invalid name %s\n" nm
));
1278 match parse_one "rule name" parse_fn file
tokens with
1279 Ast.CocciRulename
(nm
,a
,b
,c
,d
,e
) ->
1280 Ast.CocciRulename
(check_name nm
,a
,b
,c
,d
,e
)
1281 | Ast.GeneratedRulename
(nm
,a
,b
,c
,d
,e
) ->
1282 Ast.GeneratedRulename
(check_name nm
,a
,b
,c
,d
,e
)
1283 | Ast.ScriptRulename
(s
,deps
) -> Ast.ScriptRulename
(s
,deps
)
1284 | Ast.InitialScriptRulename
(s
) -> Ast.InitialScriptRulename
(s
)
1285 | Ast.FinalScriptRulename
(s
) -> Ast.FinalScriptRulename
(s
)
1287 Ast.CocciRulename
(Some
(mknm()),Ast.NoDep
,[],[],Ast.Undetermined
,false) in
1288 Data.in_rule_name
:= false;
1291 let parse_iso file
=
1292 let table = Common.full_charpos_to_pos file
in
1293 Common.with_open_infile file
(fun channel
->
1294 let lexbuf = Lexing.from_channel channel
in
1295 let get_tokens = tokens_all table file
false lexbuf in
1297 match get_tokens [PC.TArobArob
;PC.TArob
] with
1299 let parse_start start =
1300 let rev = List.rev start in
1301 let (arob
,_
) = List.hd
rev in
1302 (arob
= PC.TArob
,List.rev(List.tl
rev)) in
1303 let (starts_with_name
,start) = parse_start start in
1304 let rec loop starts_with_name
start =
1305 (!Data.init_rule
)();
1306 (* get metavariable declarations - have to be read before the
1308 let (rule_name
,_
,_
,_
,_
,_
) =
1309 match get_rule_name PC.iso_rule_name starts_with_name
get_tokens
1310 file
("iso file "^file
) with
1311 Ast.CocciRulename
(Some n
,a
,b
,c
,d
,e
) -> (n
,a
,b
,c
,d
,e
)
1312 | _
-> failwith
"Script rules cannot appear in isomorphism rules"
1314 Ast0.rule_name
:= rule_name
;
1315 Data.in_meta
:= true;
1317 match get_metavars PC.iso_meta_main
table file
lexbuf with
1318 (iso_metavars,[]) -> iso_metavars
1319 | _
-> failwith
"unexpected inheritance in iso" in
1320 Data.in_meta
:= false;
1324 [PC.TIsoStatement
;PC.TIsoExpression
;PC.TIsoArgExpression
;
1325 PC.TIsoTestExpression
;
1326 PC.TIsoDeclaration
;PC.TIsoType
;PC.TIsoTopLevel
] in
1327 let next_start = List.hd
(List.rev tokens) in
1328 let dummy_info = ("",(-1,-1),(-1,-1)) in
1329 let tokens = drop_last [(PC.EOF
,dummy_info)] tokens in
1330 let tokens = prepare_tokens (start@tokens) in
1332 print_tokens "iso tokens" tokens;
1334 let entry = parse_one "iso main" PC.iso_main file
tokens in
1335 let entry = List.map
(List.map
Test_exps.process_anything
) entry in
1337 then (* The code below allows a header like Statement list,
1338 which is more than one word. We don't have that any more,
1339 but the code is left here in case it is put back. *)
1340 match get_tokens [PC.TArobArob
;PC.TArob
] with
1342 let (starts_with_name
,start) = parse_start start in
1343 (iso_metavars,entry,rule_name
) ::
1344 (loop starts_with_name
(next_start::start))
1345 | _
-> failwith
"isomorphism ends early"
1346 else [(iso_metavars,entry,rule_name
)] in
1347 loop starts_with_name
start
1348 | (false,_
) -> [] in
1351 let parse_iso_files existing_isos iso_files extra_path
=
1352 let get_names = List.map
(function (_
,_
,nm
) -> nm
) in
1353 let old_names = get_names existing_isos
in
1354 Data.in_iso
:= true;
1357 (function (prev
,names
) ->
1359 Lexer_cocci.init
();
1362 Common.Left
(fl
) -> Filename.concat extra_path fl
1363 | Common.Right
(fl
) -> Filename.concat
Config.path fl
in
1364 let current = parse_iso file in
1365 let new_names = get_names current in
1366 if List.exists
(function x -> List.mem
x names
) new_names
1367 then failwith
(Printf.sprintf
"repeated iso name found in %s" file);
1368 (current::prev
,new_names @ names
))
1369 ([],old_names) iso_files
in
1370 Data.in_iso
:= false;
1371 existing_isos
@(List.concat
(List.rev res))
1374 let table = Common.full_charpos_to_pos
file in
1375 Common.with_open_infile
file (fun channel
->
1376 let lexbuf = Lexing.from_channel channel
in
1377 let get_tokens = tokens_all table file false lexbuf in
1378 Data.in_prolog
:= true;
1379 let initial_tokens = get_tokens [PC.TArobArob
;PC.TArob
] in
1380 Data.in_prolog
:= false;
1382 match initial_tokens with
1384 (match List.rev data
with
1385 ((PC.TArobArob
as x),_
)::_
| ((PC.TArob
as x),_
)::_
->
1387 parse_one "iso file names" PC.include_main
file data
in
1389 let parse_cocci_rule ruletype old_metas
1390 (rule_name
, dependencies
, iso
, dropiso
, exists
, is_expression
) =
1391 Ast0.rule_name
:= rule_name
;
1392 Data.inheritable_positions
:=
1393 rule_name
:: !Data.inheritable_positions
;
1395 (* get metavariable declarations *)
1396 Data.in_meta
:= true;
1397 let (metavars, inherited_metavars
) =
1398 get_metavars PC.meta_main
table file lexbuf in
1399 Data.in_meta
:= false;
1400 Hashtbl.add
Data.all_metadecls rule_name
metavars;
1401 Hashtbl.add
Lexer_cocci.rule_names rule_name
();
1402 Hashtbl.add
Lexer_cocci.all_metavariables rule_name
1404 (fun key
v rest
-> (key
,v)::rest
)
1405 Lexer_cocci.metavariables
[]);
1407 (* get transformation rules *)
1408 let (more
, tokens) = get_tokens [PC.TArobArob
; PC.TArob
] in
1409 let (minus_tokens
, _
) = split_token_stream tokens in
1410 let (_
, plus_tokens
) =
1411 split_token_stream (minus_to_nothing tokens) in
1413 let minus_tokens = consume_minus_positions minus_tokens in
1414 let minus_tokens = prepare_tokens minus_tokens in
1415 let plus_tokens = prepare_tokens plus_tokens in
1418 print_tokens "minus tokens" minus_tokens;
1419 print_tokens "plus tokens" plus_tokens;
1423 process_pragmas None
[]
1424 (fix (function x -> drop_double_dots (drop_empty_or x))
1425 (drop_when plus_tokens)) in
1427 print_tokens "plus tokens" plus_tokens;
1428 Printf.printf "before minus parse\n";
1432 then parse_one "minus" PC.minus_exp_main
file minus_tokens
1433 else parse_one "minus" PC.minus_main
file minus_tokens in
1435 Unparse_ast0.unparse minus_res;
1436 Printf.printf "before plus parse\n";
1439 if !Flag.sgrep_mode2
1440 then (* not actually used for anything, except context_neg *)
1442 (Iso_pattern.rebuild_mcode None
).VT0.rebuilder_rec_top_level
1446 then parse_one "plus" PC.plus_exp_main
file plus_tokens
1447 else parse_one "plus" PC.plus_main
file plus_tokens in
1449 Printf.printf "after plus parse\n";
1452 (if not
!Flag.sgrep_mode2
&&
1453 (any_modif minus_res or any_modif plus_res)
1454 then Data.inheritable_positions
:= []);
1456 Check_meta.check_meta rule_name old_metas inherited_metavars
1457 metavars minus_res plus_res;
1459 (more
, Ast0.CocciRule
((minus_res, metavars,
1460 (iso
, dropiso
, dependencies
, rule_name
, exists
)),
1461 (plus_res, metavars), ruletype
), metavars, tokens) in
1463 let parse_script_rule language old_metas deps
=
1464 let get_tokens = tokens_script_all table file false lexbuf in
1466 (* meta-variables *)
1467 Data.in_meta
:= true;
1469 get_script_metavars PC.script_meta_main
table file lexbuf in
1470 Data.in_meta
:= false;
1472 let exists_in old_metas
(py
,(r
,m
)) =
1473 let test (rr
,mr
) x =
1474 let (ro
,vo
) = Ast.get_meta_name
x in
1475 ro
= rr
&& vo
= mr
in
1476 List.exists
(test (r
,m
)) old_metas
in
1480 let meta2c (r
,n
) = Printf.sprintf
"%s.%s" r n
in
1481 if not
(exists_in old_metas
x) then
1484 "Script references unknown meta-variable: %s"
1489 let (more
, tokens) = get_tokens [PC.TArobArob
; PC.TArob
] in
1491 match List.hd
tokens with
1492 (PC.TScriptData
(s
),_
) -> s
1493 | (PC.TArobArob
,_
) | (PC.TArob
,_
) -> ""
1494 | _
-> failwith
"Malformed script rule" in
1495 (more
,Ast0.ScriptRule
(language
, deps
, metavars, data),[],tokens) in
1497 let parse_if_script_rule k language
=
1498 let get_tokens = tokens_script_all table file false lexbuf in
1501 let (more
, tokens) = get_tokens [PC.TArobArob
; PC.TArob
] in
1503 match List.hd
tokens with
1504 (PC.TScriptData
(s
),_
) -> s
1505 | (PC.TArobArob
,_
) | (PC.TArob
,_
) -> ""
1506 | _
-> failwith
"Malformed script rule" in
1507 (more
,k
(language
, data),[],tokens) in
1509 let parse_iscript_rule =
1510 parse_if_script_rule
1511 (function (language
,data) ->
1512 Ast0.InitialScriptRule
(language
,data)) in
1514 let parse_fscript_rule =
1515 parse_if_script_rule
1516 (function (language
,data) ->
1517 Ast0.FinalScriptRule
(language
,data)) in
1519 let parse_rule old_metas starts_with_name
=
1521 get_rule_name PC.rule_name starts_with_name
get_tokens file
1524 Ast.CocciRulename
(Some s
, a
, b
, c
, d
, e
) ->
1525 parse_cocci_rule Ast.Normal old_metas
(s
, a
, b
, c
, d
, e
)
1526 | Ast.GeneratedRulename
(Some s
, a
, b
, c
, d
, e
) ->
1527 Data.in_generating
:= true;
1529 parse_cocci_rule Ast.Generated old_metas
(s
,a
,b
,c
,d
,e
) in
1530 Data.in_generating
:= false;
1532 | Ast.ScriptRulename
(l
,deps
) -> parse_script_rule l old_metas deps
1533 | Ast.InitialScriptRulename
(l
) -> parse_iscript_rule l
1534 | Ast.FinalScriptRulename
(l
) -> parse_fscript_rule l
1535 | _
-> failwith
"Malformed rule name"
1538 let rec loop old_metas starts_with_name
=
1539 (!Data.init_rule
)();
1541 let gen_starts_with_name more
tokens =
1543 (match List.hd
(List.rev tokens) with
1544 (PC.TArobArob
,_
) -> false
1545 | (PC.TArob
,_
) -> true
1546 | _
-> failwith
"unexpected token")
1549 let (more
, rule
, metavars, tokens) =
1550 parse_rule old_metas starts_with_name
in
1553 (loop (metavars @ old_metas
) (gen_starts_with_name more
tokens))
1558 (iso_files, loop [] (x = PC.TArob
))
1559 | _
-> failwith
"unexpected code before the first rule\n")
1560 | (false,[(PC.TArobArob
,_
)]) | (false,[(PC.TArob
,_
)]) ->
1561 ([],([] : Ast0.parsed_rule list
))
1562 | _
-> failwith
"unexpected code before the first rule\n" in
1565 (* parse to ast0 and then convert to ast *)
1566 let process file isofile verbose
=
1567 let extra_path = Filename.dirname
file in
1569 let (iso_files, rules
) = parse file in
1573 | Some iso_file
-> parse_iso_files [] [Common.Left iso_file
] "" in
1574 let global_isos = parse_iso_files std_isos iso_files extra_path in
1575 let rules = Unitary_ast0.do_unitary
rules in
1579 Ast0.ScriptRule
(a
,b
,c
,d
) -> [([],Ast.ScriptRule
(a
,b
,c
,d
))]
1580 | Ast0.InitialScriptRule
(a
,b
) -> [([],Ast.InitialScriptRule
(a
,b
))]
1581 | Ast0.FinalScriptRule
(a
,b
) -> [([],Ast.FinalScriptRule
(a
,b
))]
1584 (iso
, dropiso
, dependencies
, rule_name
, exists
)),
1585 (plus
, metavars),ruletype
) ->
1587 parse_iso_files global_isos
1588 (List.map
(function x -> Common.Left
x) iso
)
1591 (* check that dropped isos are actually available *)
1594 List.map
(function (_
,_
,nm
) -> nm
) chosen_isos in
1595 let local_iso_names = reserved_names @ iso_names in
1598 (function dropped
->
1599 not
(List.mem dropped
local_iso_names))
1602 ("invalid iso name " ^
bad_dropped ^
" in " ^ rule_name
)
1603 with Not_found
-> ());
1604 if List.mem
"all" dropiso
1606 if List.length dropiso
= 1
1608 else failwith
"disable all should only be by itself"
1609 else (* drop those isos *)
1611 (function (_
,_
,nm
) -> not
(List.mem nm dropiso
))
1613 List.iter
Iso_compile.process chosen_isos;
1615 match reserved_names with
1620 List.filter
(function x -> List.mem
x dropiso
) others
)
1623 "bad list of reserved names - all must be at start" in
1624 let minus = Test_exps.process minus in
1625 let minus = Compute_lines.compute_lines
minus in
1626 let plus = Compute_lines.compute_lines
plus in
1628 (* only relevant to Flag.make_hrule *)
1629 (* doesn't handle multiple minirules properly, but since
1630 we don't really handle them in lots of other ways, it
1631 doesn't seem very important *)
1635 [match Ast0.unwrap p
with
1637 (match List.map
Ast0.unwrap
(Ast0.undots c
) with
1638 [Ast0.Exp e
] -> true | _
-> false)
1640 let minus = Arity.minus_arity
minus in
1641 let ((metavars,minus),function_prototypes
) =
1642 Function_prototypes.process
1643 rule_name
metavars dropped_isos minus plus ruletype
in
1644 let plus = Adjust_pragmas.process plus in
1645 (* warning! context_neg side-effects its arguments *)
1646 let (m
,p
) = List.split (Context_neg.context_neg
minus plus) in
1647 Type_infer.type_infer p
;
1648 (if not
!Flag.sgrep_mode2
1649 then Insert_plus.insert_plus m p
(chosen_isos = []));
1650 Type_infer.type_infer
minus;
1651 let (extra_meta
, minus) =
1652 match (chosen_isos,ruletype
) with
1653 (* separate case for [] because applying isos puts
1654 some restrictions on the -+ code *)
1655 ([],_
) | (_
,Ast.Generated
) -> ([],minus)
1656 | _
-> Iso_pattern.apply_isos
chosen_isos minus rule_name
in
1657 (* after iso, because iso can intro ... *)
1658 let minus = Adjacency.compute_adjacency
minus in
1659 let minus = Comm_assoc.comm_assoc
minus rule_name dropiso
in
1661 if !Flag.sgrep_mode2
then minus
1662 else Single_statement.single_statement
minus in
1663 let minus = Simple_assignments.simple_assignments
minus in
1665 Ast0toast.ast0toast rule_name dependencies
dropped_isos
1666 exists
minus is_exp ruletype
in
1667 match function_prototypes
with
1668 None
-> [(extra_meta
@ metavars, minus_ast)]
1670 [(extra_meta
@ metavars, minus_ast); mv_fp
])
1671 (* Ast0.CocciRule ((minus, metavarsm, (iso, dropiso, dependencies, rule_name, exists)), (plus, metavars))*)
1673 let parsed = List.concat
parsed in
1674 let disjd = Disjdistr.disj
parsed in
1676 let (metavars,code
,fvs
,neg_pos
,ua
,pos
) = Free_vars.free_vars
disjd in
1677 if !Flag_parsing_cocci.show_SP
1678 then List.iter
Pretty_print_cocci.unparse code
;
1681 Common.profile_code
"get_constants"
1682 (fun () -> Get_constants.get_constants code
) in (* for grep *)
1683 let glimpse_tokens2 =
1684 Common.profile_code
"get_glimpse_constants"
1685 (fun () -> Get_constants2.get_constants code neg_pos
) in(* for glimpse *)
1686 (metavars,code
,fvs
,neg_pos
,ua
,pos
,grep_tokens,glimpse_tokens2)