2 * Copyright 2005-2009, 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
(s
,_
) -> s
116 | PC.TIncludeL
(s
,clt
) -> (pr "#include \"%s\"" s
)^
(line_type2c clt
)
117 | PC.TIncludeNL
(s
,clt
) -> (pr "#include <%s>" s
)^
(line_type2c clt
)
118 | PC.TDefine
(clt
,_
) -> "#define"^
(line_type2c clt
)
119 | PC.TDefineParam
(clt
,_
,_
,_
) -> "#define_param"^
(line_type2c clt
)
120 | PC.TMinusFile
(s
,clt
) -> (pr "--- %s" s
)^
(line_type2c clt
)
121 | PC.TPlusFile
(s
,clt
) -> (pr "+++ %s" s
)^
(line_type2c clt
)
123 | PC.TInc
(clt
) -> "++"^
(line_type2c clt
)
124 | PC.TDec
(clt
) -> "--"^
(line_type2c clt
)
126 | PC.TIf
(clt
) -> "if"^
(line_type2c clt
)
127 | PC.TElse
(clt
) -> "else"^
(line_type2c clt
)
128 | PC.TWhile
(clt
) -> "while"^
(line_type2c clt
)
129 | PC.TFor
(clt
) -> "for"^
(line_type2c clt
)
130 | PC.TDo
(clt
) -> "do"^
(line_type2c clt
)
131 | PC.TSwitch
(clt
) -> "switch"^
(line_type2c clt
)
132 | PC.TCase
(clt
) -> "case"^
(line_type2c clt
)
133 | PC.TDefault
(clt
) -> "default"^
(line_type2c clt
)
134 | PC.TReturn
(clt
) -> "return"^
(line_type2c clt
)
135 | PC.TBreak
(clt
) -> "break"^
(line_type2c clt
)
136 | PC.TContinue
(clt
) -> "continue"^
(line_type2c clt
)
137 | PC.TGoto
(clt
) -> "goto"^
(line_type2c clt
)
138 | PC.TIdent
(s
,clt
) -> (pr "ident-%s" s
)^
(line_type2c clt
)
139 | PC.TTypeId
(s
,clt
) -> (pr "typename-%s" s
)^
(line_type2c clt
)
140 | PC.TDeclarerId
(s
,clt
) -> (pr "declarername-%s" s
)^
(line_type2c clt
)
141 | PC.TIteratorId
(s
,clt
) -> (pr "iteratorname-%s" s
)^
(line_type2c clt
)
142 | PC.TMetaDeclarer
(_
,_
,_
,clt
) -> "declmeta"^
(line_type2c clt
)
143 | PC.TMetaIterator
(_
,_
,_
,clt
) -> "itermeta"^
(line_type2c clt
)
145 | PC.TSizeof
(clt
) -> "sizeof"^
(line_type2c clt
)
147 | PC.TString
(x
,clt
) -> x^
(line_type2c clt
)
148 | PC.TChar
(x
,clt
) -> x^
(line_type2c clt
)
149 | PC.TFloat
(x
,clt
) -> x^
(line_type2c clt
)
150 | PC.TInt
(x
,clt
) -> x^
(line_type2c clt
)
152 | PC.TOrLog
(clt
) -> "||"^
(line_type2c clt
)
153 | PC.TAndLog
(clt
) -> "&&"^
(line_type2c clt
)
154 | PC.TOr
(clt
) -> "|"^
(line_type2c clt
)
155 | PC.TXor
(clt
) -> "^"^
(line_type2c clt
)
156 | PC.TAnd
(clt
) -> "&"^
(line_type2c clt
)
157 | PC.TEqEq
(clt
) -> "=="^
(line_type2c clt
)
158 | PC.TNotEq
(clt
) -> "!="^
(line_type2c clt
)
159 | PC.TTildeEq
(clt
) -> "~="^
(line_type2c clt
)
160 | PC.TTildeExclEq
(clt
) -> "~!="^
(line_type2c clt
)
161 | PC.TLogOp
(op
,clt
) ->
167 | _
-> failwith
"not possible")
169 | PC.TShOp
(op
,clt
) ->
172 | Ast.DecRight
-> ">>"
173 | _
-> failwith
"not possible")
175 | PC.TPlus
(clt
) -> "+"^
(line_type2c clt
)
176 | PC.TMinus
(clt
) -> "-"^
(line_type2c clt
)
177 | PC.TMul
(clt
) -> "*"^
(line_type2c clt
)
178 | PC.TDmOp
(op
,clt
) ->
182 | _
-> failwith
"not possible")
184 | PC.TTilde
(clt
) -> "~"^
(line_type2c clt
)
186 | PC.TMetaParam
(_
,_
,clt
) -> "parammeta"^
(line_type2c clt
)
187 | PC.TMetaParamList
(_
,_
,_
,clt
) -> "paramlistmeta"^
(line_type2c clt
)
188 | PC.TMetaConst
(_
,_
,_
,_
,clt
) -> "constmeta"^
(line_type2c clt
)
189 | PC.TMetaErr
(_
,_
,_
,clt
) -> "errmeta"^
(line_type2c clt
)
190 | PC.TMetaExp
(_
,_
,_
,_
,clt
) -> "expmeta"^
(line_type2c clt
)
191 | PC.TMetaIdExp
(_
,_
,_
,_
,clt
) -> "idexpmeta"^
(line_type2c clt
)
192 | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
) -> "localidexpmeta"^
(line_type2c clt
)
193 | PC.TMetaExpList
(_
,_
,_
,clt
) -> "explistmeta"^
(line_type2c clt
)
194 | PC.TMetaId
(_
,_
,_
,clt
) -> "idmeta"^
(line_type2c clt
)
195 | PC.TMetaType
(_
,_
,clt
) -> "typemeta"^
(line_type2c clt
)
196 | PC.TMetaInit
(_
,_
,clt
) -> "initmeta"^
(line_type2c clt
)
197 | PC.TMetaStm
(_
,_
,clt
) -> "stmmeta"^
(line_type2c clt
)
198 | PC.TMetaStmList
(_
,_
,clt
) -> "stmlistmeta"^
(line_type2c clt
)
199 | PC.TMetaFunc
(_
,_
,_
,clt
) -> "funcmeta"^
(line_type2c clt
)
200 | PC.TMetaLocalFunc
(_
,_
,_
,clt
) -> "funcmeta"^
(line_type2c clt
)
201 | PC.TMetaPos
(_
,_
,_
,clt
) -> "posmeta"
203 | PC.TArobArob
-> "@@"
206 | PC.TScript
-> "script"
207 | PC.TInitialize
-> "initialize"
208 | PC.TFinalize
-> "finalize"
210 | PC.TWhen
(clt
) -> "WHEN"^
(line_type2c clt
)
211 | PC.TWhenTrue
(clt
) -> "WHEN TRUE"^
(line_type2c clt
)
212 | PC.TWhenFalse
(clt
) -> "WHEN FALSE"^
(line_type2c clt
)
213 | PC.TAny
(clt
) -> "ANY"^
(line_type2c clt
)
214 | PC.TStrict
(clt
) -> "STRICT"^
(line_type2c clt
)
215 | PC.TEllipsis
(clt
) -> "..."^
(line_type2c clt
)
217 | PC.TCircles(clt) -> "ooo"^(line_type2c clt)
218 | PC.TStars(clt) -> "***"^(line_type2c clt)
221 | PC.TOEllipsis
(clt
) -> "<..."^
(line_type2c clt
)
222 | PC.TCEllipsis
(clt
) -> "...>"^
(line_type2c clt
)
223 | PC.TPOEllipsis
(clt
) -> "<+..."^
(line_type2c clt
)
224 | PC.TPCEllipsis
(clt
) -> "...+>"^
(line_type2c clt
)
226 | PC.TOCircles(clt) -> "<ooo"^(line_type2c clt)
227 | PC.TCCircles(clt) -> "ooo>"^(line_type2c clt)
228 | PC.TOStars(clt) -> "<***"^(line_type2c clt)
229 | PC.TCStars(clt) -> "***>"^(line_type2c clt)
235 | PC.TWhy
(clt
) -> "?"^
(line_type2c clt
)
236 | PC.TDotDot
(clt
) -> ":"^
(line_type2c clt
)
237 | PC.TBang
(clt
) -> "!"^
(line_type2c clt
)
238 | PC.TOPar
(clt
) -> "("^
(line_type2c clt
)
239 | PC.TOPar0
(clt
) -> "("^
(line_type2c clt
)
240 | PC.TMid0
(clt
) -> "|"^
(line_type2c clt
)
241 | PC.TCPar
(clt
) -> ")"^
(line_type2c clt
)
242 | PC.TCPar0
(clt
) -> ")"^
(line_type2c clt
)
244 | PC.TOBrace
(clt
) -> "{"^
(line_type2c clt
)
245 | PC.TCBrace
(clt
) -> "}"^
(line_type2c clt
)
246 | PC.TOCro
(clt
) -> "["^
(line_type2c clt
)
247 | PC.TCCro
(clt
) -> "]"^
(line_type2c clt
)
248 | PC.TOInit
(clt
) -> "{"^
(line_type2c clt
)
250 | PC.TPtrOp
(clt
) -> "->"^
(line_type2c clt
)
252 | PC.TEq
(clt
) -> "="^
(line_type2c clt
)
253 | PC.TAssign
(_
,clt
) -> "=op"^
(line_type2c clt
)
254 | PC.TDot
(clt
) -> "."^
(line_type2c clt
)
255 | PC.TComma
(clt
) -> ","^
(line_type2c clt
)
256 | PC.TPtVirg
(clt
) -> ";"^
(line_type2c clt
)
259 | PC.TLineEnd
(clt
) -> "line end"
260 | PC.TInvalid
-> "invalid"
261 | PC.TFunDecl
(clt
) -> "fundecl"
264 | PC.TRightIso
-> "=>"
265 | PC.TIsoTopLevel
-> "TopLevel"
266 | PC.TIsoExpression
-> "Expression"
267 | PC.TIsoArgExpression
-> "ArgExpression"
268 | PC.TIsoTestExpression
-> "TestExpression"
269 | PC.TIsoStatement
-> "Statement"
270 | PC.TIsoDeclaration
-> "Declaration"
271 | PC.TIsoType
-> "Type"
272 | PC.TScriptData s
-> s
274 let print_tokens s tokens
=
275 Printf.printf
"%s\n" s
;
276 List.iter
(function x
-> Printf.printf
"%s " (token2c x
)) tokens
;
277 Printf.printf
"\n\n";
280 type plus
= PLUS
| NOTPLUS
| SKIP
282 let plus_attachable only_plus
(tok
,_
) =
284 PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
285 | PC.Tfloat
(clt
) | PC.Tlong
(clt
) | PC.Tvoid
(clt
) | PC.Tstruct
(clt
)
286 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
288 | PC.Tinline
(clt
) | PC.Ttypedef
(clt
) | PC.Tattr
(_
,clt
)
289 | PC.Tauto
(clt
) | PC.Tregister
(clt
)
290 | PC.Textern
(clt
) | PC.Tconst
(clt
) | PC.Tvolatile
(clt
)
292 | PC.TIncludeL
(_
,clt
) | PC.TIncludeNL
(_
,clt
) | PC.TDefine
(clt
,_
)
293 | PC.TDefineParam
(clt
,_
,_
,_
) | PC.TMinusFile
(_
,clt
) | PC.TPlusFile
(_
,clt
)
295 | PC.TInc
(clt
) | PC.TDec
(clt
)
297 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
298 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
) | PC.TReturn
(clt
)
299 | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
) | PC.TIdent
(_
,clt
)
300 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
304 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
)
306 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
307 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TTildeEq
(clt
) | PC.TLogOp
(_
,clt
)
308 | PC.TShOp
(_
,clt
) | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
309 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
)
311 | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
312 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaErr
(_
,_
,_
,clt
)
313 | PC.TMetaExp
(_
,_
,_
,_
,clt
) | PC.TMetaIdExp
(_
,_
,_
,_
,clt
)
314 | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
315 | PC.TMetaExpList
(_
,_
,_
,clt
)
316 | PC.TMetaId
(_
,_
,_
,clt
)
317 | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
) | PC.TMetaStm
(_
,_
,clt
)
318 | PC.TMetaStmList
(_
,_
,clt
) | PC.TMetaFunc
(_
,_
,_
,clt
)
319 | PC.TMetaLocalFunc
(_
,_
,_
,clt
)
321 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
)
322 | PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TEllipsis
(clt
)
323 (* | PC.TCircles(clt) | PC.TStars(clt) *)
325 | PC.TWhy
(clt
) | PC.TDotDot
(clt
) | PC.TBang
(clt
) | PC.TOPar
(clt
)
328 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOCro
(clt
) | PC.TCCro
(clt
)
333 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
335 if List.mem
(line_type clt
) [D.PLUS
;D.PLUSPLUS
]
337 else if only_plus
then NOTPLUS
338 else if line_type clt
= D.CONTEXT
then PLUS
else NOTPLUS
340 | PC.TOPar0
(clt
) | PC.TMid0
(clt
) | PC.TCPar0
(clt
)
341 | PC.TOEllipsis
(clt
) | PC.TCEllipsis
(clt
)
342 | PC.TPOEllipsis
(clt
) | PC.TPCEllipsis
(clt
) (* | PC.TOCircles(clt)
343 | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *) -> NOTPLUS
344 | PC.TMetaPos
(nm
,_
,_
,_
) -> NOTPLUS
348 let get_clt (tok
,_
) =
350 PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
351 | PC.Tfloat
(clt
) | PC.Tlong
(clt
) | PC.Tvoid
(clt
) | PC.Tstruct
(clt
)
352 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
354 | PC.Tinline
(clt
) | PC.Tattr
(_
,clt
) | PC.Tauto
(clt
) | PC.Tregister
(clt
)
355 | PC.Textern
(clt
) | PC.Tconst
(clt
) | PC.Tvolatile
(clt
)
357 | PC.TIncludeL
(_
,clt
) | PC.TIncludeNL
(_
,clt
) | PC.TDefine
(clt
,_
)
358 | PC.TDefineParam
(clt
,_
,_
,_
) | PC.TMinusFile
(_
,clt
) | PC.TPlusFile
(_
,clt
)
360 | PC.TInc
(clt
) | PC.TDec
(clt
)
362 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
363 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
) | PC.TReturn
(clt
)
364 | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
) | PC.TIdent
(_
,clt
)
365 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
369 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
)
371 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
372 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TTildeEq
(clt
) | PC.TLogOp
(_
,clt
)
373 | PC.TShOp
(_
,clt
) | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
374 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
)
376 | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
377 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaErr
(_
,_
,_
,clt
)
378 | PC.TMetaExp
(_
,_
,_
,_
,clt
) | PC.TMetaIdExp
(_
,_
,_
,_
,clt
)
379 | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
380 | PC.TMetaExpList
(_
,_
,_
,clt
)
381 | PC.TMetaId
(_
,_
,_
,clt
)
382 | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
) | PC.TMetaStm
(_
,_
,clt
)
383 | PC.TMetaStmList
(_
,_
,clt
) | PC.TMetaFunc
(_
,_
,_
,clt
)
384 | PC.TMetaLocalFunc
(_
,_
,_
,clt
) | PC.TMetaPos
(_
,_
,_
,clt
)
386 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
) |
387 PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TEllipsis
(clt
)
388 (* | PC.TCircles(clt) | PC.TStars(clt) *)
390 | PC.TWhy
(clt
) | PC.TDotDot
(clt
) | PC.TBang
(clt
) | PC.TOPar
(clt
)
393 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOCro
(clt
) | PC.TCCro
(clt
)
398 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
401 | PC.TOPar0
(clt
) | PC.TMid0
(clt
) | PC.TCPar0
(clt
)
402 | PC.TOEllipsis
(clt
) | PC.TCEllipsis
(clt
)
403 | PC.TPOEllipsis
(clt
) | PC.TPCEllipsis
(clt
) (* | PC.TOCircles(clt)
404 | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *) -> clt
406 | _
-> failwith
"no clt"
408 let update_clt (tok
,x
) clt
=
410 PC.Tchar
(_
) -> (PC.Tchar
(clt
),x
)
411 | PC.Tshort
(_
) -> (PC.Tshort
(clt
),x
)
412 | PC.Tint
(_
) -> (PC.Tint
(clt
),x
)
413 | PC.Tdouble
(_
) -> (PC.Tdouble
(clt
),x
)
414 | PC.Tfloat
(_
) -> (PC.Tfloat
(clt
),x
)
415 | PC.Tlong
(_
) -> (PC.Tlong
(clt
),x
)
416 | PC.Tvoid
(_
) -> (PC.Tvoid
(clt
),x
)
417 | PC.Tstruct
(_
) -> (PC.Tstruct
(clt
),x
)
418 | PC.Tunion
(_
) -> (PC.Tunion
(clt
),x
)
419 | PC.Tenum
(_
) -> (PC.Tenum
(clt
),x
)
420 | PC.Tunsigned
(_
) -> (PC.Tunsigned
(clt
),x
)
421 | PC.Tsigned
(_
) -> (PC.Tsigned
(clt
),x
)
422 | PC.Tstatic
(_
) -> (PC.Tstatic
(clt
),x
)
423 | PC.Tinline
(_
) -> (PC.Tinline
(clt
),x
)
424 | PC.Ttypedef
(_
) -> (PC.Ttypedef
(clt
),x
)
425 | PC.Tattr
(s
,_
) -> (PC.Tattr
(s
,clt
),x
)
426 | PC.Tauto
(_
) -> (PC.Tauto
(clt
),x
)
427 | PC.Tregister
(_
) -> (PC.Tregister
(clt
),x
)
428 | PC.Textern
(_
) -> (PC.Textern
(clt
),x
)
429 | PC.Tconst
(_
) -> (PC.Tconst
(clt
),x
)
430 | PC.Tvolatile
(_
) -> (PC.Tvolatile
(clt
),x
)
432 | PC.TIncludeL
(s
,_
) -> (PC.TIncludeL
(s
,clt
),x
)
433 | PC.TIncludeNL
(s
,_
) -> (PC.TIncludeNL
(s
,clt
),x
)
434 | PC.TDefine
(_
,a
) -> (PC.TDefine
(clt
,a
),x
)
435 | PC.TDefineParam
(_
,a
,b
,c
) -> (PC.TDefineParam
(clt
,a
,b
,c
),x
)
436 | PC.TMinusFile
(s
,_
) -> (PC.TMinusFile
(s
,clt
),x
)
437 | PC.TPlusFile
(s
,_
) -> (PC.TPlusFile
(s
,clt
),x
)
439 | PC.TInc
(_
) -> (PC.TInc
(clt
),x
)
440 | PC.TDec
(_
) -> (PC.TDec
(clt
),x
)
442 | PC.TIf
(_
) -> (PC.TIf
(clt
),x
)
443 | PC.TElse
(_
) -> (PC.TElse
(clt
),x
)
444 | PC.TWhile
(_
) -> (PC.TWhile
(clt
),x
)
445 | PC.TFor
(_
) -> (PC.TFor
(clt
),x
)
446 | PC.TDo
(_
) -> (PC.TDo
(clt
),x
)
447 | PC.TSwitch
(_
) -> (PC.TSwitch
(clt
),x
)
448 | PC.TCase
(_
) -> (PC.TCase
(clt
),x
)
449 | PC.TDefault
(_
) -> (PC.TDefault
(clt
),x
)
450 | PC.TReturn
(_
) -> (PC.TReturn
(clt
),x
)
451 | PC.TBreak
(_
) -> (PC.TBreak
(clt
),x
)
452 | PC.TContinue
(_
) -> (PC.TContinue
(clt
),x
)
453 | PC.TGoto
(_
) -> (PC.TGoto
(clt
),x
)
454 | PC.TIdent
(s
,_
) -> (PC.TIdent
(s
,clt
),x
)
455 | PC.TTypeId
(s
,_
) -> (PC.TTypeId
(s
,clt
),x
)
456 | PC.TDeclarerId
(s
,_
) -> (PC.TDeclarerId
(s
,clt
),x
)
457 | PC.TIteratorId
(s
,_
) -> (PC.TIteratorId
(s
,clt
),x
)
459 | PC.TSizeof
(_
) -> (PC.TSizeof
(clt
),x
)
461 | PC.TString
(s
,_
) -> (PC.TString
(s
,clt
),x
)
462 | PC.TChar
(s
,_
) -> (PC.TChar
(s
,clt
),x
)
463 | PC.TFloat
(s
,_
) -> (PC.TFloat
(s
,clt
),x
)
464 | PC.TInt
(s
,_
) -> (PC.TInt
(s
,clt
),x
)
466 | PC.TOrLog
(_
) -> (PC.TOrLog
(clt
),x
)
467 | PC.TAndLog
(_
) -> (PC.TAndLog
(clt
),x
)
468 | PC.TOr
(_
) -> (PC.TOr
(clt
),x
)
469 | PC.TXor
(_
) -> (PC.TXor
(clt
),x
)
470 | PC.TAnd
(_
) -> (PC.TAnd
(clt
),x
)
471 | PC.TEqEq
(_
) -> (PC.TEqEq
(clt
),x
)
472 | PC.TNotEq
(_
) -> (PC.TNotEq
(clt
),x
)
473 | PC.TTildeEq
(_
) -> (PC.TTildeEq
(clt
),x
)
474 | PC.TLogOp
(op
,_
) -> (PC.TLogOp
(op
,clt
),x
)
475 | PC.TShOp
(op
,_
) -> (PC.TShOp
(op
,clt
),x
)
476 | PC.TPlus
(_
) -> (PC.TPlus
(clt
),x
)
477 | PC.TMinus
(_
) -> (PC.TMinus
(clt
),x
)
478 | PC.TMul
(_
) -> (PC.TMul
(clt
),x
)
479 | PC.TDmOp
(op
,_
) -> (PC.TDmOp
(op
,clt
),x
)
480 | PC.TTilde
(_
) -> (PC.TTilde
(clt
),x
)
482 | PC.TMetaParam
(a
,b
,_
) -> (PC.TMetaParam
(a
,b
,clt
),x
)
483 | PC.TMetaParamList
(a
,b
,c
,_
) -> (PC.TMetaParamList
(a
,b
,c
,clt
),x
)
484 | PC.TMetaConst
(a
,b
,c
,d
,_
) -> (PC.TMetaConst
(a
,b
,c
,d
,clt
),x
)
485 | PC.TMetaErr
(a
,b
,c
,_
) -> (PC.TMetaErr
(a
,b
,c
,clt
),x
)
486 | PC.TMetaExp
(a
,b
,c
,d
,_
) -> (PC.TMetaExp
(a
,b
,c
,d
,clt
),x
)
487 | PC.TMetaIdExp
(a
,b
,c
,d
,_
) -> (PC.TMetaIdExp
(a
,b
,c
,d
,clt
),x
)
488 | PC.TMetaLocalIdExp
(a
,b
,c
,d
,_
) -> (PC.TMetaLocalIdExp
(a
,b
,c
,d
,clt
),x
)
489 | PC.TMetaExpList
(a
,b
,c
,_
) -> (PC.TMetaExpList
(a
,b
,c
,clt
),x
)
490 | PC.TMetaId
(a
,b
,c
,_
) -> (PC.TMetaId
(a
,b
,c
,clt
),x
)
491 | PC.TMetaType
(a
,b
,_
) -> (PC.TMetaType
(a
,b
,clt
),x
)
492 | PC.TMetaInit
(a
,b
,_
) -> (PC.TMetaInit
(a
,b
,clt
),x
)
493 | PC.TMetaStm
(a
,b
,_
) -> (PC.TMetaStm
(a
,b
,clt
),x
)
494 | PC.TMetaStmList
(a
,b
,_
) -> (PC.TMetaStmList
(a
,b
,clt
),x
)
495 | PC.TMetaFunc
(a
,b
,c
,_
) -> (PC.TMetaFunc
(a
,b
,c
,clt
),x
)
496 | PC.TMetaLocalFunc
(a
,b
,c
,_
) -> (PC.TMetaLocalFunc
(a
,b
,c
,clt
),x
)
498 | PC.TWhen
(_
) -> (PC.TWhen
(clt
),x
)
499 | PC.TWhenTrue
(_
) -> (PC.TWhenTrue
(clt
),x
)
500 | PC.TWhenFalse
(_
) -> (PC.TWhenFalse
(clt
),x
)
501 | PC.TAny
(_
) -> (PC.TAny
(clt
),x
)
502 | PC.TStrict
(_
) -> (PC.TStrict
(clt
),x
)
503 | PC.TEllipsis
(_
) -> (PC.TEllipsis
(clt
),x
)
505 | PC.TCircles(_) -> (PC.TCircles(clt),x)
506 | PC.TStars(_) -> (PC.TStars(clt),x)
509 | PC.TOEllipsis
(_
) -> (PC.TOEllipsis
(clt
),x
)
510 | PC.TCEllipsis
(_
) -> (PC.TCEllipsis
(clt
),x
)
511 | PC.TPOEllipsis
(_
) -> (PC.TPOEllipsis
(clt
),x
)
512 | PC.TPCEllipsis
(_
) -> (PC.TPCEllipsis
(clt
),x
)
514 | PC.TOCircles(_) -> (PC.TOCircles(clt),x)
515 | PC.TCCircles(_) -> (PC.TCCircles(clt),x)
516 | PC.TOStars(_) -> (PC.TOStars(clt),x)
517 | PC.TCStars(_) -> (PC.TCStars(clt),x)
520 | PC.TWhy
(_
) -> (PC.TWhy
(clt
),x
)
521 | PC.TDotDot
(_
) -> (PC.TDotDot
(clt
),x
)
522 | PC.TBang
(_
) -> (PC.TBang
(clt
),x
)
523 | PC.TOPar
(_
) -> (PC.TOPar
(clt
),x
)
524 | PC.TOPar0
(_
) -> (PC.TOPar0
(clt
),x
)
525 | PC.TMid0
(_
) -> (PC.TMid0
(clt
),x
)
526 | PC.TCPar
(_
) -> (PC.TCPar
(clt
),x
)
527 | PC.TCPar0
(_
) -> (PC.TCPar0
(clt
),x
)
529 | PC.TOBrace
(_
) -> (PC.TOBrace
(clt
),x
)
530 | PC.TCBrace
(_
) -> (PC.TCBrace
(clt
),x
)
531 | PC.TOCro
(_
) -> (PC.TOCro
(clt
),x
)
532 | PC.TCCro
(_
) -> (PC.TCCro
(clt
),x
)
533 | PC.TOInit
(_
) -> (PC.TOInit
(clt
),x
)
535 | PC.TPtrOp
(_
) -> (PC.TPtrOp
(clt
),x
)
537 | PC.TEq
(_
) -> (PC.TEq
(clt
),x
)
538 | PC.TAssign
(s
,_
) -> (PC.TAssign
(s
,clt
),x
)
539 | PC.TDot
(_
) -> (PC.TDot
(clt
),x
)
540 | PC.TComma
(_
) -> (PC.TComma
(clt
),x
)
541 | PC.TPtVirg
(_
) -> (PC.TPtVirg
(clt
),x
)
543 | PC.TLineEnd
(_
) -> (PC.TLineEnd
(clt
),x
)
544 | PC.TFunDecl
(_
) -> (PC.TFunDecl
(clt
),x
)
546 | _
-> failwith
"no clt"
549 (* ----------------------------------------------------------------------- *)
551 let make_name prefix ln
= Printf.sprintf
"%s starting on line %d" prefix ln
553 (* ----------------------------------------------------------------------- *)
556 let wrap_lexbuf_info lexbuf
=
557 (Lexing.lexeme lexbuf
, Lexing.lexeme_start lexbuf
)
559 let tokens_all_full token table file get_ats lexbuf end_markers
:
560 (bool * ((PC.token
* (string * (int * int) * (int * int))) list
)) =
563 let result = token lexbuf
in
564 let info = (Lexing.lexeme lexbuf
,
565 (table
.(Lexing.lexeme_start lexbuf
)),
566 (Lexing.lexeme_start lexbuf
, Lexing.lexeme_end lexbuf
)) in
570 then failwith
"unexpected end of file in a metavariable declaration"
571 else (false,[(result,info)])
572 else if List.mem
result end_markers
573 then (true,[(result,info)])
575 let (more
,rest
) = aux() in
576 (more
,(result, info)::rest
)
579 e
-> pr2 (Common.error_message file
(wrap_lexbuf_info lexbuf
) ); raise e
581 let tokens_all table file get_ats lexbuf end_markers
:
582 (bool * ((PC.token
* (string * (int * int) * (int * int))) list
)) =
583 tokens_all_full Lexer_cocci.token table file get_ats lexbuf end_markers
585 let tokens_script_all table file get_ats lexbuf end_markers
:
586 (bool * ((PC.token
* (string * (int * int) * (int * int))) list
)) =
587 tokens_all_full Lexer_script.token table file get_ats lexbuf end_markers
589 (* ----------------------------------------------------------------------- *)
590 (* Split tokens into minus and plus fragments *)
593 let (d
,_
,_
,_
,_
,_
,_
,_
) = clt
in
595 D.MINUS
| D.OPTMINUS
| D.UNIQUEMINUS
-> ([t
],[])
596 | D.PLUS
| D.PLUSPLUS
-> ([],[t
])
597 | D.CONTEXT
| D.UNIQUE
| D.OPT
-> ([t
],[t
])
599 let split_token ((tok
,_
) as t
) =
601 PC.TIdentifier
| PC.TConstant
| PC.TExpression
| PC.TIdExpression
602 | PC.TStatement
| PC.TPosition
| PC.TPosAny
| PC.TInitialiser
603 | PC.TFunction
| PC.TTypedef
| PC.TDeclarer
| PC.TIterator
| PC.TName
604 | PC.TType
| PC.TParameter
| PC.TLocal
| PC.Tlist
| PC.TFresh
605 | PC.TCppConcatOp
| PC.TPure
606 | PC.TContext
| PC.TRuleName
(_
) | PC.TUsing
| PC.TVirtual
| PC.TDisable
607 | PC.TExtends
| PC.TPathIsoFile
(_
)
608 | PC.TDepends
| PC.TOn
| PC.TEver
| PC.TNever
| PC.TExists
| PC.TForall
609 | PC.TError
| PC.TWords
| PC.TGenerated
| PC.TNothing
-> ([t
],[t
])
611 | PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
612 | PC.Tfloat
(clt
) | PC.Tlong
(clt
) | PC.Tvoid
(clt
) | PC.Tstruct
(clt
)
613 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
614 | PC.Tstatic
(clt
) | PC.Tauto
(clt
) | PC.Tregister
(clt
) | PC.Textern
(clt
)
615 | PC.Tinline
(clt
) | PC.Ttypedef
(clt
) | PC.Tattr
(_
,clt
)
616 | PC.Tconst
(clt
) | PC.Tvolatile
(clt
) -> split t clt
618 | PC.TPragma
(s
,_
) -> ([],[t
]) (* only allowed in + *)
619 | PC.TPlusFile
(s
,clt
) | PC.TMinusFile
(s
,clt
)
620 | PC.TIncludeL
(s
,clt
) | PC.TIncludeNL
(s
,clt
) ->
622 | PC.TDefine
(clt
,_
) | PC.TDefineParam
(clt
,_
,_
,_
) -> split t clt
624 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
625 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
)
627 | PC.TReturn
(clt
) | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
)
629 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
630 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaExp
(_
,_
,_
,_
,clt
)
631 | PC.TMetaIdExp
(_
,_
,_
,_
,clt
) | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
632 | PC.TMetaExpList
(_
,_
,_
,clt
)
633 | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
634 | PC.TMetaId
(_
,_
,_
,clt
) | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
)
635 | PC.TMetaStm
(_
,_
,clt
) | PC.TMetaStmList
(_
,_
,clt
) | PC.TMetaErr
(_
,_
,_
,clt
)
636 | PC.TMetaFunc
(_
,_
,_
,clt
) | PC.TMetaLocalFunc
(_
,_
,_
,clt
)
637 | PC.TMetaDeclarer
(_
,_
,_
,clt
) | PC.TMetaIterator
(_
,_
,_
,clt
) -> split t clt
638 | PC.TMPtVirg
| PC.TArob
| PC.TArobArob
| PC.TScript
639 | PC.TInitialize
| PC.TFinalize
-> ([t
],[t
])
640 | PC.TPArob
| PC.TMetaPos
(_
,_
,_
,_
) -> ([t
],[])
643 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
)
644 | PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TLineEnd
(clt
)
645 | PC.TEllipsis
(clt
) (* | PC.TCircles(clt) | PC.TStars(clt) *) -> split t clt
647 | PC.TOEllipsis
(_
) | PC.TCEllipsis
(_
) (* clt must be context *)
648 | PC.TPOEllipsis
(_
) | PC.TPCEllipsis
(_
) (* clt must be context *)
650 | PC.TOCircles(_) | PC.TCCircles(_) (* clt must be context *)
651 | PC.TOStars
(_
) | PC.TCStars
(_
) (* clt must be context *)
653 | PC.TBang0
| PC.TPlus0
| PC.TWhy0
->
656 | PC.TWhy
(clt
) | PC.TDotDot
(clt
)
657 | PC.TBang
(clt
) | PC.TOPar
(clt
) | PC.TOPar0
(clt
)
658 | PC.TMid0
(clt
) | PC.TCPar
(clt
) | PC.TCPar0
(clt
) -> split t clt
660 | PC.TInc
(clt
) | PC.TDec
(clt
) -> split t clt
662 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
) ->
665 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
666 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TTildeEq
(clt
) | PC.TTildeExclEq
(clt
) | PC.TLogOp
(_
,clt
)
667 | PC.TShOp
(_
,clt
) | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
668 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
) -> split t clt
670 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOInit
(clt
) -> split t clt
671 | PC.TOCro
(clt
) | PC.TCCro
(clt
) -> split t clt
673 | PC.TPtrOp
(clt
) -> split t clt
675 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
676 | PC.TPtVirg
(clt
) -> split t clt
678 | PC.EOF
| PC.TInvalid
-> ([t
],[t
])
680 | PC.TIso
| PC.TRightIso
681 | PC.TIsoExpression
| PC.TIsoStatement
| PC.TIsoDeclaration
| PC.TIsoType
682 | PC.TIsoTopLevel
| PC.TIsoArgExpression
| PC.TIsoTestExpression
->
683 failwith
"unexpected tokens"
684 | PC.TScriptData s
-> ([t
],[t
])
686 let split_token_stream tokens
=
687 let rec loop = function
690 let (minus
,plus
) = split_token token
in
691 let (minus_stream
,plus_stream
) = loop tokens
in
692 (minus
@minus_stream
,plus
@plus_stream
) in
695 (* ----------------------------------------------------------------------- *)
696 (* Find function names *)
697 (* This addresses a shift-reduce problem in the parser, allowing us to
698 distinguish a function declaration from a function call even if the latter
699 has no return type. Undoubtedly, this is not very nice, but it doesn't
700 seem very convenient to refactor the grammar to get around the problem. *)
702 let rec find_function_names = function
704 | ((PC.TIdent
(_
,clt
),info) as t1
) :: ((PC.TOPar
(_
),_
) as t2
) :: rest
705 | ((PC.TMetaId
(_
,_
,_
,clt
),info) as t1
) :: ((PC.TOPar
(_
),_
) as t2
) :: rest
706 | ((PC.TMetaFunc
(_
,_
,_
,clt
),info) as t1
) :: ((PC.TOPar
(_
),_
) as t2
) :: rest
707 | ((PC.TMetaLocalFunc
(_
,_
,_
,clt
),info) as t1
)::((PC.TOPar
(_
),_
) as t2
)::rest
709 let rec skip level
= function
711 | ((PC.TCPar
(_
),_
) as t
)::rest
->
712 let level = level - 1 in
715 else let (pre
,found
,post
) = skip level rest
in (t
::pre
,found
,post
)
716 | ((PC.TOPar
(_
),_
) as t
)::rest
->
717 let level = level + 1 in
718 let (pre
,found
,post
) = skip level rest
in (t
::pre
,found
,post
)
719 | ((PC.TArobArob
,_
) as t
)::rest
720 | ((PC.TArob
,_
) as t
)::rest
721 | ((PC.EOF
,_
) as t
)::rest
-> ([t
],false,rest
)
723 let (pre
,found
,post
) = skip level rest
in (t
::pre
,found
,post
) in
724 let (pre
,found
,post
) = skip 1 rest
in
725 (match (found
,post
) with
726 (true,((PC.TOBrace
(_
),_
) as t3
)::rest
) ->
727 (PC.TFunDecl
(clt
),info) :: t1
:: t2
:: pre
@
728 t3
:: (find_function_names rest
)
729 | _
-> t1
:: t2
:: pre
@ find_function_names post
)
730 | t
:: rest
-> t
:: find_function_names rest
732 (* ----------------------------------------------------------------------- *)
733 (* an attribute is an identifier that preceeds another identifier and
736 let rec detect_attr l
=
738 (PC.TIdent
(_
,_
),_
) | (PC.TMetaId
(_
,_
,_
,_
),_
) | (PC.TMetaFunc
(_
,_
,_
,_
),_
)
739 | (PC.TMetaLocalFunc
(_
,_
,_
,_
),_
) -> true
741 let rec loop = function
744 | ((PC.TIdent
(nm
,clt
),info) as t1
)::id
::rest
when is_id id
->
745 if String.length nm
> 2 && String.sub nm
0 2 = "__"
746 then (PC.Tattr
(nm
,clt
),info)::(loop (id
::rest
))
747 else t1
::(loop (id
::rest
))
748 | x
::xs
-> x
::(loop xs
) in
751 (* ----------------------------------------------------------------------- *)
752 (* Look for variable declarations where the name is a typedef name.
753 We assume that C code does not contain a multiplication as a top-level
756 (* bug: once a type, always a type, even if the same name is later intended
757 to be used as a real identifier *)
758 let detect_types in_meta_decls l
=
759 let is_delim infn
= function
760 (PC.TOEllipsis
(_
),_
) (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *)
761 | (PC.TPOEllipsis
(_
),_
) (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *)
762 | (PC.TEllipsis
(_
),_
) (* | (PC.TCircles(_),_) | (PC.TStars(_),_) *)
763 | (PC.TPtVirg
(_
),_
) | (PC.TOBrace
(_
),_
) | (PC.TOInit
(_
),_
)
765 | (PC.TPure
,_
) | (PC.TContext
,_
)
766 | (PC.Tstatic
(_
),_
) | (PC.Textern
(_
),_
)
767 | (PC.Tinline
(_
),_
) | (PC.Ttypedef
(_
),_
) | (PC.Tattr
(_
),_
) -> true
768 | (PC.TComma
(_
),_
) when infn
> 0 or in_meta_decls
-> true
769 | (PC.TDotDot
(_
),_
) when in_meta_decls
-> true
771 let is_choices_delim = function
772 (PC.TOBrace
(_
),_
) | (PC.TComma
(_
),_
) -> true | _
-> false in
774 (PC.TIdent
(_
,_
),_
) | (PC.TMetaId
(_
,_
,_
,_
),_
) | (PC.TMetaFunc
(_
,_
,_
,_
),_
)
775 | (PC.TMetaLocalFunc
(_
,_
,_
,_
),_
) -> true
776 | (PC.TMetaParam
(_
,_
,_
),_
)
777 | (PC.TMetaParamList
(_
,_
,_
,_
),_
)
778 | (PC.TMetaConst
(_
,_
,_
,_
,_
),_
)
779 | (PC.TMetaErr
(_
,_
,_
,_
),_
)
780 | (PC.TMetaExp
(_
,_
,_
,_
,_
),_
)
781 | (PC.TMetaIdExp
(_
,_
,_
,_
,_
),_
)
782 | (PC.TMetaLocalIdExp
(_
,_
,_
,_
,_
),_
)
783 | (PC.TMetaExpList
(_
,_
,_
,_
),_
)
784 | (PC.TMetaType
(_
,_
,_
),_
)
785 | (PC.TMetaInit
(_
,_
,_
),_
)
786 | (PC.TMetaStm
(_
,_
,_
),_
)
787 | (PC.TMetaStmList
(_
,_
,_
),_
)
788 | (PC.TMetaPos
(_
,_
,_
,_
),_
) -> in_meta_decls
790 let redo_id ident clt v
=
791 !Data.add_type_name ident
;
792 (PC.TTypeId
(ident
,clt
),v
) in
793 let rec loop start infn type_names
= function
794 (* infn: 0 means not in a function header
795 > 0 means in a function header, after infn - 1 unmatched open parens*)
797 | ((PC.TOBrace
(clt
),v
)::_
) as all
when in_meta_decls
->
798 collect_choices type_names all
(* never a function header *)
799 | delim
::(PC.TIdent
(ident
,clt
),v
)::((PC.TMul
(_
),_
) as x
)::rest
800 when is_delim infn delim
->
801 let newid = redo_id ident clt v
in
802 delim
::newid::x
::(loop false infn
(ident
::type_names
) rest
)
803 | delim
::(PC.TIdent
(ident
,clt
),v
)::id
::rest
804 when is_delim infn delim
&& is_id id
->
805 let newid = redo_id ident clt v
in
806 delim
::newid::id
::(loop false infn
(ident
::type_names
) rest
)
807 | ((PC.TFunDecl
(_
),_
) as fn
)::rest
->
808 fn
::(loop false 1 type_names rest
)
809 | ((PC.TOPar
(_
),_
) as lp
)::rest
when infn
> 0 ->
810 lp
::(loop false (infn
+ 1) type_names rest
)
811 | ((PC.TCPar
(_
),_
) as rp
)::rest
when infn
> 0 ->
813 then rp
::(loop false 0 type_names rest
) (* 0 means not in fn header *)
814 else rp
::(loop false (infn
- 1) type_names rest
)
815 | (PC.TIdent
(ident
,clt
),v
)::((PC.TMul
(_
),_
) as x
)::rest
when start
->
816 let newid = redo_id ident clt v
in
817 newid::x
::(loop false infn
(ident
::type_names
) rest
)
818 | (PC.TIdent
(ident
,clt
),v
)::id
::rest
when start
&& is_id id
->
819 let newid = redo_id ident clt v
in
820 newid::id
::(loop false infn
(ident
::type_names
) rest
)
821 | (PC.TIdent
(ident
,clt
),v
)::rest
when List.mem ident type_names
->
822 (PC.TTypeId
(ident
,clt
),v
)::(loop false infn type_names rest
)
823 | ((PC.TIdent
(ident
,clt
),v
) as x
)::rest
->
824 x
::(loop false infn type_names rest
)
825 | x
::rest
-> x
::(loop false infn type_names rest
)
826 and collect_choices type_names
= function
827 [] -> [] (* should happen, but let the parser detect that *)
828 | (PC.TCBrace
(clt
),v
)::rest
->
829 (PC.TCBrace
(clt
),v
)::(loop false 0 type_names rest
)
830 | delim
::(PC.TIdent
(ident
,clt
),v
)::rest
831 when is_choices_delim delim
->
832 let newid = redo_id ident clt v
in
833 delim
::newid::(collect_choices
(ident
::type_names
) rest
)
834 | x
::rest
-> x
::(collect_choices type_names rest
) in
838 (* ----------------------------------------------------------------------- *)
839 (* Insert TLineEnd tokens at the end of a line that contains a WHEN.
840 WHEN is restricted to a single line, to avoid ambiguity in eg:
844 let token2line (tok
,_
) =
846 PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
847 | PC.Tfloat
(clt
) | PC.Tlong
(clt
) | PC.Tvoid
(clt
) | PC.Tstruct
(clt
)
848 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
849 | PC.Tstatic
(clt
) | PC.Tauto
(clt
) | PC.Tregister
(clt
) | PC.Textern
(clt
)
850 | PC.Tinline
(clt
) | PC.Ttypedef
(clt
) | PC.Tattr
(_
,clt
) | PC.Tconst
(clt
)
853 | PC.TInc
(clt
) | PC.TDec
(clt
)
855 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
856 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
) | PC.TSizeof
(clt
)
857 | PC.TReturn
(clt
) | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
)
859 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
860 | PC.TMetaDeclarer
(_
,_
,_
,clt
) | PC.TMetaIterator
(_
,_
,_
,clt
)
862 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
)
864 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
865 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TLogOp
(_
,clt
)
866 | PC.TShOp
(_
,clt
) | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
867 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
)
869 | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
870 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaExp
(_
,_
,_
,_
,clt
)
871 | PC.TMetaIdExp
(_
,_
,_
,_
,clt
) | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
872 | PC.TMetaExpList
(_
,_
,_
,clt
)
873 | PC.TMetaId
(_
,_
,_
,clt
) | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
)
874 | PC.TMetaStm
(_
,_
,clt
) | PC.TMetaStmList
(_
,_
,clt
) | PC.TMetaFunc
(_
,_
,_
,clt
)
875 | PC.TMetaLocalFunc
(_
,_
,_
,clt
) | PC.TMetaPos
(_
,_
,_
,clt
)
878 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
)
879 | PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TEllipsis
(clt
)
880 (* | PC.TCircles(clt) | PC.TStars(clt) *)
882 | PC.TOEllipsis
(clt
) | PC.TCEllipsis
(clt
)
883 | PC.TPOEllipsis
(clt
) | PC.TPCEllipsis
(clt
) (*| PC.TOCircles(clt)
884 | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *)
886 | PC.TWhy
(clt
) | PC.TDotDot
(clt
) | PC.TBang
(clt
) | PC.TOPar
(clt
)
887 | PC.TOPar0
(clt
) | PC.TMid0
(clt
) | PC.TCPar
(clt
)
890 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOCro
(clt
) | PC.TCCro
(clt
)
895 | PC.TDefine
(clt
,_
) | PC.TDefineParam
(clt
,_
,_
,_
)
896 | PC.TIncludeL
(_
,clt
) | PC.TIncludeNL
(_
,clt
)
898 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
900 let (_
,line
,_
,_
,_
,_
,_
,_
) = clt
in Some line
904 let rec insert_line_end = function
906 | (((PC.TWhen
(clt
),q
) as x
)::xs
) ->
907 x
::(find_line_end
true (token2line x
) clt q xs
)
908 | (((PC.TDefine
(clt
,_
),q
) as x
)::xs
)
909 | (((PC.TDefineParam
(clt
,_
,_
,_
),q
) as x
)::xs
) ->
910 x
::(find_line_end
false (token2line x
) clt q xs
)
911 | x
::xs
-> x
::(insert_line_end xs
)
913 and find_line_end inwhen line clt q
= function
914 (* don't know what 2nd component should be so just use the info of
915 the When. Also inherit - of when, if any *)
916 [] -> [(PC.TLineEnd
(clt
),q
)]
917 | ((PC.TIdent
("strict",clt
),a
) as x
)::xs
when token2line x
= line
->
918 (PC.TStrict
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
919 | ((PC.TIdent
("STRICT",clt
),a
) as x
)::xs
when token2line x
= line
->
920 (PC.TStrict
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
921 | ((PC.TIdent
("any",clt
),a
) as x
)::xs
when token2line x
= line
->
922 (PC.TAny
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
923 | ((PC.TIdent
("ANY",clt
),a
) as x
)::xs
when token2line x
= line
->
924 (PC.TAny
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
925 | ((PC.TIdent
("forall",clt
),a
) as x
)::xs
when token2line x
= line
->
926 (PC.TForall
,a
) :: (find_line_end inwhen line clt q xs
)
927 | ((PC.TIdent
("exists",clt
),a
) as x
)::xs
when token2line x
= line
->
928 (PC.TExists
,a
) :: (find_line_end inwhen line clt q xs
)
929 | ((PC.TComma
(clt
),a
) as x
)::xs
when token2line x
= line
->
930 (PC.TComma
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
931 | ((PC.TPArob
,a
) as x
)::xs
-> (* no line #, just assume on the same line *)
932 x
:: (find_line_end inwhen line clt q xs
)
933 | x
::xs
when token2line x
= line
-> x
:: (find_line_end inwhen line clt q xs
)
934 | xs
-> (PC.TLineEnd
(clt
),q
)::(insert_line_end xs
)
936 let rec translate_when_true_false = function
938 | (PC.TWhen
(clt
),q
)::((PC.TNotEq
(_
),_
) as x
)::(PC.TIdent
("true",_
),_
)::xs
->
939 (PC.TWhenTrue
(clt
),q
)::x
::(translate_when_true_false xs
)
940 | (PC.TWhen
(clt
),q
)::((PC.TNotEq
(_
),_
) as x
)::(PC.TIdent
("false",_
),_
)::xs
->
941 (PC.TWhenFalse
(clt
),q
)::x
::(translate_when_true_false xs
)
942 | x
::xs
-> x
:: (translate_when_true_false xs
)
944 (* ----------------------------------------------------------------------- *)
946 let check_parentheses tokens
=
947 let clt2line (_
,line
,_
,_
,_
,_
,_
,_
) = line
in
948 let rec loop seen_open
= function
950 | (PC.TOPar
(clt
),q
) :: rest
951 | (PC.TDefineParam
(clt
,_
,_
,_
),q
) :: rest
->
952 loop (Common.Left
(clt2line clt
) :: seen_open
) rest
953 | (PC.TOPar0
(clt
),q
) :: rest
->
954 loop (Common.Right
(clt2line clt
) :: seen_open
) rest
955 | (PC.TCPar
(clt
),q
) :: rest
->
956 (match seen_open
with
960 "unexpected close parenthesis in line %d\n" (clt2line clt
))
961 | Common.Left _
:: seen_open
-> loop seen_open rest
962 | Common.Right open_line
:: _
->
965 "disjunction parenthesis in line %d column 0 matched to normal parenthesis on line %d\n" open_line
(clt2line clt
)))
966 | (PC.TCPar0
(clt
),q
) :: rest
->
967 (match seen_open
with
971 "unexpected close parenthesis in line %d\n" (clt2line clt
))
972 | Common.Right _
:: seen_open
-> loop seen_open rest
973 | Common.Left open_line
:: _
->
976 "normal parenthesis in line %d matched to disjunction parenthesis on line %d column 0\n" open_line
(clt2line clt
)))
977 | x
::rest
-> loop seen_open rest
in
980 (* ----------------------------------------------------------------------- *)
981 (* top level initializers: a sequence of braces followed by a dot *)
983 let find_top_init tokens
=
985 (PC.TOBrace
(clt
),q
) :: rest
->
986 let rec dot_start acc
= function
987 ((PC.TOBrace
(_
),_
) as x
) :: rest
->
988 dot_start (x
::acc
) rest
989 | ((PC.TDot
(_
),_
) :: rest
) as x
->
990 Some
((PC.TOInit
(clt
),q
) :: (List.rev acc
) @ x
)
992 let rec comma_end acc
= function
993 ((PC.TCBrace
(_
),_
) as x
) :: rest
->
994 comma_end (x
::acc
) rest
995 | ((PC.TComma
(_
),_
) :: rest
) as x
->
996 Some
((PC.TOInit
(clt
),q
) :: (List.rev x
) @ acc
)
998 (match dot_start [] rest
with
1001 (match List.rev rest
with
1002 (* not super sure what this does, but EOF, @, and @@ should be
1003 the same, markind the end of a rule *)
1004 ((PC.EOF
,_
) as x
)::rest
| ((PC.TArob
,_
) as x
)::rest
1005 | ((PC.TArobArob
,_
) as x
)::rest
->
1006 (match comma_end [x
] rest
with
1010 failwith
"unexpected empty token list"))
1013 (* ----------------------------------------------------------------------- *)
1014 (* Integrate pragmas into some adjacent token. + tokens are preferred. Dots
1017 let rec collect_all_pragmas collected
= function
1018 (PC.TPragma
(s
,(_
,line
,logical_line
,offset
,col
,_
,_
,pos
)),_
)::rest
->
1020 { Ast0.line_start
= line
; Ast0.line_end
= line
;
1021 Ast0.logical_start
= logical_line
; Ast0.logical_end
= logical_line
;
1022 Ast0.column
= col
; Ast0.offset
= offset
; } in
1023 collect_all_pragmas ((s
,i)::collected
) rest
1024 | l
-> (List.rev collected
,l
)
1026 let rec collect_pass = function
1029 match plus_attachable false x
with
1031 let (pass
,rest
) = collect_pass xs
in
1035 let plus_attach strict
= function
1037 | Some x
-> plus_attachable strict x
1039 let add_bef = function Some x
-> [x
] | None
-> []
1041 (*skips should be things like line end
1042 skips is things before pragmas that can't be attached to, pass is things
1043 after. pass is used immediately. skips accumulates. *)
1044 let rec process_pragmas bef skips
= function
1045 [] -> add_bef bef
@ List.rev skips
1046 | ((PC.TPragma
(s
,i),_
)::_
) as l
->
1047 let (pragmas
,rest
) = collect_all_pragmas [] l
in
1048 let (pass
,rest0
) = collect_pass rest
in
1050 match rest0
with [] -> (None
,[]) | next
::rest
-> (Some next
,rest
) in
1051 (match (bef
,plus_attach true bef
,next
,plus_attach true next
) with
1052 (Some bef
,PLUS
,_
,_
) ->
1053 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt bef
in
1054 (update_clt bef
(a
,b
,c
,d
,e
,strbef
,pragmas
,pos
))::List.rev skips
@
1055 pass
@process_pragmas None
[] rest0
1056 | (_
,_
,Some next
,PLUS
) ->
1057 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt next
in
1058 (add_bef bef
) @ List.rev skips
@ pass
@
1060 (Some
(update_clt next
(a
,b
,c
,d
,e
,pragmas
,straft
,pos
)))
1063 (match (bef
,plus_attach false bef
,next
,plus_attach false next
) with
1064 (Some bef
,PLUS
,_
,_
) ->
1065 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt bef
in
1066 (update_clt bef
(a
,b
,c
,d
,e
,strbef
,pragmas
,pos
))::List.rev skips
@
1067 pass
@process_pragmas None
[] rest0
1068 | (_
,_
,Some next
,PLUS
) ->
1069 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt next
in
1070 (add_bef bef
) @ List.rev skips
@ pass
@
1072 (Some
(update_clt next
(a
,b
,c
,d
,e
,pragmas
,straft
,pos
)))
1074 | _
-> failwith
"nothing to attach pragma to"))
1076 (match plus_attachable false x
with
1077 SKIP
-> process_pragmas bef
(x
::skips
) xs
1078 | _
-> (add_bef bef
) @ List.rev skips
@ (process_pragmas (Some x
) [] xs
))
1080 (* ----------------------------------------------------------------------- *)
1081 (* Drop ... ... . This is only allowed in + code, and arises when there is
1082 some - code between the ... *)
1083 (* drop whens as well - they serve no purpose in + code and they cause
1084 problems for drop_double_dots *)
1086 let rec drop_when = function
1088 | (PC.TWhen
(clt
),info)::xs
->
1089 let rec loop = function
1091 | (PC.TLineEnd
(_
),info)::xs
-> drop_when xs
1092 | x
::xs
-> loop xs
in
1094 | x
::xs
-> x
::drop_when xs
1096 (* instead of dropping the double dots, we put TNothing in between them.
1097 these vanish after the parser, but keeping all the ...s in the + code makes
1098 it easier to align the + and - code in context_neg and in preparation for the
1099 isomorphisms. This shouldn't matter because the context code of the +
1100 slice is mostly ignored anyway *)
1101 let minus_to_nothing l
=
1102 (* for cases like | <..., which may or may not arise from removing minus
1103 code, depending on whether <... is a statement or expression *)
1106 let (d
,_
,_
,_
,_
,_
,_
,_
) = get_clt tok
in
1108 D.MINUS
| D.OPTMINUS
| D.UNIQUEMINUS
-> true
1109 | D.PLUS
| D.PLUSPLUS
-> false
1110 | D.CONTEXT
| D.UNIQUE
| D.OPT
-> false)
1112 let rec minus_loop = function
1114 | (d
::ds
) as l
-> if is_minus d
then minus_loop ds
else l
in
1115 let rec loop = function
1117 | ((PC.TMid0
(clt
),i) as x
)::t1
::ts
when is_minus t1
->
1118 (match minus_loop ts
with
1119 ((PC.TOEllipsis
(_
),_
)::_
) | ((PC.TPOEllipsis
(_
),_
)::_
)
1120 | ((PC.TEllipsis
(_
),_
)::_
) as l
-> x
::(PC.TNothing
,i)::(loop l
)
1122 | t
::ts
-> t
::(loop ts
) in
1125 let rec drop_double_dots l
=
1126 let start = function
1127 (PC.TOEllipsis
(_
),_
) | (PC.TPOEllipsis
(_
),_
)
1128 (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *) ->
1131 let middle = function
1132 (PC.TEllipsis
(_
),_
) (* | (PC.TCircles(_),_) | (PC.TStars(_),_) *) -> true
1134 let whenline = function
1135 (PC.TLineEnd
(_
),_
) -> true
1136 (*| (PC.TMid0(_),_) -> true*)
1138 let final = function
1139 (PC.TCEllipsis
(_
),_
) | (PC.TPCEllipsis
(_
),_
)
1140 (* | (PC.TCCircles(_),_) | (PC.TCStars(_),_) *) ->
1143 let any_before x
= start x
or middle x
or final x
or whenline x
in
1144 let any_after x
= start x
or middle x
or final x
in
1145 let rec loop ((_
,i) as prev
) = function
1147 | x
::rest
when any_before prev
&& any_after x
->
1148 (PC.TNothing
,i)::x
::(loop x rest
)
1149 | x
::rest
-> x
:: (loop x rest
) in
1152 | (x
::xs
) -> x
:: loop x xs
1156 if l
= cur then l
else fix f
cur
1158 (* ( | ... | ) also causes parsing problems *)
1162 let rec drop_empty_thing starter
middle ender
= function
1164 | hd
::rest
when starter hd
->
1165 let rec loop = function
1166 x
::rest
when middle x
-> loop rest
1167 | x
::rest
when ender x
-> rest
1168 | _
-> raise Not_empty
in
1169 (match try Some
(loop rest
) with Not_empty
-> None
with
1170 Some x
-> drop_empty_thing starter
middle ender x
1171 | None
-> hd
:: drop_empty_thing starter
middle ender rest
)
1172 | x
::rest
-> x
:: drop_empty_thing starter
middle ender rest
1176 (function (PC.TOPar0
(_
),_
) -> true | _
-> false)
1177 (function (PC.TMid0
(_
),_
) -> true | _
-> false)
1178 (function (PC.TCPar0
(_
),_
) -> true | _
-> false)
1180 let drop_empty_nest = drop_empty_thing
1182 (* ----------------------------------------------------------------------- *)
1185 let get_s_starts (_
, (s
,_
,(starts
, ends
))) =
1186 Printf.printf
"%d %d\n" starts ends
; (s
, starts
)
1189 let v = List.hd
!l
in
1194 PC.reinit (function _
-> PC.TArobArob
(* a handy token *))
1195 (Lexing.from_function
1196 (function buf
-> function n
-> raise
Common.Impossible
))
1198 let parse_one str parsefn file toks
=
1199 let all_tokens = ref toks
in
1200 let cur_tok = ref (List.hd
!all_tokens) in
1202 let lexer_function _
=
1203 let (v, info) = pop2 all_tokens in
1204 cur_tok := (v, info);
1208 Lexing.from_function
1209 (function buf
-> function n
-> raise
Common.Impossible
)
1214 try parsefn
lexer_function lexbuf_fake
1216 Lexer_cocci.Lexical s
->
1218 (Printf.sprintf
"%s: lexical error: %s\n =%s\n" str s
1219 (Common.error_message file
(get_s_starts !cur_tok) ))
1220 | Parser_cocci_menhir.Error
->
1222 (Printf.sprintf
"%s: parse error: \n = %s\n" str
1223 (Common.error_message file
(get_s_starts !cur_tok) ))
1224 | Semantic_cocci.Semantic s
->
1226 (Printf.sprintf
"%s: semantic error: %s\n =%s\n" str s
1227 (Common.error_message file
(get_s_starts !cur_tok) ))
1231 let prepare_tokens tokens
=
1233 (translate_when_true_false (* after insert_line_end *)
1236 (find_function_names (detect_attr (check_parentheses tokens
))))))
1238 let prepare_mv_tokens tokens
=
1239 detect_types false (detect_attr tokens
)
1241 let rec consume_minus_positions = function
1243 | ((PC.TOPar0
(_
),_
) as x
)::xs
| ((PC.TCPar0
(_
),_
) as x
)::xs
1244 | ((PC.TMid0
(_
),_
) as x
)::xs
-> x
::consume_minus_positions xs
1245 | x
::(PC.TPArob
,_
)::(PC.TMetaPos
(name
,constraints
,per
,clt
),_
)::xs
->
1246 let (arity
,ln
,lln
,offset
,col
,strbef
,straft
,_
) = get_clt x
in
1247 let name = Parse_aux.clt2mcode
name clt
in
1250 (arity
,ln
,lln
,offset
,col
,strbef
,straft
,
1251 Ast0.MetaPos
(name,constraints
,per
)) in
1252 x::(consume_minus_positions xs
)
1253 | x::xs
-> x::consume_minus_positions xs
1255 let any_modif rule
=
1257 match Ast0.get_mcode_mcodekind
x with
1258 Ast0.MINUS _
| Ast0.PLUS _
-> true
1260 let donothing r k e
= k e
in
1261 let bind x y
= x or y
in
1262 let option_default = false in
1264 V0.flat_combiner
bind option_default
1265 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1266 donothing donothing donothing donothing donothing donothing
1267 donothing donothing donothing donothing donothing donothing donothing
1268 donothing donothing in
1269 List.exists
fn.VT0.combiner_rec_top_level rule
1271 let eval_virt virt
=
1274 if not
(List.mem
x virt
)
1277 (Printf.sprintf
"unknown virtual rule %s\n" x))
1278 !Flag_parsing_cocci.defined_virtual_rules
1280 let drop_last extra l
= List.rev
(extra
@(List.tl
(List.rev l
)))
1282 let partition_either l
=
1283 let rec part_either left right
= function
1284 | [] -> (List.rev left
, List.rev right
)
1287 | Common.Left e
-> part_either (e
:: left
) right l
1288 | Common.Right e
-> part_either left
(e
:: right
) l
) in
1291 let get_metavars parse_fn table file lexbuf
=
1292 let rec meta_loop acc
(* read one decl at a time *) =
1296 tokens_all table file
true lexbuf
[PC.TArobArob
;PC.TMPtVirg
]) in
1297 let tokens = prepare_mv_tokens tokens in
1299 [(PC.TArobArob
,_
)] -> List.rev acc
1301 let metavars = parse_one "meta" parse_fn file
tokens in
1302 meta_loop (metavars@acc
) in
1303 partition_either (meta_loop [])
1305 let get_script_metavars parse_fn table file lexbuf
=
1306 let rec meta_loop acc
=
1308 tokens_all table file
true lexbuf
[PC.TArobArob
; PC.TMPtVirg
] in
1309 let tokens = prepare_tokens tokens in
1311 [(PC.TArobArob
, _
)] -> List.rev acc
1313 let metavar = parse_one "scriptmeta" parse_fn file
tokens in
1314 meta_loop (metavar :: acc
)
1318 let get_rule_name parse_fn starts_with_name get_tokens file prefix
=
1319 Data.in_rule_name
:= true;
1320 let mknm _
= make_name prefix
(!Lexer_cocci.line
) in
1324 let (_
,tokens) = get_tokens
[PC.TArob
] in
1325 let check_name = function
1326 None
-> Some
(mknm())
1328 (if List.mem nm
reserved_names
1329 then failwith
(Printf.sprintf
"invalid name %s\n" nm
));
1331 match parse_one "rule name" parse_fn file
tokens with
1332 Ast.CocciRulename
(nm
,a
,b
,c
,d
,e
) ->
1333 Ast.CocciRulename
(check_name nm
,a
,b
,c
,d
,e
)
1334 | Ast.GeneratedRulename
(nm
,a
,b
,c
,d
,e
) ->
1335 Ast.GeneratedRulename
(check_name nm
,a
,b
,c
,d
,e
)
1336 | Ast.ScriptRulename
(s
,deps
) -> Ast.ScriptRulename
(s
,deps
)
1337 | Ast.InitialScriptRulename
(s
) -> Ast.InitialScriptRulename
(s
)
1338 | Ast.FinalScriptRulename
(s
) -> Ast.FinalScriptRulename
(s
)
1340 Ast.CocciRulename
(Some
(mknm()),Ast.NoDep
,[],[],Ast.Undetermined
,false) in
1341 Data.in_rule_name
:= false;
1344 let parse_iso file
=
1345 let table = Common.full_charpos_to_pos file
in
1346 Common.with_open_infile file
(fun channel
->
1347 let lexbuf = Lexing.from_channel channel
in
1348 let get_tokens = tokens_all table file
false lexbuf in
1350 match get_tokens [PC.TArobArob
;PC.TArob
] with
1352 let parse_start start =
1353 let rev = List.rev start in
1354 let (arob
,_
) = List.hd
rev in
1355 (arob
= PC.TArob
,List.rev(List.tl
rev)) in
1356 let (starts_with_name
,start) = parse_start start in
1357 let rec loop starts_with_name
start =
1358 (!Data.init_rule
)();
1359 (* get metavariable declarations - have to be read before the
1361 let (rule_name
,_
,_
,_
,_
,_
) =
1362 match get_rule_name PC.iso_rule_name starts_with_name
get_tokens
1363 file
("iso file "^file
) with
1364 Ast.CocciRulename
(Some n
,a
,b
,c
,d
,e
) -> (n
,a
,b
,c
,d
,e
)
1365 | _
-> failwith
"Script rules cannot appear in isomorphism rules"
1367 Ast0.rule_name
:= rule_name
;
1369 match get_metavars PC.iso_meta_main
table file
lexbuf with
1370 (iso_metavars,[]) -> iso_metavars
1371 | _
-> failwith
"unexpected inheritance in iso" in
1375 [PC.TIsoStatement
;PC.TIsoExpression
;PC.TIsoArgExpression
;
1376 PC.TIsoTestExpression
;
1377 PC.TIsoDeclaration
;PC.TIsoType
;PC.TIsoTopLevel
] in
1378 let next_start = List.hd
(List.rev tokens) in
1379 let dummy_info = ("",(-1,-1),(-1,-1)) in
1380 let tokens = drop_last [(PC.EOF
,dummy_info)] tokens in
1381 let tokens = prepare_tokens (start@tokens) in
1383 print_tokens "iso tokens" tokens;
1385 let entry = parse_one "iso main" PC.iso_main file
tokens in
1386 let entry = List.map
(List.map
Test_exps.process_anything
) entry in
1388 then (* The code below allows a header like Statement list,
1389 which is more than one word. We don't have that any more,
1390 but the code is left here in case it is put back. *)
1391 match get_tokens [PC.TArobArob
;PC.TArob
] with
1393 let (starts_with_name
,start) = parse_start start in
1394 (iso_metavars,entry,rule_name
) ::
1395 (loop starts_with_name
(next_start::start))
1396 | _
-> failwith
"isomorphism ends early"
1397 else [(iso_metavars,entry,rule_name
)] in
1398 loop starts_with_name
start
1399 | (false,_
) -> [] in
1402 let parse_iso_files existing_isos iso_files extra_path
=
1403 let get_names = List.map
(function (_
,_
,nm
) -> nm
) in
1404 let old_names = get_names existing_isos
in
1405 Data.in_iso
:= true;
1408 (function (prev
,names
) ->
1410 Lexer_cocci.init
();
1413 Common.Left
(fl
) -> Filename.concat extra_path fl
1414 | Common.Right
(fl
) -> Filename.concat
Config.path fl
in
1415 let current = parse_iso file in
1416 let new_names = get_names current in
1417 if List.exists
(function x -> List.mem
x names
) new_names
1418 then failwith
(Printf.sprintf
"repeated iso name found in %s" file);
1419 (current::prev
,new_names @ names
))
1420 ([],old_names) iso_files
in
1421 Data.in_iso
:= false;
1422 existing_isos
@(List.concat
(List.rev res))
1424 (* None = dependency not satisfied
1425 Some dep = dependency satisfied or unknown and dep has virts optimized
1427 let eval_depend dep virt
=
1430 Ast.Dep req
| Ast.EverDep req
->
1431 if List.mem req virt
1433 if List.mem req
!Flag_parsing_cocci.defined_virtual_rules
1437 | Ast.AntiDep antireq
| Ast.NeverDep antireq
->
1438 if List.mem antireq virt
1440 if not
(List.mem antireq
!Flag_parsing_cocci.defined_virtual_rules
)
1444 | Ast.AndDep
(d1
,d2
) ->
1445 (match (loop d1
, loop d2
) with
1446 (None
,_
) | (_
,None
) -> None
1447 | (Some
Ast.NoDep
,x) | (x,Some
Ast.NoDep
) -> x
1448 | (Some
x,Some y
) -> Some
(Ast.AndDep
(x,y
)))
1449 | Ast.OrDep
(d1
,d2
) ->
1450 (match (loop d1
, loop d2
) with
1452 | (Some
Ast.NoDep
,x) | (x,Some
Ast.NoDep
) | (None
,x) | (x,None
) -> x
1453 | (Some
x,Some y
) -> Some
(Ast.OrDep
(x,y
)))
1454 | Ast.NoDep
| Ast.FailDep
-> Some dep
1458 let rec parse file =
1460 let table = Common.full_charpos_to_pos
file in
1461 Common.with_open_infile
file (fun channel
->
1462 let lexbuf = Lexing.from_channel channel
in
1463 let get_tokens = tokens_all table file false lexbuf in
1464 Data.in_prolog
:= true;
1465 let initial_tokens = get_tokens [PC.TArobArob
;PC.TArob
] in
1466 Data.in_prolog
:= false;
1468 match initial_tokens with
1470 (match List.rev data
with
1471 ((PC.TArobArob
as x),_
)::_
| ((PC.TArob
as x),_
)::_
->
1472 let include_and_iso_files =
1473 parse_one "include and iso file names" PC.include_main
file data
in
1475 let (include_files
,iso_files
,virt
) =
1477 (function (include_files
,iso_files
,virt
) ->
1479 Data.Include s
-> (s
::include_files
,iso_files
,virt
)
1480 | Data.Iso s
-> (include_files
,s
::iso_files
,virt
)
1481 | Data.Virt l
-> (include_files
,iso_files
,l
@virt
))
1482 ([],[],[]) include_and_iso_files in
1484 List.iter
(function x -> Hashtbl.add
Lexer_cocci.rule_names
x ())
1487 let (extra_iso_files
, extra_rules
, extra_virt
) =
1488 let rec loop = function
1491 let (x,y
,z
) = loop rest
in
1493 loop (List.map
parse include_files
) in
1495 let parse_cocci_rule ruletype old_metas
1496 (rule_name
, dependencies
, iso
, dropiso
, exists
, is_expression
) =
1497 Ast0.rule_name
:= rule_name
;
1498 Data.inheritable_positions
:=
1499 rule_name
:: !Data.inheritable_positions
;
1501 (* get metavariable declarations *)
1502 let (metavars, inherited_metavars
) =
1503 get_metavars PC.meta_main
table file lexbuf in
1504 Hashtbl.add
Data.all_metadecls rule_name
metavars;
1505 Hashtbl.add
Lexer_cocci.rule_names rule_name
();
1506 Hashtbl.add
Lexer_cocci.all_metavariables rule_name
1508 (fun key
v rest
-> (key
,v)::rest
)
1509 Lexer_cocci.metavariables
[]);
1511 (* get transformation rules *)
1512 let (more
, tokens) = get_tokens [PC.TArobArob
; PC.TArob
] in
1513 let (minus_tokens
, _
) = split_token_stream tokens in
1514 let (_
, plus_tokens
) =
1515 split_token_stream (minus_to_nothing tokens) in
1518 print_tokens "minus tokens" minus_tokens;
1519 print_tokens "plus tokens" plus_tokens;
1522 let minus_tokens = consume_minus_positions minus_tokens in
1523 let minus_tokens = prepare_tokens minus_tokens in
1524 let plus_tokens = prepare_tokens plus_tokens in
1527 print_tokens "minus tokens" minus_tokens;
1528 print_tokens "plus tokens" plus_tokens;
1532 process_pragmas None
[]
1533 (fix (function x -> drop_double_dots (drop_empty_or x))
1534 (drop_when plus_tokens)) in
1536 print_tokens "plus tokens" plus_tokens;
1537 Printf.printf "before minus parse\n";
1541 then parse_one "minus" PC.minus_exp_main
file minus_tokens
1542 else parse_one "minus" PC.minus_main
file minus_tokens in
1544 Unparse_ast0.unparse minus_res;
1545 Printf.printf "before plus parse\n";
1548 (* put ignore_patch_or_match with * case, which is less
1550 if !Flag.sgrep_mode2
or !D.ignore_patch_or_match
1551 then (* not actually used for anything, except context_neg *)
1553 (Iso_pattern.rebuild_mcode None
).VT0.rebuilder_rec_top_level
1557 then parse_one "plus" PC.plus_exp_main
file plus_tokens
1558 else parse_one "plus" PC.plus_main
file plus_tokens in
1560 Printf.printf "after plus parse\n";
1563 (if not
!Flag.sgrep_mode2
&&
1564 (any_modif minus_res or any_modif plus_res)
1565 then Data.inheritable_positions
:= []);
1567 Check_meta.check_meta rule_name old_metas inherited_metavars
1568 metavars minus_res plus_res;
1570 (more
, Ast0.CocciRule
((minus_res, metavars,
1571 (iso
, dropiso
, dependencies
, rule_name
, exists
)),
1572 (plus_res, metavars), ruletype
), metavars, tokens) in
1574 let rec collect_script_tokens = function
1575 [(PC.EOF
,_
)] | [(PC.TArobArob
,_
)] | [(PC.TArob
,_
)] -> ""
1576 | (PC.TScriptData
(s
),_
)::xs
-> s^
(collect_script_tokens xs
)
1580 Printf.printf
"%s\n" (token2c x))
1582 failwith
"Malformed script rule" in
1584 let parse_script_rule language old_metas deps
=
1585 let get_tokens = tokens_script_all table file false lexbuf in
1587 (* meta-variables *)
1591 get_script_metavars PC.script_meta_main
table file lexbuf) in
1593 let exists_in old_metas
(py
,(r
,m
)) =
1594 let test (rr
,mr
) x =
1595 let (ro
,vo
) = Ast.get_meta_name
x in
1596 ro
= rr
&& vo
= mr
in
1597 List.exists
(test (r
,m
)) old_metas
in
1601 let meta2c (r
,n
) = Printf.sprintf
"%s.%s" r n
in
1602 if not
(exists_in old_metas
x) then
1605 "Script references unknown meta-variable: %s"
1610 let (more
, tokens) = get_tokens [PC.TArobArob
; PC.TArob
] in
1611 let data = collect_script_tokens tokens in
1612 (more
,Ast0.ScriptRule
(language
, deps
, metavars, data),[],tokens) in
1614 let parse_if_script_rule k language
=
1615 let get_tokens = tokens_script_all table file false lexbuf in
1618 let (more
, tokens) = get_tokens [PC.TArobArob
; PC.TArob
] in
1619 let data = collect_script_tokens tokens in
1620 (more
,k
(language
, data),[],tokens) in
1622 let parse_iscript_rule =
1623 parse_if_script_rule
1624 (function (language
,data) ->
1625 Ast0.InitialScriptRule
(language
,data)) in
1627 let parse_fscript_rule =
1628 parse_if_script_rule
1629 (function (language
,data) ->
1630 Ast0.FinalScriptRule
(language
,data)) in
1632 let parse_rule old_metas starts_with_name
=
1634 get_rule_name PC.rule_name starts_with_name
get_tokens file
1637 Ast.CocciRulename
(Some s
, dep
, b
, c
, d
, e
) ->
1638 (match eval_depend dep virt
with
1640 parse_cocci_rule Ast.Normal old_metas
(s
,dep
,b
,c
,d
,e
)
1642 D.ignore_patch_or_match
:= true;
1644 parse_cocci_rule Ast.Normal old_metas
1645 (s
, Ast.FailDep
, b
, c
, d
, e
) in
1646 D.ignore_patch_or_match
:= false;
1648 | Ast.GeneratedRulename
(Some s
, dep
, b
, c
, d
, e
) ->
1649 (match eval_depend dep virt
with
1651 Data.in_generating
:= true;
1653 parse_cocci_rule Ast.Normal old_metas
(s
,dep
,b
,c
,d
,e
) in
1654 Data.in_generating
:= false;
1657 D.ignore_patch_or_match
:= true;
1658 Data.in_generating
:= true;
1660 parse_cocci_rule Ast.Normal old_metas
1661 (s
, Ast.FailDep
, b
, c
, d
, e
) in
1662 D.ignore_patch_or_match
:= false;
1663 Data.in_generating
:= false;
1665 | Ast.ScriptRulename
(l
,deps
) ->
1666 (match eval_depend deps virt
with
1667 Some deps
-> parse_script_rule l old_metas deps
1668 | None
-> parse_script_rule l old_metas
Ast.FailDep
)
1669 | Ast.InitialScriptRulename
(l
) -> parse_iscript_rule l
1670 | Ast.FinalScriptRulename
(l
) -> parse_fscript_rule l
1671 | _
-> failwith
"Malformed rule name" in
1673 let rec loop old_metas starts_with_name
=
1674 (!Data.init_rule
)();
1676 let gen_starts_with_name more
tokens =
1678 (match List.hd
(List.rev tokens) with
1679 (PC.TArobArob
,_
) -> false
1680 | (PC.TArob
,_
) -> true
1681 | _
-> failwith
"unexpected token")
1684 let (more
, rule
, metavars, tokens) =
1685 parse_rule old_metas starts_with_name
in
1688 (loop (metavars @ old_metas
) (gen_starts_with_name more
tokens))
1692 (function prev
-> function cur -> Common.union_set
cur prev
)
1693 iso_files extra_iso_files
,
1694 (* included rules first *)
1695 List.fold_left
(function prev
-> function cur -> cur@prev
)
1696 (loop [] (x = PC.TArob
)) (List.rev extra_rules
),
1697 List.fold_left
(@) virt extra_virt
(*no dups allowed*))
1698 | _
-> failwith
"unexpected code before the first rule\n")
1699 | (false,[(PC.TArobArob
,_
)]) | (false,[(PC.TArob
,_
)]) ->
1700 ([],([] : Ast0.parsed_rule list
),[] (*virtual rules*))
1701 | _
-> failwith
"unexpected code before the first rule\n" in
1704 (* parse to ast0 and then convert to ast *)
1705 let process file isofile verbose
=
1706 let extra_path = Filename.dirname
file in
1707 let (iso_files
, rules
, virt
) = parse file in
1712 | Some iso_file
-> parse_iso_files [] [Common.Left iso_file
] "" in
1713 let global_isos = parse_iso_files std_isos iso_files
extra_path in
1714 let rules = Unitary_ast0.do_unitary
rules in
1718 Ast0.ScriptRule
(a
,b
,c
,d
) -> [([],Ast.ScriptRule
(a
,b
,c
,d
))]
1719 | Ast0.InitialScriptRule
(a
,b
) -> [([],Ast.InitialScriptRule
(a
,b
))]
1720 | Ast0.FinalScriptRule
(a
,b
) -> [([],Ast.FinalScriptRule
(a
,b
))]
1723 (iso
, dropiso
, dependencies
, rule_name
, exists
)),
1724 (plus
, metavars),ruletype
) ->
1726 parse_iso_files global_isos
1727 (List.map
(function x -> Common.Left
x) iso
)
1730 (* check that dropped isos are actually available *)
1733 List.map
(function (_
,_
,nm
) -> nm
) chosen_isos in
1734 let local_iso_names = reserved_names @ iso_names in
1737 (function dropped
->
1738 not
(List.mem dropped
local_iso_names))
1741 ("invalid iso name " ^
bad_dropped ^
" in " ^ rule_name
)
1742 with Not_found
-> ());
1743 if List.mem
"all" dropiso
1745 if List.length dropiso
= 1
1747 else failwith
"disable all should only be by itself"
1748 else (* drop those isos *)
1750 (function (_
,_
,nm
) -> not
(List.mem nm dropiso
))
1752 List.iter
Iso_compile.process chosen_isos;
1754 match reserved_names with
1759 List.filter
(function x -> List.mem
x dropiso
) others
)
1762 "bad list of reserved names - all must be at start" in
1763 let minus = Test_exps.process minus in
1764 let minus = Compute_lines.compute_lines
false minus in
1765 let plus = Compute_lines.compute_lines
false plus in
1767 (* only relevant to Flag.make_hrule *)
1768 (* doesn't handle multiple minirules properly, but since
1769 we don't really handle them in lots of other ways, it
1770 doesn't seem very important *)
1774 [match Ast0.unwrap p
with
1776 (match List.map
Ast0.unwrap
(Ast0.undots c
) with
1777 [Ast0.Exp e
] -> true | _
-> false)
1779 let minus = Arity.minus_arity
minus in
1780 let ((metavars,minus),function_prototypes
) =
1781 Function_prototypes.process
1782 rule_name
metavars dropped_isos minus plus ruletype
in
1783 let plus = Adjust_pragmas.process plus in
1784 (* warning! context_neg side-effects its arguments *)
1785 let (m
,p
) = List.split (Context_neg.context_neg
minus plus) in
1786 Type_infer.type_infer p
;
1787 (if not
!Flag.sgrep_mode2
1788 then Insert_plus.insert_plus m p
(chosen_isos = []));
1789 Type_infer.type_infer
minus;
1790 let (extra_meta
, minus) =
1791 match (chosen_isos,ruletype
) with
1792 (* separate case for [] because applying isos puts
1793 some restrictions on the -+ code *)
1794 ([],_
) | (_
,Ast.Generated
) -> ([],minus)
1795 | _
-> Iso_pattern.apply_isos
chosen_isos minus rule_name
in
1796 (* after iso, because iso can intro ... *)
1797 let minus = Adjacency.compute_adjacency
minus in
1798 let minus = Comm_assoc.comm_assoc
minus rule_name dropiso
in
1800 if !Flag.sgrep_mode2
then minus
1801 else Single_statement.single_statement
minus in
1802 let minus = Simple_assignments.simple_assignments
minus in
1804 Ast0toast.ast0toast rule_name dependencies
dropped_isos
1805 exists
minus is_exp ruletype
in
1807 match function_prototypes
with
1808 None
-> [(extra_meta
@ metavars, minus_ast)]
1809 | Some mv_fp
-> [(extra_meta
@ metavars, minus_ast); mv_fp
])
1810 (* Ast0.CocciRule ((minus, metavarsm, (iso, dropiso, dependencies, rule_name, exists)), (plus, metavars))*)
1812 let parsed = List.concat
parsed in
1813 let disjd = Disjdistr.disj
parsed in
1815 let (metavars,code
,fvs
,neg_pos
,ua
,pos
) = Free_vars.free_vars
disjd in
1816 if !Flag_parsing_cocci.show_SP
1817 then List.iter
Pretty_print_cocci.unparse code
;
1820 Common.profile_code
"get_constants"
1821 (fun () -> Get_constants.get_constants code
) in (* for grep *)
1822 let glimpse_tokens2 =
1823 Common.profile_code
"get_glimpse_constants" (* for glimpse *)
1824 (fun () -> Get_constants2.get_constants code neg_pos
) in
1826 (metavars,code
,fvs
,neg_pos
,ua
,pos
,grep_tokens,glimpse_tokens2)