1 (* splits the entire file into minus and plus fragments, and parses each
2 separately (thus duplicating work for the parsing of the context elements) *)
5 module PC
= Parser_cocci_menhir
6 module V0
= Visitor_ast0
7 module VT0
= Visitor_ast0_types
9 module Ast0
= Ast0_cocci
10 let pr = Printf.sprintf
11 (*let pr2 s = prerr_string s; prerr_string "\n"; flush stderr*)
12 let pr2 s
= Printf.printf
"%s\n" s
14 (* for isomorphisms. all should be at the front!!! *)
16 ["all";"optional_storage";"optional_qualifier";"value_format";"comm_assoc"]
18 (* ----------------------------------------------------------------------- *)
21 let line_type (d
,_
,_
,_
,_
,_
,_
,_
) = d
24 match line_type tok
with
25 D.MINUS
| D.OPTMINUS
| D.UNIQUEMINUS
-> ":-"
28 | D.CONTEXT
| D.UNIQUE
| D.OPT
-> ""
32 PC.TIdentifier
-> "identifier"
34 | PC.TParameter
-> "parameter"
35 | PC.TConstant
-> "constant"
36 | PC.TExpression
-> "expression"
37 | PC.TIdExpression
-> "idexpression"
38 | PC.TInitialiser
-> "initialiser"
39 | PC.TStatement
-> "statement"
40 | PC.TPosition
-> "position"
42 | PC.TFunction
-> "function"
43 | PC.TLocal
-> "local"
45 | PC.TFresh
-> "fresh"
46 | PC.TCppConcatOp
-> "##"
48 | PC.TContext
-> "context"
49 | PC.TTypedef
-> "typedef"
50 | PC.TDeclarer
-> "declarer"
51 | PC.TIterator
-> "iterator"
53 | PC.TRuleName str
-> "rule_name-"^str
54 | PC.TUsing
-> "using"
55 | PC.TVirtual
-> "virtual"
56 | PC.TPathIsoFile str
-> "path_iso_file-"^str
57 | PC.TDisable
-> "disable"
58 | PC.TExtends
-> "extends"
59 | PC.TDepends
-> "depends"
62 | PC.TNever
-> "never"
63 | PC.TExists
-> "exists"
64 | PC.TForall
-> "forall"
65 | PC.TError
-> "error"
66 | PC.TWords
-> "words"
67 | PC.TGenerated
-> "generated"
69 | PC.TNothing
-> "nothing"
71 | PC.Tchar
(clt
) -> "char"^
(line_type2c clt
)
72 | PC.Tshort
(clt
) -> "short"^
(line_type2c clt
)
73 | PC.Tint
(clt
) -> "int"^
(line_type2c clt
)
74 | PC.Tdouble
(clt
) -> "double"^
(line_type2c clt
)
75 | PC.Tfloat
(clt
) -> "float"^
(line_type2c clt
)
76 | PC.Tlong
(clt
) -> "long"^
(line_type2c clt
)
77 | PC.Tvoid
(clt
) -> "void"^
(line_type2c clt
)
78 | PC.Tstruct
(clt
) -> "struct"^
(line_type2c clt
)
79 | PC.Tunion
(clt
) -> "union"^
(line_type2c clt
)
80 | PC.Tenum
(clt
) -> "enum"^
(line_type2c clt
)
81 | PC.Tunsigned
(clt
) -> "unsigned"^
(line_type2c clt
)
82 | PC.Tsigned
(clt
) -> "signed"^
(line_type2c clt
)
83 | PC.Tstatic
(clt
) -> "static"^
(line_type2c clt
)
84 | PC.Tinline
(clt
) -> "inline"^
(line_type2c clt
)
85 | PC.Ttypedef
(clt
) -> "typedef"^
(line_type2c clt
)
86 | PC.Tattr
(s
,clt
) -> s^
(line_type2c clt
)
87 | PC.Tauto
(clt
) -> "auto"^
(line_type2c clt
)
88 | PC.Tregister
(clt
) -> "register"^
(line_type2c clt
)
89 | PC.Textern
(clt
) -> "extern"^
(line_type2c clt
)
90 | PC.Tconst
(clt
) -> "const"^
(line_type2c clt
)
91 | PC.Tvolatile
(clt
) -> "volatile"^
(line_type2c clt
)
93 | PC.TPragma
(s
,_
) -> s
94 | PC.TIncludeL
(s
,clt
) -> (pr "#include \"%s\"" s
)^
(line_type2c clt
)
95 | PC.TIncludeNL
(s
,clt
) -> (pr "#include <%s>" s
)^
(line_type2c clt
)
96 | PC.TDefine
(clt
,_
) -> "#define"^
(line_type2c clt
)
97 | PC.TDefineParam
(clt
,_
,_
,_
) -> "#define_param"^
(line_type2c clt
)
98 | PC.TMinusFile
(s
,clt
) -> (pr "--- %s" s
)^
(line_type2c clt
)
99 | PC.TPlusFile
(s
,clt
) -> (pr "+++ %s" s
)^
(line_type2c clt
)
101 | PC.TInc
(clt
) -> "++"^
(line_type2c clt
)
102 | PC.TDec
(clt
) -> "--"^
(line_type2c clt
)
104 | PC.TIf
(clt
) -> "if"^
(line_type2c clt
)
105 | PC.TElse
(clt
) -> "else"^
(line_type2c clt
)
106 | PC.TWhile
(clt
) -> "while"^
(line_type2c clt
)
107 | PC.TFor
(clt
) -> "for"^
(line_type2c clt
)
108 | PC.TDo
(clt
) -> "do"^
(line_type2c clt
)
109 | PC.TSwitch
(clt
) -> "switch"^
(line_type2c clt
)
110 | PC.TCase
(clt
) -> "case"^
(line_type2c clt
)
111 | PC.TDefault
(clt
) -> "default"^
(line_type2c clt
)
112 | PC.TReturn
(clt
) -> "return"^
(line_type2c clt
)
113 | PC.TBreak
(clt
) -> "break"^
(line_type2c clt
)
114 | PC.TContinue
(clt
) -> "continue"^
(line_type2c clt
)
115 | PC.TGoto
(clt
) -> "goto"^
(line_type2c clt
)
116 | PC.TIdent
(s
,clt
) -> (pr "ident-%s" s
)^
(line_type2c clt
)
117 | PC.TTypeId
(s
,clt
) -> (pr "typename-%s" s
)^
(line_type2c clt
)
118 | PC.TDeclarerId
(s
,clt
) -> (pr "declarername-%s" s
)^
(line_type2c clt
)
119 | PC.TIteratorId
(s
,clt
) -> (pr "iteratorname-%s" s
)^
(line_type2c clt
)
120 | PC.TMetaDeclarer
(_
,_
,_
,clt
) -> "declmeta"^
(line_type2c clt
)
121 | PC.TMetaIterator
(_
,_
,_
,clt
) -> "itermeta"^
(line_type2c clt
)
123 | PC.TSizeof
(clt
) -> "sizeof"^
(line_type2c clt
)
125 | PC.TString
(x
,clt
) -> x^
(line_type2c clt
)
126 | PC.TChar
(x
,clt
) -> x^
(line_type2c clt
)
127 | PC.TFloat
(x
,clt
) -> x^
(line_type2c clt
)
128 | PC.TInt
(x
,clt
) -> x^
(line_type2c clt
)
130 | PC.TOrLog
(clt
) -> "||"^
(line_type2c clt
)
131 | PC.TAndLog
(clt
) -> "&&"^
(line_type2c clt
)
132 | PC.TOr
(clt
) -> "|"^
(line_type2c clt
)
133 | PC.TXor
(clt
) -> "^"^
(line_type2c clt
)
134 | PC.TAnd
(clt
) -> "&"^
(line_type2c clt
)
135 | PC.TEqEq
(clt
) -> "=="^
(line_type2c clt
)
136 | PC.TNotEq
(clt
) -> "!="^
(line_type2c clt
)
137 | PC.TTildeEq
(clt
) -> "~="^
(line_type2c clt
)
138 | PC.TTildeExclEq
(clt
) -> "~!="^
(line_type2c clt
)
139 | PC.TLogOp
(op
,clt
) ->
145 | _
-> failwith
"not possible")
147 | PC.TShOp
(op
,clt
) ->
150 | Ast.DecRight
-> ">>"
151 | _
-> failwith
"not possible")
153 | PC.TPlus
(clt
) -> "+"^
(line_type2c clt
)
154 | PC.TMinus
(clt
) -> "-"^
(line_type2c clt
)
155 | PC.TMul
(clt
) -> "*"^
(line_type2c clt
)
156 | PC.TDmOp
(op
,clt
) ->
160 | _
-> failwith
"not possible")
162 | PC.TTilde
(clt
) -> "~"^
(line_type2c clt
)
164 | PC.TMetaParam
(_
,_
,clt
) -> "parammeta"^
(line_type2c clt
)
165 | PC.TMetaParamList
(_
,_
,_
,clt
) -> "paramlistmeta"^
(line_type2c clt
)
166 | PC.TMetaConst
(_
,_
,_
,_
,clt
) -> "constmeta"^
(line_type2c clt
)
167 | PC.TMetaErr
(_
,_
,_
,clt
) -> "errmeta"^
(line_type2c clt
)
168 | PC.TMetaExp
(_
,_
,_
,_
,clt
) -> "expmeta"^
(line_type2c clt
)
169 | PC.TMetaIdExp
(_
,_
,_
,_
,clt
) -> "idexpmeta"^
(line_type2c clt
)
170 | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
) -> "localidexpmeta"^
(line_type2c clt
)
171 | PC.TMetaExpList
(_
,_
,_
,clt
) -> "explistmeta"^
(line_type2c clt
)
172 | PC.TMetaId
(_
,_
,_
,clt
) -> "idmeta"^
(line_type2c clt
)
173 | PC.TMetaType
(_
,_
,clt
) -> "typemeta"^
(line_type2c clt
)
174 | PC.TMetaInit
(_
,_
,clt
) -> "initmeta"^
(line_type2c clt
)
175 | PC.TMetaStm
(_
,_
,clt
) -> "stmmeta"^
(line_type2c clt
)
176 | PC.TMetaStmList
(_
,_
,clt
) -> "stmlistmeta"^
(line_type2c clt
)
177 | PC.TMetaFunc
(_
,_
,_
,clt
) -> "funcmeta"^
(line_type2c clt
)
178 | PC.TMetaLocalFunc
(_
,_
,_
,clt
) -> "funcmeta"^
(line_type2c clt
)
179 | PC.TMetaPos
(_
,_
,_
,clt
) -> "posmeta"
181 | PC.TArobArob
-> "@@"
184 | PC.TScript
-> "script"
185 | PC.TInitialize
-> "initialize"
186 | PC.TFinalize
-> "finalize"
188 | PC.TWhen
(clt
) -> "WHEN"^
(line_type2c clt
)
189 | PC.TWhenTrue
(clt
) -> "WHEN TRUE"^
(line_type2c clt
)
190 | PC.TWhenFalse
(clt
) -> "WHEN FALSE"^
(line_type2c clt
)
191 | PC.TAny
(clt
) -> "ANY"^
(line_type2c clt
)
192 | PC.TStrict
(clt
) -> "STRICT"^
(line_type2c clt
)
193 | PC.TEllipsis
(clt
) -> "..."^
(line_type2c clt
)
195 | PC.TCircles(clt) -> "ooo"^(line_type2c clt)
196 | PC.TStars(clt) -> "***"^(line_type2c clt)
199 | PC.TOEllipsis
(clt
) -> "<..."^
(line_type2c clt
)
200 | PC.TCEllipsis
(clt
) -> "...>"^
(line_type2c clt
)
201 | PC.TPOEllipsis
(clt
) -> "<+..."^
(line_type2c clt
)
202 | PC.TPCEllipsis
(clt
) -> "...+>"^
(line_type2c clt
)
204 | PC.TOCircles(clt) -> "<ooo"^(line_type2c clt)
205 | PC.TCCircles(clt) -> "ooo>"^(line_type2c clt)
206 | PC.TOStars(clt) -> "<***"^(line_type2c clt)
207 | PC.TCStars(clt) -> "***>"^(line_type2c clt)
213 | PC.TWhy
(clt
) -> "?"^
(line_type2c clt
)
214 | PC.TDotDot
(clt
) -> ":"^
(line_type2c clt
)
215 | PC.TBang
(clt
) -> "!"^
(line_type2c clt
)
216 | PC.TOPar
(clt
) -> "("^
(line_type2c clt
)
217 | PC.TOPar0
(clt
) -> "("^
(line_type2c clt
)
218 | PC.TMid0
(clt
) -> "|"^
(line_type2c clt
)
219 | PC.TCPar
(clt
) -> ")"^
(line_type2c clt
)
220 | PC.TCPar0
(clt
) -> ")"^
(line_type2c clt
)
222 | PC.TOBrace
(clt
) -> "{"^
(line_type2c clt
)
223 | PC.TCBrace
(clt
) -> "}"^
(line_type2c clt
)
224 | PC.TOCro
(clt
) -> "["^
(line_type2c clt
)
225 | PC.TCCro
(clt
) -> "]"^
(line_type2c clt
)
226 | PC.TOInit
(clt
) -> "{"^
(line_type2c clt
)
228 | PC.TPtrOp
(clt
) -> "->"^
(line_type2c clt
)
230 | PC.TEq
(clt
) -> "="^
(line_type2c clt
)
231 | PC.TAssign
(_
,clt
) -> "=op"^
(line_type2c clt
)
232 | PC.TDot
(clt
) -> "."^
(line_type2c clt
)
233 | PC.TComma
(clt
) -> ","^
(line_type2c clt
)
234 | PC.TPtVirg
(clt
) -> ";"^
(line_type2c clt
)
237 | PC.TLineEnd
(clt
) -> "line end"
238 | PC.TInvalid
-> "invalid"
239 | PC.TFunDecl
(clt
) -> "fundecl"
242 | PC.TRightIso
-> "=>"
243 | PC.TIsoTopLevel
-> "TopLevel"
244 | PC.TIsoExpression
-> "Expression"
245 | PC.TIsoArgExpression
-> "ArgExpression"
246 | PC.TIsoTestExpression
-> "TestExpression"
247 | PC.TIsoStatement
-> "Statement"
248 | PC.TIsoDeclaration
-> "Declaration"
249 | PC.TIsoType
-> "Type"
250 | PC.TScriptData s
-> s
252 let print_tokens s tokens
=
253 Printf.printf
"%s\n" s
;
254 List.iter
(function x
-> Printf.printf
"%s " (token2c x
)) tokens
;
255 Printf.printf
"\n\n";
258 type plus
= PLUS
| NOTPLUS
| SKIP
260 let plus_attachable only_plus
(tok
,_
) =
262 PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
263 | PC.Tfloat
(clt
) | PC.Tlong
(clt
) | PC.Tvoid
(clt
) | PC.Tstruct
(clt
)
264 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
266 | PC.Tinline
(clt
) | PC.Ttypedef
(clt
) | PC.Tattr
(_
,clt
)
267 | PC.Tauto
(clt
) | PC.Tregister
(clt
)
268 | PC.Textern
(clt
) | PC.Tconst
(clt
) | PC.Tvolatile
(clt
)
270 | PC.TIncludeL
(_
,clt
) | PC.TIncludeNL
(_
,clt
) | PC.TDefine
(clt
,_
)
271 | PC.TDefineParam
(clt
,_
,_
,_
) | PC.TMinusFile
(_
,clt
) | PC.TPlusFile
(_
,clt
)
273 | PC.TInc
(clt
) | PC.TDec
(clt
)
275 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
276 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
) | PC.TReturn
(clt
)
277 | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
) | PC.TIdent
(_
,clt
)
278 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
282 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
)
284 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
285 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TTildeEq
(clt
) | PC.TLogOp
(_
,clt
)
286 | PC.TShOp
(_
,clt
) | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
287 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
)
289 | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
290 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaErr
(_
,_
,_
,clt
)
291 | PC.TMetaExp
(_
,_
,_
,_
,clt
) | PC.TMetaIdExp
(_
,_
,_
,_
,clt
)
292 | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
293 | PC.TMetaExpList
(_
,_
,_
,clt
)
294 | PC.TMetaId
(_
,_
,_
,clt
)
295 | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
) | PC.TMetaStm
(_
,_
,clt
)
296 | PC.TMetaStmList
(_
,_
,clt
) | PC.TMetaFunc
(_
,_
,_
,clt
)
297 | PC.TMetaLocalFunc
(_
,_
,_
,clt
)
299 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
)
300 | PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TEllipsis
(clt
)
301 (* | PC.TCircles(clt) | PC.TStars(clt) *)
303 | PC.TWhy
(clt
) | PC.TDotDot
(clt
) | PC.TBang
(clt
) | PC.TOPar
(clt
)
306 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOCro
(clt
) | PC.TCCro
(clt
)
311 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
313 if List.mem
(line_type clt
) [D.PLUS
;D.PLUSPLUS
]
315 else if only_plus
then NOTPLUS
316 else if line_type clt
= D.CONTEXT
then PLUS
else NOTPLUS
318 | PC.TOPar0
(clt
) | PC.TMid0
(clt
) | PC.TCPar0
(clt
)
319 | PC.TOEllipsis
(clt
) | PC.TCEllipsis
(clt
)
320 | PC.TPOEllipsis
(clt
) | PC.TPCEllipsis
(clt
) (* | PC.TOCircles(clt)
321 | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *) -> NOTPLUS
322 | PC.TMetaPos
(nm
,_
,_
,_
) -> NOTPLUS
326 let get_clt (tok
,_
) =
328 PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
329 | PC.Tfloat
(clt
) | PC.Tlong
(clt
) | PC.Tvoid
(clt
) | PC.Tstruct
(clt
)
330 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
332 | PC.Tinline
(clt
) | PC.Tattr
(_
,clt
) | PC.Tauto
(clt
) | PC.Tregister
(clt
)
333 | PC.Textern
(clt
) | PC.Tconst
(clt
) | PC.Tvolatile
(clt
)
335 | PC.TIncludeL
(_
,clt
) | PC.TIncludeNL
(_
,clt
) | PC.TDefine
(clt
,_
)
336 | PC.TDefineParam
(clt
,_
,_
,_
) | PC.TMinusFile
(_
,clt
) | PC.TPlusFile
(_
,clt
)
338 | PC.TInc
(clt
) | PC.TDec
(clt
)
340 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
341 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
) | PC.TReturn
(clt
)
342 | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
) | PC.TIdent
(_
,clt
)
343 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
347 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
)
349 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
350 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TTildeEq
(clt
) | PC.TLogOp
(_
,clt
)
351 | PC.TShOp
(_
,clt
) | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
352 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
)
354 | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
355 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaErr
(_
,_
,_
,clt
)
356 | PC.TMetaExp
(_
,_
,_
,_
,clt
) | PC.TMetaIdExp
(_
,_
,_
,_
,clt
)
357 | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
358 | PC.TMetaExpList
(_
,_
,_
,clt
)
359 | PC.TMetaId
(_
,_
,_
,clt
)
360 | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
) | PC.TMetaStm
(_
,_
,clt
)
361 | PC.TMetaStmList
(_
,_
,clt
) | PC.TMetaFunc
(_
,_
,_
,clt
)
362 | PC.TMetaLocalFunc
(_
,_
,_
,clt
) | PC.TMetaPos
(_
,_
,_
,clt
)
364 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
) |
365 PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TEllipsis
(clt
)
366 (* | PC.TCircles(clt) | PC.TStars(clt) *)
368 | PC.TWhy
(clt
) | PC.TDotDot
(clt
) | PC.TBang
(clt
) | PC.TOPar
(clt
)
371 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOCro
(clt
) | PC.TCCro
(clt
)
376 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
379 | PC.TOPar0
(clt
) | PC.TMid0
(clt
) | PC.TCPar0
(clt
)
380 | PC.TOEllipsis
(clt
) | PC.TCEllipsis
(clt
)
381 | PC.TPOEllipsis
(clt
) | PC.TPCEllipsis
(clt
) (* | PC.TOCircles(clt)
382 | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *) -> clt
384 | _
-> failwith
"no clt"
386 let update_clt (tok
,x
) clt
=
388 PC.Tchar
(_
) -> (PC.Tchar
(clt
),x
)
389 | PC.Tshort
(_
) -> (PC.Tshort
(clt
),x
)
390 | PC.Tint
(_
) -> (PC.Tint
(clt
),x
)
391 | PC.Tdouble
(_
) -> (PC.Tdouble
(clt
),x
)
392 | PC.Tfloat
(_
) -> (PC.Tfloat
(clt
),x
)
393 | PC.Tlong
(_
) -> (PC.Tlong
(clt
),x
)
394 | PC.Tvoid
(_
) -> (PC.Tvoid
(clt
),x
)
395 | PC.Tstruct
(_
) -> (PC.Tstruct
(clt
),x
)
396 | PC.Tunion
(_
) -> (PC.Tunion
(clt
),x
)
397 | PC.Tenum
(_
) -> (PC.Tenum
(clt
),x
)
398 | PC.Tunsigned
(_
) -> (PC.Tunsigned
(clt
),x
)
399 | PC.Tsigned
(_
) -> (PC.Tsigned
(clt
),x
)
400 | PC.Tstatic
(_
) -> (PC.Tstatic
(clt
),x
)
401 | PC.Tinline
(_
) -> (PC.Tinline
(clt
),x
)
402 | PC.Ttypedef
(_
) -> (PC.Ttypedef
(clt
),x
)
403 | PC.Tattr
(s
,_
) -> (PC.Tattr
(s
,clt
),x
)
404 | PC.Tauto
(_
) -> (PC.Tauto
(clt
),x
)
405 | PC.Tregister
(_
) -> (PC.Tregister
(clt
),x
)
406 | PC.Textern
(_
) -> (PC.Textern
(clt
),x
)
407 | PC.Tconst
(_
) -> (PC.Tconst
(clt
),x
)
408 | PC.Tvolatile
(_
) -> (PC.Tvolatile
(clt
),x
)
410 | PC.TIncludeL
(s
,_
) -> (PC.TIncludeL
(s
,clt
),x
)
411 | PC.TIncludeNL
(s
,_
) -> (PC.TIncludeNL
(s
,clt
),x
)
412 | PC.TDefine
(_
,a
) -> (PC.TDefine
(clt
,a
),x
)
413 | PC.TDefineParam
(_
,a
,b
,c
) -> (PC.TDefineParam
(clt
,a
,b
,c
),x
)
414 | PC.TMinusFile
(s
,_
) -> (PC.TMinusFile
(s
,clt
),x
)
415 | PC.TPlusFile
(s
,_
) -> (PC.TPlusFile
(s
,clt
),x
)
417 | PC.TInc
(_
) -> (PC.TInc
(clt
),x
)
418 | PC.TDec
(_
) -> (PC.TDec
(clt
),x
)
420 | PC.TIf
(_
) -> (PC.TIf
(clt
),x
)
421 | PC.TElse
(_
) -> (PC.TElse
(clt
),x
)
422 | PC.TWhile
(_
) -> (PC.TWhile
(clt
),x
)
423 | PC.TFor
(_
) -> (PC.TFor
(clt
),x
)
424 | PC.TDo
(_
) -> (PC.TDo
(clt
),x
)
425 | PC.TSwitch
(_
) -> (PC.TSwitch
(clt
),x
)
426 | PC.TCase
(_
) -> (PC.TCase
(clt
),x
)
427 | PC.TDefault
(_
) -> (PC.TDefault
(clt
),x
)
428 | PC.TReturn
(_
) -> (PC.TReturn
(clt
),x
)
429 | PC.TBreak
(_
) -> (PC.TBreak
(clt
),x
)
430 | PC.TContinue
(_
) -> (PC.TContinue
(clt
),x
)
431 | PC.TGoto
(_
) -> (PC.TGoto
(clt
),x
)
432 | PC.TIdent
(s
,_
) -> (PC.TIdent
(s
,clt
),x
)
433 | PC.TTypeId
(s
,_
) -> (PC.TTypeId
(s
,clt
),x
)
434 | PC.TDeclarerId
(s
,_
) -> (PC.TDeclarerId
(s
,clt
),x
)
435 | PC.TIteratorId
(s
,_
) -> (PC.TIteratorId
(s
,clt
),x
)
437 | PC.TSizeof
(_
) -> (PC.TSizeof
(clt
),x
)
439 | PC.TString
(s
,_
) -> (PC.TString
(s
,clt
),x
)
440 | PC.TChar
(s
,_
) -> (PC.TChar
(s
,clt
),x
)
441 | PC.TFloat
(s
,_
) -> (PC.TFloat
(s
,clt
),x
)
442 | PC.TInt
(s
,_
) -> (PC.TInt
(s
,clt
),x
)
444 | PC.TOrLog
(_
) -> (PC.TOrLog
(clt
),x
)
445 | PC.TAndLog
(_
) -> (PC.TAndLog
(clt
),x
)
446 | PC.TOr
(_
) -> (PC.TOr
(clt
),x
)
447 | PC.TXor
(_
) -> (PC.TXor
(clt
),x
)
448 | PC.TAnd
(_
) -> (PC.TAnd
(clt
),x
)
449 | PC.TEqEq
(_
) -> (PC.TEqEq
(clt
),x
)
450 | PC.TNotEq
(_
) -> (PC.TNotEq
(clt
),x
)
451 | PC.TTildeEq
(_
) -> (PC.TTildeEq
(clt
),x
)
452 | PC.TLogOp
(op
,_
) -> (PC.TLogOp
(op
,clt
),x
)
453 | PC.TShOp
(op
,_
) -> (PC.TShOp
(op
,clt
),x
)
454 | PC.TPlus
(_
) -> (PC.TPlus
(clt
),x
)
455 | PC.TMinus
(_
) -> (PC.TMinus
(clt
),x
)
456 | PC.TMul
(_
) -> (PC.TMul
(clt
),x
)
457 | PC.TDmOp
(op
,_
) -> (PC.TDmOp
(op
,clt
),x
)
458 | PC.TTilde
(_
) -> (PC.TTilde
(clt
),x
)
460 | PC.TMetaParam
(a
,b
,_
) -> (PC.TMetaParam
(a
,b
,clt
),x
)
461 | PC.TMetaParamList
(a
,b
,c
,_
) -> (PC.TMetaParamList
(a
,b
,c
,clt
),x
)
462 | PC.TMetaConst
(a
,b
,c
,d
,_
) -> (PC.TMetaConst
(a
,b
,c
,d
,clt
),x
)
463 | PC.TMetaErr
(a
,b
,c
,_
) -> (PC.TMetaErr
(a
,b
,c
,clt
),x
)
464 | PC.TMetaExp
(a
,b
,c
,d
,_
) -> (PC.TMetaExp
(a
,b
,c
,d
,clt
),x
)
465 | PC.TMetaIdExp
(a
,b
,c
,d
,_
) -> (PC.TMetaIdExp
(a
,b
,c
,d
,clt
),x
)
466 | PC.TMetaLocalIdExp
(a
,b
,c
,d
,_
) -> (PC.TMetaLocalIdExp
(a
,b
,c
,d
,clt
),x
)
467 | PC.TMetaExpList
(a
,b
,c
,_
) -> (PC.TMetaExpList
(a
,b
,c
,clt
),x
)
468 | PC.TMetaId
(a
,b
,c
,_
) -> (PC.TMetaId
(a
,b
,c
,clt
),x
)
469 | PC.TMetaType
(a
,b
,_
) -> (PC.TMetaType
(a
,b
,clt
),x
)
470 | PC.TMetaInit
(a
,b
,_
) -> (PC.TMetaInit
(a
,b
,clt
),x
)
471 | PC.TMetaStm
(a
,b
,_
) -> (PC.TMetaStm
(a
,b
,clt
),x
)
472 | PC.TMetaStmList
(a
,b
,_
) -> (PC.TMetaStmList
(a
,b
,clt
),x
)
473 | PC.TMetaFunc
(a
,b
,c
,_
) -> (PC.TMetaFunc
(a
,b
,c
,clt
),x
)
474 | PC.TMetaLocalFunc
(a
,b
,c
,_
) -> (PC.TMetaLocalFunc
(a
,b
,c
,clt
),x
)
476 | PC.TWhen
(_
) -> (PC.TWhen
(clt
),x
)
477 | PC.TWhenTrue
(_
) -> (PC.TWhenTrue
(clt
),x
)
478 | PC.TWhenFalse
(_
) -> (PC.TWhenFalse
(clt
),x
)
479 | PC.TAny
(_
) -> (PC.TAny
(clt
),x
)
480 | PC.TStrict
(_
) -> (PC.TStrict
(clt
),x
)
481 | PC.TEllipsis
(_
) -> (PC.TEllipsis
(clt
),x
)
483 | PC.TCircles(_) -> (PC.TCircles(clt),x)
484 | PC.TStars(_) -> (PC.TStars(clt),x)
487 | PC.TOEllipsis
(_
) -> (PC.TOEllipsis
(clt
),x
)
488 | PC.TCEllipsis
(_
) -> (PC.TCEllipsis
(clt
),x
)
489 | PC.TPOEllipsis
(_
) -> (PC.TPOEllipsis
(clt
),x
)
490 | PC.TPCEllipsis
(_
) -> (PC.TPCEllipsis
(clt
),x
)
492 | PC.TOCircles(_) -> (PC.TOCircles(clt),x)
493 | PC.TCCircles(_) -> (PC.TCCircles(clt),x)
494 | PC.TOStars(_) -> (PC.TOStars(clt),x)
495 | PC.TCStars(_) -> (PC.TCStars(clt),x)
498 | PC.TWhy
(_
) -> (PC.TWhy
(clt
),x
)
499 | PC.TDotDot
(_
) -> (PC.TDotDot
(clt
),x
)
500 | PC.TBang
(_
) -> (PC.TBang
(clt
),x
)
501 | PC.TOPar
(_
) -> (PC.TOPar
(clt
),x
)
502 | PC.TOPar0
(_
) -> (PC.TOPar0
(clt
),x
)
503 | PC.TMid0
(_
) -> (PC.TMid0
(clt
),x
)
504 | PC.TCPar
(_
) -> (PC.TCPar
(clt
),x
)
505 | PC.TCPar0
(_
) -> (PC.TCPar0
(clt
),x
)
507 | PC.TOBrace
(_
) -> (PC.TOBrace
(clt
),x
)
508 | PC.TCBrace
(_
) -> (PC.TCBrace
(clt
),x
)
509 | PC.TOCro
(_
) -> (PC.TOCro
(clt
),x
)
510 | PC.TCCro
(_
) -> (PC.TCCro
(clt
),x
)
511 | PC.TOInit
(_
) -> (PC.TOInit
(clt
),x
)
513 | PC.TPtrOp
(_
) -> (PC.TPtrOp
(clt
),x
)
515 | PC.TEq
(_
) -> (PC.TEq
(clt
),x
)
516 | PC.TAssign
(s
,_
) -> (PC.TAssign
(s
,clt
),x
)
517 | PC.TDot
(_
) -> (PC.TDot
(clt
),x
)
518 | PC.TComma
(_
) -> (PC.TComma
(clt
),x
)
519 | PC.TPtVirg
(_
) -> (PC.TPtVirg
(clt
),x
)
521 | PC.TLineEnd
(_
) -> (PC.TLineEnd
(clt
),x
)
522 | PC.TFunDecl
(_
) -> (PC.TFunDecl
(clt
),x
)
524 | _
-> failwith
"no clt"
527 (* ----------------------------------------------------------------------- *)
529 let make_name prefix ln
= Printf.sprintf
"%s starting on line %d" prefix ln
531 (* ----------------------------------------------------------------------- *)
534 let wrap_lexbuf_info lexbuf
=
535 (Lexing.lexeme lexbuf
, Lexing.lexeme_start lexbuf
)
537 let tokens_all_full token table file get_ats lexbuf end_markers
:
538 (bool * ((PC.token
* (string * (int * int) * (int * int))) list
)) =
541 let result = token lexbuf
in
542 let info = (Lexing.lexeme lexbuf
,
543 (table
.(Lexing.lexeme_start lexbuf
)),
544 (Lexing.lexeme_start lexbuf
, Lexing.lexeme_end lexbuf
)) in
548 then failwith
"unexpected end of file in a metavariable declaration"
549 else (false,[(result,info)])
550 else if List.mem
result end_markers
551 then (true,[(result,info)])
553 let (more
,rest
) = aux() in
554 (more
,(result, info)::rest
)
557 e
-> pr2 (Common.error_message file
(wrap_lexbuf_info lexbuf
) ); raise e
559 let tokens_all table file get_ats lexbuf end_markers
:
560 (bool * ((PC.token
* (string * (int * int) * (int * int))) list
)) =
561 tokens_all_full Lexer_cocci.token table file get_ats lexbuf end_markers
563 let tokens_script_all table file get_ats lexbuf end_markers
:
564 (bool * ((PC.token
* (string * (int * int) * (int * int))) list
)) =
565 tokens_all_full Lexer_script.token table file get_ats lexbuf end_markers
567 (* ----------------------------------------------------------------------- *)
568 (* Split tokens into minus and plus fragments *)
571 let (d
,_
,_
,_
,_
,_
,_
,_
) = clt
in
573 D.MINUS
| D.OPTMINUS
| D.UNIQUEMINUS
-> ([t
],[])
574 | D.PLUS
| D.PLUSPLUS
-> ([],[t
])
575 | D.CONTEXT
| D.UNIQUE
| D.OPT
-> ([t
],[t
])
577 let split_token ((tok
,_
) as t
) =
579 PC.TIdentifier
| PC.TConstant
| PC.TExpression
| PC.TIdExpression
580 | PC.TStatement
| PC.TPosition
| PC.TPosAny
| PC.TInitialiser
581 | PC.TFunction
| PC.TTypedef
| PC.TDeclarer
| PC.TIterator
| PC.TName
582 | PC.TType
| PC.TParameter
| PC.TLocal
| PC.Tlist
| PC.TFresh
583 | PC.TCppConcatOp
| PC.TPure
584 | PC.TContext
| PC.TRuleName
(_
) | PC.TUsing
| PC.TVirtual
| PC.TDisable
585 | PC.TExtends
| PC.TPathIsoFile
(_
)
586 | PC.TDepends
| PC.TOn
| PC.TEver
| PC.TNever
| PC.TExists
| PC.TForall
587 | PC.TError
| PC.TWords
| PC.TGenerated
| PC.TNothing
-> ([t
],[t
])
589 | PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
590 | PC.Tfloat
(clt
) | PC.Tlong
(clt
) | PC.Tvoid
(clt
) | PC.Tstruct
(clt
)
591 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
592 | PC.Tstatic
(clt
) | PC.Tauto
(clt
) | PC.Tregister
(clt
) | PC.Textern
(clt
)
593 | PC.Tinline
(clt
) | PC.Ttypedef
(clt
) | PC.Tattr
(_
,clt
)
594 | PC.Tconst
(clt
) | PC.Tvolatile
(clt
) -> split t clt
596 | PC.TPragma
(s
,_
) -> ([],[t
]) (* only allowed in + *)
597 | PC.TPlusFile
(s
,clt
) | PC.TMinusFile
(s
,clt
)
598 | PC.TIncludeL
(s
,clt
) | PC.TIncludeNL
(s
,clt
) ->
600 | PC.TDefine
(clt
,_
) | PC.TDefineParam
(clt
,_
,_
,_
) -> split t clt
602 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
603 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
)
605 | PC.TReturn
(clt
) | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
)
607 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
608 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaExp
(_
,_
,_
,_
,clt
)
609 | PC.TMetaIdExp
(_
,_
,_
,_
,clt
) | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
610 | PC.TMetaExpList
(_
,_
,_
,clt
)
611 | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
612 | PC.TMetaId
(_
,_
,_
,clt
) | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
)
613 | PC.TMetaStm
(_
,_
,clt
) | PC.TMetaStmList
(_
,_
,clt
) | PC.TMetaErr
(_
,_
,_
,clt
)
614 | PC.TMetaFunc
(_
,_
,_
,clt
) | PC.TMetaLocalFunc
(_
,_
,_
,clt
)
615 | PC.TMetaDeclarer
(_
,_
,_
,clt
) | PC.TMetaIterator
(_
,_
,_
,clt
) -> split t clt
616 | PC.TMPtVirg
| PC.TArob
| PC.TArobArob
| PC.TScript
617 | PC.TInitialize
| PC.TFinalize
-> ([t
],[t
])
618 | PC.TPArob
| PC.TMetaPos
(_
,_
,_
,_
) -> ([t
],[])
621 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
)
622 | PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TLineEnd
(clt
)
623 | PC.TEllipsis
(clt
) (* | PC.TCircles(clt) | PC.TStars(clt) *) -> split t clt
625 | PC.TOEllipsis
(_
) | PC.TCEllipsis
(_
) (* clt must be context *)
626 | PC.TPOEllipsis
(_
) | PC.TPCEllipsis
(_
) (* clt must be context *)
628 | PC.TOCircles(_) | PC.TCCircles(_) (* clt must be context *)
629 | PC.TOStars
(_
) | PC.TCStars
(_
) (* clt must be context *)
631 | PC.TBang0
| PC.TPlus0
| PC.TWhy0
->
634 | PC.TWhy
(clt
) | PC.TDotDot
(clt
)
635 | PC.TBang
(clt
) | PC.TOPar
(clt
) | PC.TOPar0
(clt
)
636 | PC.TMid0
(clt
) | PC.TCPar
(clt
) | PC.TCPar0
(clt
) -> split t clt
638 | PC.TInc
(clt
) | PC.TDec
(clt
) -> split t clt
640 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
) ->
643 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
644 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TTildeEq
(clt
) | PC.TTildeExclEq
(clt
) | PC.TLogOp
(_
,clt
)
645 | PC.TShOp
(_
,clt
) | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
646 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
) -> split t clt
648 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOInit
(clt
) -> split t clt
649 | PC.TOCro
(clt
) | PC.TCCro
(clt
) -> split t clt
651 | PC.TPtrOp
(clt
) -> split t clt
653 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
654 | PC.TPtVirg
(clt
) -> split t clt
656 | PC.EOF
| PC.TInvalid
-> ([t
],[t
])
658 | PC.TIso
| PC.TRightIso
659 | PC.TIsoExpression
| PC.TIsoStatement
| PC.TIsoDeclaration
| PC.TIsoType
660 | PC.TIsoTopLevel
| PC.TIsoArgExpression
| PC.TIsoTestExpression
->
661 failwith
"unexpected tokens"
662 | PC.TScriptData s
-> ([t
],[t
])
664 let split_token_stream tokens
=
665 let rec loop = function
668 let (minus
,plus
) = split_token token
in
669 let (minus_stream
,plus_stream
) = loop tokens
in
670 (minus
@minus_stream
,plus
@plus_stream
) in
673 (* ----------------------------------------------------------------------- *)
674 (* Find function names *)
675 (* This addresses a shift-reduce problem in the parser, allowing us to
676 distinguish a function declaration from a function call even if the latter
677 has no return type. Undoubtedly, this is not very nice, but it doesn't
678 seem very convenient to refactor the grammar to get around the problem. *)
680 let rec find_function_names = function
682 | ((PC.TIdent
(_
,clt
),info) as t1
) :: ((PC.TOPar
(_
),_
) as t2
) :: rest
683 | ((PC.TMetaId
(_
,_
,_
,clt
),info) as t1
) :: ((PC.TOPar
(_
),_
) as t2
) :: rest
684 | ((PC.TMetaFunc
(_
,_
,_
,clt
),info) as t1
) :: ((PC.TOPar
(_
),_
) as t2
) :: rest
685 | ((PC.TMetaLocalFunc
(_
,_
,_
,clt
),info) as t1
)::((PC.TOPar
(_
),_
) as t2
)::rest
687 let rec skip level
= function
689 | ((PC.TCPar
(_
),_
) as t
)::rest
->
690 let level = level - 1 in
693 else let (pre
,found
,post
) = skip level rest
in (t
::pre
,found
,post
)
694 | ((PC.TOPar
(_
),_
) as t
)::rest
->
695 let level = level + 1 in
696 let (pre
,found
,post
) = skip level rest
in (t
::pre
,found
,post
)
697 | ((PC.TArobArob
,_
) as t
)::rest
698 | ((PC.TArob
,_
) as t
)::rest
699 | ((PC.EOF
,_
) as t
)::rest
-> ([t
],false,rest
)
701 let (pre
,found
,post
) = skip level rest
in (t
::pre
,found
,post
) in
702 let (pre
,found
,post
) = skip 1 rest
in
703 (match (found
,post
) with
704 (true,((PC.TOBrace
(_
),_
) as t3
)::rest
) ->
705 (PC.TFunDecl
(clt
),info) :: t1
:: t2
:: pre
@
706 t3
:: (find_function_names rest
)
707 | _
-> t1
:: t2
:: pre
@ find_function_names post
)
708 | t
:: rest
-> t
:: find_function_names rest
710 (* ----------------------------------------------------------------------- *)
711 (* an attribute is an identifier that preceeds another identifier and
714 let rec detect_attr l
=
716 (PC.TIdent
(_
,_
),_
) | (PC.TMetaId
(_
,_
,_
,_
),_
) | (PC.TMetaFunc
(_
,_
,_
,_
),_
)
717 | (PC.TMetaLocalFunc
(_
,_
,_
,_
),_
) -> true
719 let rec loop = function
722 | ((PC.TIdent
(nm
,clt
),info) as t1
)::id
::rest
when is_id id
->
723 if String.length nm
> 2 && String.sub nm
0 2 = "__"
724 then (PC.Tattr
(nm
,clt
),info)::(loop (id
::rest
))
725 else t1
::(loop (id
::rest
))
726 | x
::xs
-> x
::(loop xs
) in
729 (* ----------------------------------------------------------------------- *)
730 (* Look for variable declarations where the name is a typedef name.
731 We assume that C code does not contain a multiplication as a top-level
734 (* bug: once a type, always a type, even if the same name is later intended
735 to be used as a real identifier *)
736 let detect_types in_meta_decls l
=
737 let is_delim infn
= function
738 (PC.TOEllipsis
(_
),_
) (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *)
739 | (PC.TPOEllipsis
(_
),_
) (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *)
740 | (PC.TEllipsis
(_
),_
) (* | (PC.TCircles(_),_) | (PC.TStars(_),_) *)
741 | (PC.TPtVirg
(_
),_
) | (PC.TOBrace
(_
),_
) | (PC.TOInit
(_
),_
)
743 | (PC.TPure
,_
) | (PC.TContext
,_
)
744 | (PC.Tstatic
(_
),_
) | (PC.Textern
(_
),_
)
745 | (PC.Tinline
(_
),_
) | (PC.Ttypedef
(_
),_
) | (PC.Tattr
(_
),_
) -> true
746 | (PC.TComma
(_
),_
) when infn
> 0 or in_meta_decls
-> true
747 | (PC.TDotDot
(_
),_
) when in_meta_decls
-> true
749 let is_choices_delim = function
750 (PC.TOBrace
(_
),_
) | (PC.TComma
(_
),_
) -> true | _
-> false in
752 (PC.TIdent
(_
,_
),_
) | (PC.TMetaId
(_
,_
,_
,_
),_
) | (PC.TMetaFunc
(_
,_
,_
,_
),_
)
753 | (PC.TMetaLocalFunc
(_
,_
,_
,_
),_
) -> true
754 | (PC.TMetaParam
(_
,_
,_
),_
)
755 | (PC.TMetaParamList
(_
,_
,_
,_
),_
)
756 | (PC.TMetaConst
(_
,_
,_
,_
,_
),_
)
757 | (PC.TMetaErr
(_
,_
,_
,_
),_
)
758 | (PC.TMetaExp
(_
,_
,_
,_
,_
),_
)
759 | (PC.TMetaIdExp
(_
,_
,_
,_
,_
),_
)
760 | (PC.TMetaLocalIdExp
(_
,_
,_
,_
,_
),_
)
761 | (PC.TMetaExpList
(_
,_
,_
,_
),_
)
762 | (PC.TMetaType
(_
,_
,_
),_
)
763 | (PC.TMetaInit
(_
,_
,_
),_
)
764 | (PC.TMetaStm
(_
,_
,_
),_
)
765 | (PC.TMetaStmList
(_
,_
,_
),_
)
766 | (PC.TMetaPos
(_
,_
,_
,_
),_
) -> in_meta_decls
768 let redo_id ident clt v
=
769 !Data.add_type_name ident
;
770 (PC.TTypeId
(ident
,clt
),v
) in
771 let rec loop start infn type_names
= function
772 (* infn: 0 means not in a function header
773 > 0 means in a function header, after infn - 1 unmatched open parens*)
775 | ((PC.TOBrace
(clt
),v
)::_
) as all
when in_meta_decls
->
776 collect_choices type_names all
(* never a function header *)
777 | delim
::(PC.TIdent
(ident
,clt
),v
)::((PC.TMul
(_
),_
) as x
)::rest
778 when is_delim infn delim
->
779 let newid = redo_id ident clt v
in
780 delim
::newid::x
::(loop false infn
(ident
::type_names
) rest
)
781 | delim
::(PC.TIdent
(ident
,clt
),v
)::id
::rest
782 when is_delim infn delim
&& is_id id
->
783 let newid = redo_id ident clt v
in
784 delim
::newid::id
::(loop false infn
(ident
::type_names
) rest
)
785 | ((PC.TFunDecl
(_
),_
) as fn
)::rest
->
786 fn
::(loop false 1 type_names rest
)
787 | ((PC.TOPar
(_
),_
) as lp
)::rest
when infn
> 0 ->
788 lp
::(loop false (infn
+ 1) type_names rest
)
789 | ((PC.TCPar
(_
),_
) as rp
)::rest
when infn
> 0 ->
791 then rp
::(loop false 0 type_names rest
) (* 0 means not in fn header *)
792 else rp
::(loop false (infn
- 1) type_names rest
)
793 | (PC.TIdent
(ident
,clt
),v
)::((PC.TMul
(_
),_
) as x
)::rest
when start
->
794 let newid = redo_id ident clt v
in
795 newid::x
::(loop false infn
(ident
::type_names
) rest
)
796 | (PC.TIdent
(ident
,clt
),v
)::id
::rest
when start
&& is_id id
->
797 let newid = redo_id ident clt v
in
798 newid::id
::(loop false infn
(ident
::type_names
) rest
)
799 | (PC.TIdent
(ident
,clt
),v
)::rest
when List.mem ident type_names
->
800 (PC.TTypeId
(ident
,clt
),v
)::(loop false infn type_names rest
)
801 | ((PC.TIdent
(ident
,clt
),v
) as x
)::rest
->
802 x
::(loop false infn type_names rest
)
803 | x
::rest
-> x
::(loop false infn type_names rest
)
804 and collect_choices type_names
= function
805 [] -> [] (* should happen, but let the parser detect that *)
806 | (PC.TCBrace
(clt
),v
)::rest
->
807 (PC.TCBrace
(clt
),v
)::(loop false 0 type_names rest
)
808 | delim
::(PC.TIdent
(ident
,clt
),v
)::rest
809 when is_choices_delim delim
->
810 let newid = redo_id ident clt v
in
811 delim
::newid::(collect_choices
(ident
::type_names
) rest
)
812 | x
::rest
-> x
::(collect_choices type_names rest
) in
816 (* ----------------------------------------------------------------------- *)
817 (* Insert TLineEnd tokens at the end of a line that contains a WHEN.
818 WHEN is restricted to a single line, to avoid ambiguity in eg:
822 let token2line (tok
,_
) =
824 PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
825 | PC.Tfloat
(clt
) | PC.Tlong
(clt
) | PC.Tvoid
(clt
) | PC.Tstruct
(clt
)
826 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
827 | PC.Tstatic
(clt
) | PC.Tauto
(clt
) | PC.Tregister
(clt
) | PC.Textern
(clt
)
828 | PC.Tinline
(clt
) | PC.Ttypedef
(clt
) | PC.Tattr
(_
,clt
) | PC.Tconst
(clt
)
831 | PC.TInc
(clt
) | PC.TDec
(clt
)
833 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
834 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
) | PC.TSizeof
(clt
)
835 | PC.TReturn
(clt
) | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
)
837 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
838 | PC.TMetaDeclarer
(_
,_
,_
,clt
) | PC.TMetaIterator
(_
,_
,_
,clt
)
840 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
)
842 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
843 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TLogOp
(_
,clt
)
844 | PC.TShOp
(_
,clt
) | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
845 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
)
847 | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
848 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaExp
(_
,_
,_
,_
,clt
)
849 | PC.TMetaIdExp
(_
,_
,_
,_
,clt
) | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
850 | PC.TMetaExpList
(_
,_
,_
,clt
)
851 | PC.TMetaId
(_
,_
,_
,clt
) | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
)
852 | PC.TMetaStm
(_
,_
,clt
) | PC.TMetaStmList
(_
,_
,clt
) | PC.TMetaFunc
(_
,_
,_
,clt
)
853 | PC.TMetaLocalFunc
(_
,_
,_
,clt
) | PC.TMetaPos
(_
,_
,_
,clt
)
856 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
)
857 | PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TEllipsis
(clt
)
858 (* | PC.TCircles(clt) | PC.TStars(clt) *)
860 | PC.TOEllipsis
(clt
) | PC.TCEllipsis
(clt
)
861 | PC.TPOEllipsis
(clt
) | PC.TPCEllipsis
(clt
) (*| PC.TOCircles(clt)
862 | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *)
864 | PC.TWhy
(clt
) | PC.TDotDot
(clt
) | PC.TBang
(clt
) | PC.TOPar
(clt
)
865 | PC.TOPar0
(clt
) | PC.TMid0
(clt
) | PC.TCPar
(clt
)
868 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOCro
(clt
) | PC.TCCro
(clt
)
873 | PC.TDefine
(clt
,_
) | PC.TDefineParam
(clt
,_
,_
,_
)
874 | PC.TIncludeL
(_
,clt
) | PC.TIncludeNL
(_
,clt
)
876 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
878 let (_
,line
,_
,_
,_
,_
,_
,_
) = clt
in Some line
882 let rec insert_line_end = function
884 | (((PC.TWhen
(clt
),q
) as x
)::xs
) ->
885 x
::(find_line_end
true (token2line x
) clt q xs
)
886 | (((PC.TDefine
(clt
,_
),q
) as x
)::xs
)
887 | (((PC.TDefineParam
(clt
,_
,_
,_
),q
) as x
)::xs
) ->
888 x
::(find_line_end
false (token2line x
) clt q xs
)
889 | x
::xs
-> x
::(insert_line_end xs
)
891 and find_line_end inwhen line clt q
= function
892 (* don't know what 2nd component should be so just use the info of
893 the When. Also inherit - of when, if any *)
894 [] -> [(PC.TLineEnd
(clt
),q
)]
895 | ((PC.TIdent
("strict",clt
),a
) as x
)::xs
when token2line x
= line
->
896 (PC.TStrict
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
897 | ((PC.TIdent
("STRICT",clt
),a
) as x
)::xs
when token2line x
= line
->
898 (PC.TStrict
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
899 | ((PC.TIdent
("any",clt
),a
) as x
)::xs
when token2line x
= line
->
900 (PC.TAny
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
901 | ((PC.TIdent
("ANY",clt
),a
) as x
)::xs
when token2line x
= line
->
902 (PC.TAny
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
903 | ((PC.TIdent
("forall",clt
),a
) as x
)::xs
when token2line x
= line
->
904 (PC.TForall
,a
) :: (find_line_end inwhen line clt q xs
)
905 | ((PC.TIdent
("exists",clt
),a
) as x
)::xs
when token2line x
= line
->
906 (PC.TExists
,a
) :: (find_line_end inwhen line clt q xs
)
907 | ((PC.TComma
(clt
),a
) as x
)::xs
when token2line x
= line
->
908 (PC.TComma
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
909 | ((PC.TPArob
,a
) as x
)::xs
-> (* no line #, just assume on the same line *)
910 x
:: (find_line_end inwhen line clt q xs
)
911 | x
::xs
when token2line x
= line
-> x
:: (find_line_end inwhen line clt q xs
)
912 | xs
-> (PC.TLineEnd
(clt
),q
)::(insert_line_end xs
)
914 let rec translate_when_true_false = function
916 | (PC.TWhen
(clt
),q
)::((PC.TNotEq
(_
),_
) as x
)::(PC.TIdent
("true",_
),_
)::xs
->
917 (PC.TWhenTrue
(clt
),q
)::x
::(translate_when_true_false xs
)
918 | (PC.TWhen
(clt
),q
)::((PC.TNotEq
(_
),_
) as x
)::(PC.TIdent
("false",_
),_
)::xs
->
919 (PC.TWhenFalse
(clt
),q
)::x
::(translate_when_true_false xs
)
920 | x
::xs
-> x
:: (translate_when_true_false xs
)
922 (* ----------------------------------------------------------------------- *)
924 let check_parentheses tokens
=
925 let clt2line (_
,line
,_
,_
,_
,_
,_
,_
) = line
in
926 let rec loop seen_open
= function
928 | (PC.TOPar
(clt
),q
) :: rest
929 | (PC.TDefineParam
(clt
,_
,_
,_
),q
) :: rest
->
930 loop (Common.Left
(clt2line clt
) :: seen_open
) rest
931 | (PC.TOPar0
(clt
),q
) :: rest
->
932 loop (Common.Right
(clt2line clt
) :: seen_open
) rest
933 | (PC.TCPar
(clt
),q
) :: rest
->
934 (match seen_open
with
938 "unexpected close parenthesis in line %d\n" (clt2line clt
))
939 | Common.Left _
:: seen_open
-> loop seen_open rest
940 | Common.Right open_line
:: _
->
943 "disjunction parenthesis in line %d column 0 matched to normal parenthesis on line %d\n" open_line
(clt2line clt
)))
944 | (PC.TCPar0
(clt
),q
) :: rest
->
945 (match seen_open
with
949 "unexpected close parenthesis in line %d\n" (clt2line clt
))
950 | Common.Right _
:: seen_open
-> loop seen_open rest
951 | Common.Left open_line
:: _
->
954 "normal parenthesis in line %d matched to disjunction parenthesis on line %d column 0\n" open_line
(clt2line clt
)))
955 | x
::rest
-> loop seen_open rest
in
958 (* ----------------------------------------------------------------------- *)
959 (* top level initializers: a sequence of braces followed by a dot *)
961 let find_top_init tokens
=
963 (PC.TOBrace
(clt
),q
) :: rest
->
964 let rec dot_start acc
= function
965 ((PC.TOBrace
(_
),_
) as x
) :: rest
->
966 dot_start (x
::acc
) rest
967 | ((PC.TDot
(_
),_
) :: rest
) as x
->
968 Some
((PC.TOInit
(clt
),q
) :: (List.rev acc
) @ x
)
970 let rec comma_end acc
= function
971 ((PC.TCBrace
(_
),_
) as x
) :: rest
->
972 comma_end (x
::acc
) rest
973 | ((PC.TComma
(_
),_
) :: rest
) as x
->
974 Some
((PC.TOInit
(clt
),q
) :: (List.rev x
) @ acc
)
976 (match dot_start [] rest
with
979 (match List.rev rest
with
980 (* not super sure what this does, but EOF, @, and @@ should be
981 the same, markind the end of a rule *)
982 ((PC.EOF
,_
) as x
)::rest
| ((PC.TArob
,_
) as x
)::rest
983 | ((PC.TArobArob
,_
) as x
)::rest
->
984 (match comma_end [x
] rest
with
988 failwith
"unexpected empty token list"))
991 (* ----------------------------------------------------------------------- *)
992 (* Integrate pragmas into some adjacent token. + tokens are preferred. Dots
995 let rec collect_all_pragmas collected
= function
996 (PC.TPragma
(s
,(_
,line
,logical_line
,offset
,col
,_
,_
,pos
)),_
)::rest
->
998 { Ast0.line_start
= line
; Ast0.line_end
= line
;
999 Ast0.logical_start
= logical_line
; Ast0.logical_end
= logical_line
;
1000 Ast0.column
= col
; Ast0.offset
= offset
; } in
1001 collect_all_pragmas ((s
,i)::collected
) rest
1002 | l
-> (List.rev collected
,l
)
1004 let rec collect_pass = function
1007 match plus_attachable false x
with
1009 let (pass
,rest
) = collect_pass xs
in
1013 let plus_attach strict
= function
1015 | Some x
-> plus_attachable strict x
1017 let add_bef = function Some x
-> [x
] | None
-> []
1019 (*skips should be things like line end
1020 skips is things before pragmas that can't be attached to, pass is things
1021 after. pass is used immediately. skips accumulates. *)
1022 let rec process_pragmas bef skips
= function
1023 [] -> add_bef bef
@ List.rev skips
1024 | ((PC.TPragma
(s
,i),_
)::_
) as l
->
1025 let (pragmas
,rest
) = collect_all_pragmas [] l
in
1026 let (pass
,rest0
) = collect_pass rest
in
1028 match rest0
with [] -> (None
,[]) | next
::rest
-> (Some next
,rest
) in
1029 (match (bef
,plus_attach true bef
,next
,plus_attach true next
) with
1030 (Some bef
,PLUS
,_
,_
) ->
1031 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt bef
in
1032 (update_clt bef
(a
,b
,c
,d
,e
,strbef
,pragmas
,pos
))::List.rev skips
@
1033 pass
@process_pragmas None
[] rest0
1034 | (_
,_
,Some next
,PLUS
) ->
1035 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt next
in
1036 (add_bef bef
) @ List.rev skips
@ pass
@
1038 (Some
(update_clt next
(a
,b
,c
,d
,e
,pragmas
,straft
,pos
)))
1041 (match (bef
,plus_attach false bef
,next
,plus_attach false next
) with
1042 (Some bef
,PLUS
,_
,_
) ->
1043 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt bef
in
1044 (update_clt bef
(a
,b
,c
,d
,e
,strbef
,pragmas
,pos
))::List.rev skips
@
1045 pass
@process_pragmas None
[] rest0
1046 | (_
,_
,Some next
,PLUS
) ->
1047 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt next
in
1048 (add_bef bef
) @ List.rev skips
@ pass
@
1050 (Some
(update_clt next
(a
,b
,c
,d
,e
,pragmas
,straft
,pos
)))
1052 | _
-> failwith
"nothing to attach pragma to"))
1054 (match plus_attachable false x
with
1055 SKIP
-> process_pragmas bef
(x
::skips
) xs
1056 | _
-> (add_bef bef
) @ List.rev skips
@ (process_pragmas (Some x
) [] xs
))
1058 (* ----------------------------------------------------------------------- *)
1059 (* Drop ... ... . This is only allowed in + code, and arises when there is
1060 some - code between the ... *)
1061 (* drop whens as well - they serve no purpose in + code and they cause
1062 problems for drop_double_dots *)
1064 let rec drop_when = function
1066 | (PC.TWhen
(clt
),info)::xs
->
1067 let rec loop = function
1069 | (PC.TLineEnd
(_
),info)::xs
-> drop_when xs
1070 | x
::xs
-> loop xs
in
1072 | x
::xs
-> x
::drop_when xs
1074 (* instead of dropping the double dots, we put TNothing in between them.
1075 these vanish after the parser, but keeping all the ...s in the + code makes
1076 it easier to align the + and - code in context_neg and in preparation for the
1077 isomorphisms. This shouldn't matter because the context code of the +
1078 slice is mostly ignored anyway *)
1079 let minus_to_nothing l
=
1080 (* for cases like | <..., which may or may not arise from removing minus
1081 code, depending on whether <... is a statement or expression *)
1084 let (d
,_
,_
,_
,_
,_
,_
,_
) = get_clt tok
in
1086 D.MINUS
| D.OPTMINUS
| D.UNIQUEMINUS
-> true
1087 | D.PLUS
| D.PLUSPLUS
-> false
1088 | D.CONTEXT
| D.UNIQUE
| D.OPT
-> false)
1090 let rec minus_loop = function
1092 | (d
::ds
) as l
-> if is_minus d
then minus_loop ds
else l
in
1093 let rec loop = function
1095 | ((PC.TMid0
(clt
),i) as x
)::t1
::ts
when is_minus t1
->
1096 (match minus_loop ts
with
1097 ((PC.TOEllipsis
(_
),_
)::_
) | ((PC.TPOEllipsis
(_
),_
)::_
)
1098 | ((PC.TEllipsis
(_
),_
)::_
) as l
-> x
::(PC.TNothing
,i)::(loop l
)
1100 | t
::ts
-> t
::(loop ts
) in
1103 let rec drop_double_dots l
=
1104 let start = function
1105 (PC.TOEllipsis
(_
),_
) | (PC.TPOEllipsis
(_
),_
)
1106 (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *) ->
1109 let middle = function
1110 (PC.TEllipsis
(_
),_
) (* | (PC.TCircles(_),_) | (PC.TStars(_),_) *) -> true
1112 let whenline = function
1113 (PC.TLineEnd
(_
),_
) -> true
1114 (*| (PC.TMid0(_),_) -> true*)
1116 let final = function
1117 (PC.TCEllipsis
(_
),_
) | (PC.TPCEllipsis
(_
),_
)
1118 (* | (PC.TCCircles(_),_) | (PC.TCStars(_),_) *) ->
1121 let any_before x
= start x
or middle x
or final x
or whenline x
in
1122 let any_after x
= start x
or middle x
or final x
in
1123 let rec loop ((_
,i) as prev
) = function
1125 | x
::rest
when any_before prev
&& any_after x
->
1126 (PC.TNothing
,i)::x
::(loop x rest
)
1127 | x
::rest
-> x
:: (loop x rest
) in
1130 | (x
::xs
) -> x
:: loop x xs
1134 if l
= cur then l
else fix f
cur
1136 (* ( | ... | ) also causes parsing problems *)
1140 let rec drop_empty_thing starter
middle ender
= function
1142 | hd
::rest
when starter hd
->
1143 let rec loop = function
1144 x
::rest
when middle x
-> loop rest
1145 | x
::rest
when ender x
-> rest
1146 | _
-> raise Not_empty
in
1147 (match try Some
(loop rest
) with Not_empty
-> None
with
1148 Some x
-> drop_empty_thing starter
middle ender x
1149 | None
-> hd
:: drop_empty_thing starter
middle ender rest
)
1150 | x
::rest
-> x
:: drop_empty_thing starter
middle ender rest
1154 (function (PC.TOPar0
(_
),_
) -> true | _
-> false)
1155 (function (PC.TMid0
(_
),_
) -> true | _
-> false)
1156 (function (PC.TCPar0
(_
),_
) -> true | _
-> false)
1158 let drop_empty_nest = drop_empty_thing
1160 (* ----------------------------------------------------------------------- *)
1163 let get_s_starts (_
, (s
,_
,(starts
, ends
))) =
1164 Printf.printf
"%d %d\n" starts ends
; (s
, starts
)
1167 let v = List.hd
!l
in
1172 PC.reinit (function _
-> PC.TArobArob
(* a handy token *))
1173 (Lexing.from_function
1174 (function buf
-> function n
-> raise
Common.Impossible
))
1176 let parse_one str parsefn file toks
=
1177 let all_tokens = ref toks
in
1178 let cur_tok = ref (List.hd
!all_tokens) in
1180 let lexer_function _
=
1181 let (v, info) = pop2 all_tokens in
1182 cur_tok := (v, info);
1186 Lexing.from_function
1187 (function buf
-> function n
-> raise
Common.Impossible
)
1192 try parsefn
lexer_function lexbuf_fake
1194 Lexer_cocci.Lexical s
->
1196 (Printf.sprintf
"%s: lexical error: %s\n =%s\n" str s
1197 (Common.error_message file
(get_s_starts !cur_tok) ))
1198 | Parser_cocci_menhir.Error
->
1200 (Printf.sprintf
"%s: parse error: \n = %s\n" str
1201 (Common.error_message file
(get_s_starts !cur_tok) ))
1202 | Semantic_cocci.Semantic s
->
1204 (Printf.sprintf
"%s: semantic error: %s\n =%s\n" str s
1205 (Common.error_message file
(get_s_starts !cur_tok) ))
1209 let prepare_tokens tokens
=
1211 (translate_when_true_false (* after insert_line_end *)
1214 (find_function_names (detect_attr (check_parentheses tokens
))))))
1216 let prepare_mv_tokens tokens
=
1217 detect_types false (detect_attr tokens
)
1219 let rec consume_minus_positions = function
1221 | ((PC.TOPar0
(_
),_
) as x
)::xs
| ((PC.TCPar0
(_
),_
) as x
)::xs
1222 | ((PC.TMid0
(_
),_
) as x
)::xs
-> x
::consume_minus_positions xs
1223 | x
::(PC.TPArob
,_
)::(PC.TMetaPos
(name
,constraints
,per
,clt
),_
)::xs
->
1224 let (arity
,ln
,lln
,offset
,col
,strbef
,straft
,_
) = get_clt x
in
1225 let name = Parse_aux.clt2mcode
name clt
in
1228 (arity
,ln
,lln
,offset
,col
,strbef
,straft
,
1229 Ast0.MetaPos
(name,constraints
,per
)) in
1230 x::(consume_minus_positions xs
)
1231 | x::xs
-> x::consume_minus_positions xs
1233 let any_modif rule
=
1235 match Ast0.get_mcode_mcodekind
x with
1236 Ast0.MINUS _
| Ast0.PLUS _
-> true
1238 let donothing r k e
= k e
in
1239 let bind x y
= x or y
in
1240 let option_default = false in
1242 V0.flat_combiner
bind option_default
1243 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1244 donothing donothing donothing donothing donothing donothing
1245 donothing donothing donothing donothing donothing donothing donothing
1246 donothing donothing in
1247 List.exists
fn.VT0.combiner_rec_top_level rule
1249 let eval_virt virt
=
1252 if not
(List.mem
x virt
)
1255 (Printf.sprintf
"unknown virtual rule %s\n" x))
1256 !Flag_parsing_cocci.defined_virtual_rules
1258 let drop_last extra l
= List.rev
(extra
@(List.tl
(List.rev l
)))
1260 let partition_either l
=
1261 let rec part_either left right
= function
1262 | [] -> (List.rev left
, List.rev right
)
1265 | Common.Left e
-> part_either (e
:: left
) right l
1266 | Common.Right e
-> part_either left
(e
:: right
) l
) in
1269 let get_metavars parse_fn table file lexbuf
=
1270 let rec meta_loop acc
(* read one decl at a time *) =
1274 tokens_all table file
true lexbuf
[PC.TArobArob
;PC.TMPtVirg
]) in
1275 let tokens = prepare_mv_tokens tokens in
1277 [(PC.TArobArob
,_
)] -> List.rev acc
1279 let metavars = parse_one "meta" parse_fn file
tokens in
1280 meta_loop (metavars@acc
) in
1281 partition_either (meta_loop [])
1283 let get_script_metavars parse_fn table file lexbuf
=
1284 let rec meta_loop acc
=
1286 tokens_all table file
true lexbuf
[PC.TArobArob
; PC.TMPtVirg
] in
1287 let tokens = prepare_tokens tokens in
1289 [(PC.TArobArob
, _
)] -> List.rev acc
1291 let metavar = parse_one "scriptmeta" parse_fn file
tokens in
1292 meta_loop (metavar :: acc
)
1296 let get_rule_name parse_fn starts_with_name get_tokens file prefix
=
1297 Data.in_rule_name
:= true;
1298 let mknm _
= make_name prefix
(!Lexer_cocci.line
) in
1302 let (_
,tokens) = get_tokens
[PC.TArob
] in
1303 let check_name = function
1304 None
-> Some
(mknm())
1306 (if List.mem nm
reserved_names
1307 then failwith
(Printf.sprintf
"invalid name %s\n" nm
));
1309 match parse_one "rule name" parse_fn file
tokens with
1310 Ast.CocciRulename
(nm
,a
,b
,c
,d
,e
) ->
1311 Ast.CocciRulename
(check_name nm
,a
,b
,c
,d
,e
)
1312 | Ast.GeneratedRulename
(nm
,a
,b
,c
,d
,e
) ->
1313 Ast.GeneratedRulename
(check_name nm
,a
,b
,c
,d
,e
)
1314 | Ast.ScriptRulename
(s
,deps
) -> Ast.ScriptRulename
(s
,deps
)
1315 | Ast.InitialScriptRulename
(s
) -> Ast.InitialScriptRulename
(s
)
1316 | Ast.FinalScriptRulename
(s
) -> Ast.FinalScriptRulename
(s
)
1318 Ast.CocciRulename
(Some
(mknm()),Ast.NoDep
,[],[],Ast.Undetermined
,false) in
1319 Data.in_rule_name
:= false;
1322 let parse_iso file
=
1323 let table = Common.full_charpos_to_pos file
in
1324 Common.with_open_infile file
(fun channel
->
1325 let lexbuf = Lexing.from_channel channel
in
1326 let get_tokens = tokens_all table file
false lexbuf in
1328 match get_tokens [PC.TArobArob
;PC.TArob
] with
1330 let parse_start start =
1331 let rev = List.rev start in
1332 let (arob
,_
) = List.hd
rev in
1333 (arob
= PC.TArob
,List.rev(List.tl
rev)) in
1334 let (starts_with_name
,start) = parse_start start in
1335 let rec loop starts_with_name
start =
1336 (!Data.init_rule
)();
1337 (* get metavariable declarations - have to be read before the
1339 let (rule_name
,_
,_
,_
,_
,_
) =
1340 match get_rule_name PC.iso_rule_name starts_with_name
get_tokens
1341 file
("iso file "^file
) with
1342 Ast.CocciRulename
(Some n
,a
,b
,c
,d
,e
) -> (n
,a
,b
,c
,d
,e
)
1343 | _
-> failwith
"Script rules cannot appear in isomorphism rules"
1345 Ast0.rule_name
:= rule_name
;
1347 match get_metavars PC.iso_meta_main
table file
lexbuf with
1348 (iso_metavars,[]) -> iso_metavars
1349 | _
-> failwith
"unexpected inheritance in iso" in
1353 [PC.TIsoStatement
;PC.TIsoExpression
;PC.TIsoArgExpression
;
1354 PC.TIsoTestExpression
;
1355 PC.TIsoDeclaration
;PC.TIsoType
;PC.TIsoTopLevel
] in
1356 let next_start = List.hd
(List.rev tokens) in
1357 let dummy_info = ("",(-1,-1),(-1,-1)) in
1358 let tokens = drop_last [(PC.EOF
,dummy_info)] tokens in
1359 let tokens = prepare_tokens (start@tokens) in
1361 print_tokens "iso tokens" tokens;
1363 let entry = parse_one "iso main" PC.iso_main file
tokens in
1364 let entry = List.map
(List.map
Test_exps.process_anything
) entry in
1366 then (* The code below allows a header like Statement list,
1367 which is more than one word. We don't have that any more,
1368 but the code is left here in case it is put back. *)
1369 match get_tokens [PC.TArobArob
;PC.TArob
] with
1371 let (starts_with_name
,start) = parse_start start in
1372 (iso_metavars,entry,rule_name
) ::
1373 (loop starts_with_name
(next_start::start))
1374 | _
-> failwith
"isomorphism ends early"
1375 else [(iso_metavars,entry,rule_name
)] in
1376 loop starts_with_name
start
1377 | (false,_
) -> [] in
1380 let parse_iso_files existing_isos iso_files extra_path
=
1381 let get_names = List.map
(function (_
,_
,nm
) -> nm
) in
1382 let old_names = get_names existing_isos
in
1383 Data.in_iso
:= true;
1386 (function (prev
,names
) ->
1388 Lexer_cocci.init
();
1391 Common.Left
(fl
) -> Filename.concat extra_path fl
1392 | Common.Right
(fl
) -> Filename.concat
Config.path fl
in
1393 let current = parse_iso file in
1394 let new_names = get_names current in
1395 if List.exists
(function x -> List.mem
x names
) new_names
1396 then failwith
(Printf.sprintf
"repeated iso name found in %s" file);
1397 (current::prev
,new_names @ names
))
1398 ([],old_names) iso_files
in
1399 Data.in_iso
:= false;
1400 existing_isos
@(List.concat
(List.rev res))
1402 (* None = dependency not satisfied
1403 Some dep = dependency satisfied or unknown and dep has virts optimized
1405 let eval_depend dep virt
=
1408 Ast.Dep req
| Ast.EverDep req
->
1409 if List.mem req virt
1411 if List.mem req
!Flag_parsing_cocci.defined_virtual_rules
1415 | Ast.AntiDep antireq
| Ast.NeverDep antireq
->
1416 if List.mem antireq virt
1418 if not
(List.mem antireq
!Flag_parsing_cocci.defined_virtual_rules
)
1422 | Ast.AndDep
(d1
,d2
) ->
1423 (match (loop d1
, loop d2
) with
1424 (None
,_
) | (_
,None
) -> None
1425 | (Some
Ast.NoDep
,x) | (x,Some
Ast.NoDep
) -> x
1426 | (Some
x,Some y
) -> Some
(Ast.AndDep
(x,y
)))
1427 | Ast.OrDep
(d1
,d2
) ->
1428 (match (loop d1
, loop d2
) with
1430 | (Some
Ast.NoDep
,x) | (x,Some
Ast.NoDep
) | (None
,x) | (x,None
) -> x
1431 | (Some
x,Some y
) -> Some
(Ast.OrDep
(x,y
)))
1432 | Ast.NoDep
| Ast.FailDep
-> Some dep
1436 let rec parse file =
1438 let table = Common.full_charpos_to_pos
file in
1439 Common.with_open_infile
file (fun channel
->
1440 let lexbuf = Lexing.from_channel channel
in
1441 let get_tokens = tokens_all table file false lexbuf in
1442 Data.in_prolog
:= true;
1443 let initial_tokens = get_tokens [PC.TArobArob
;PC.TArob
] in
1444 Data.in_prolog
:= false;
1446 match initial_tokens with
1448 (match List.rev data
with
1449 ((PC.TArobArob
as x),_
)::_
| ((PC.TArob
as x),_
)::_
->
1450 let include_and_iso_files =
1451 parse_one "include and iso file names" PC.include_main
file data
in
1453 let (include_files
,iso_files
,virt
) =
1455 (function (include_files
,iso_files
,virt
) ->
1457 Data.Include s
-> (s
::include_files
,iso_files
,virt
)
1458 | Data.Iso s
-> (include_files
,s
::iso_files
,virt
)
1459 | Data.Virt l
-> (include_files
,iso_files
,l
@virt
))
1460 ([],[],[]) include_and_iso_files in
1462 List.iter
(function x -> Hashtbl.add
Lexer_cocci.rule_names
x ())
1465 let (extra_iso_files
, extra_rules
, extra_virt
) =
1466 let rec loop = function
1469 let (x,y
,z
) = loop rest
in
1471 loop (List.map
parse include_files
) in
1473 let parse_cocci_rule ruletype old_metas
1474 (rule_name
, dependencies
, iso
, dropiso
, exists
, is_expression
) =
1475 Ast0.rule_name
:= rule_name
;
1476 Data.inheritable_positions
:=
1477 rule_name
:: !Data.inheritable_positions
;
1479 (* get metavariable declarations *)
1480 let (metavars, inherited_metavars
) =
1481 get_metavars PC.meta_main
table file lexbuf in
1482 Hashtbl.add
Data.all_metadecls rule_name
metavars;
1483 Hashtbl.add
Lexer_cocci.rule_names rule_name
();
1484 Hashtbl.add
Lexer_cocci.all_metavariables rule_name
1486 (fun key
v rest
-> (key
,v)::rest
)
1487 Lexer_cocci.metavariables
[]);
1489 (* get transformation rules *)
1490 let (more
, tokens) = get_tokens [PC.TArobArob
; PC.TArob
] in
1491 let (minus_tokens
, _
) = split_token_stream tokens in
1492 let (_
, plus_tokens
) =
1493 split_token_stream (minus_to_nothing tokens) in
1496 print_tokens "minus tokens" minus_tokens;
1497 print_tokens "plus tokens" plus_tokens;
1500 let minus_tokens = consume_minus_positions minus_tokens in
1501 let minus_tokens = prepare_tokens minus_tokens in
1502 let plus_tokens = prepare_tokens plus_tokens in
1505 print_tokens "minus tokens" minus_tokens;
1506 print_tokens "plus tokens" plus_tokens;
1510 process_pragmas None
[]
1511 (fix (function x -> drop_double_dots (drop_empty_or x))
1512 (drop_when plus_tokens)) in
1514 print_tokens "plus tokens" plus_tokens;
1515 Printf.printf "before minus parse\n";
1519 then parse_one "minus" PC.minus_exp_main
file minus_tokens
1520 else parse_one "minus" PC.minus_main
file minus_tokens in
1522 Unparse_ast0.unparse minus_res;
1523 Printf.printf "before plus parse\n";
1526 if !Flag.sgrep_mode2
1527 then (* not actually used for anything, except context_neg *)
1529 (Iso_pattern.rebuild_mcode None
).VT0.rebuilder_rec_top_level
1533 then parse_one "plus" PC.plus_exp_main
file plus_tokens
1534 else parse_one "plus" PC.plus_main
file plus_tokens in
1536 Printf.printf "after plus parse\n";
1539 (if not
!Flag.sgrep_mode2
&&
1540 (any_modif minus_res or any_modif plus_res)
1541 then Data.inheritable_positions
:= []);
1543 Check_meta.check_meta rule_name old_metas inherited_metavars
1544 metavars minus_res plus_res;
1546 (more
, Ast0.CocciRule
((minus_res, metavars,
1547 (iso
, dropiso
, dependencies
, rule_name
, exists
)),
1548 (plus_res, metavars), ruletype
), metavars, tokens) in
1550 let rec collect_script_tokens = function
1551 [(PC.EOF
,_
)] | [(PC.TArobArob
,_
)] | [(PC.TArob
,_
)] -> ""
1552 | (PC.TScriptData
(s
),_
)::xs
-> s^
(collect_script_tokens xs
)
1556 Printf.printf
"%s\n" (token2c x))
1558 failwith
"Malformed script rule" in
1560 let parse_script_rule language old_metas deps
=
1561 let get_tokens = tokens_script_all table file false lexbuf in
1563 (* meta-variables *)
1567 get_script_metavars PC.script_meta_main
table file lexbuf) in
1569 let exists_in old_metas
(py
,(r
,m
)) =
1570 let test (rr
,mr
) x =
1571 let (ro
,vo
) = Ast.get_meta_name
x in
1572 ro
= rr
&& vo
= mr
in
1573 List.exists
(test (r
,m
)) old_metas
in
1577 let meta2c (r
,n
) = Printf.sprintf
"%s.%s" r n
in
1578 if not
(exists_in old_metas
x) then
1581 "Script references unknown meta-variable: %s"
1586 let (more
, tokens) = get_tokens [PC.TArobArob
; PC.TArob
] in
1587 let data = collect_script_tokens tokens in
1588 (more
,Ast0.ScriptRule
(language
, deps
, metavars, data),[],tokens) in
1590 let parse_if_script_rule k language
=
1591 let get_tokens = tokens_script_all table file false lexbuf in
1594 let (more
, tokens) = get_tokens [PC.TArobArob
; PC.TArob
] in
1595 let data = collect_script_tokens tokens in
1596 (more
,k
(language
, data),[],tokens) in
1598 let parse_iscript_rule =
1599 parse_if_script_rule
1600 (function (language
,data) ->
1601 Ast0.InitialScriptRule
(language
,data)) in
1603 let parse_fscript_rule =
1604 parse_if_script_rule
1605 (function (language
,data) ->
1606 Ast0.FinalScriptRule
(language
,data)) in
1608 let parse_rule old_metas starts_with_name
=
1610 get_rule_name PC.rule_name starts_with_name
get_tokens file
1613 Ast.CocciRulename
(Some s
, dep
, b
, c
, d
, e
) ->
1614 (match eval_depend dep virt
with
1616 parse_cocci_rule Ast.Normal old_metas
(s
,dep
,b
,c
,d
,e
)
1618 D.ignore_patch_or_match
:= true;
1620 parse_cocci_rule Ast.Normal old_metas
1621 (s
, Ast.FailDep
, b
, c
, d
, e
) in
1622 D.ignore_patch_or_match
:= false;
1624 | Ast.GeneratedRulename
(Some s
, dep
, b
, c
, d
, e
) ->
1625 (match eval_depend dep virt
with
1627 Data.in_generating
:= true;
1629 parse_cocci_rule Ast.Normal old_metas
(s
,dep
,b
,c
,d
,e
) in
1630 Data.in_generating
:= false;
1633 D.ignore_patch_or_match
:= true;
1634 Data.in_generating
:= true;
1636 parse_cocci_rule Ast.Normal old_metas
1637 (s
, Ast.FailDep
, b
, c
, d
, e
) in
1638 D.ignore_patch_or_match
:= false;
1639 Data.in_generating
:= false;
1641 | Ast.ScriptRulename
(l
,deps
) ->
1642 (match eval_depend deps virt
with
1643 Some deps
-> parse_script_rule l old_metas deps
1644 | None
-> parse_script_rule l old_metas
Ast.FailDep
)
1645 | Ast.InitialScriptRulename
(l
) -> parse_iscript_rule l
1646 | Ast.FinalScriptRulename
(l
) -> parse_fscript_rule l
1647 | _
-> failwith
"Malformed rule name" in
1649 let rec loop old_metas starts_with_name
=
1650 (!Data.init_rule
)();
1652 let gen_starts_with_name more
tokens =
1654 (match List.hd
(List.rev tokens) with
1655 (PC.TArobArob
,_
) -> false
1656 | (PC.TArob
,_
) -> true
1657 | _
-> failwith
"unexpected token")
1660 let (more
, rule
, metavars, tokens) =
1661 parse_rule old_metas starts_with_name
in
1664 (loop (metavars @ old_metas
) (gen_starts_with_name more
tokens))
1668 (function prev
-> function cur -> Common.union_set
cur prev
)
1669 iso_files extra_iso_files
,
1670 (* included rules first *)
1671 List.fold_left
(function prev
-> function cur -> cur@prev
)
1672 (loop [] (x = PC.TArob
)) (List.rev extra_rules
),
1673 List.fold_left
(@) virt extra_virt
(*no dups allowed*))
1674 | _
-> failwith
"unexpected code before the first rule\n")
1675 | (false,[(PC.TArobArob
,_
)]) | (false,[(PC.TArob
,_
)]) ->
1676 ([],([] : Ast0.parsed_rule list
),[] (*virtual rules*))
1677 | _
-> failwith
"unexpected code before the first rule\n" in
1680 (* parse to ast0 and then convert to ast *)
1681 let process file isofile verbose
=
1682 let extra_path = Filename.dirname
file in
1683 let (iso_files
, rules
, virt
) = parse file in
1688 | Some iso_file
-> parse_iso_files [] [Common.Left iso_file
] "" in
1689 let global_isos = parse_iso_files std_isos iso_files
extra_path in
1690 let rules = Unitary_ast0.do_unitary
rules in
1694 Ast0.ScriptRule
(a
,b
,c
,d
) -> [([],Ast.ScriptRule
(a
,b
,c
,d
))]
1695 | Ast0.InitialScriptRule
(a
,b
) -> [([],Ast.InitialScriptRule
(a
,b
))]
1696 | Ast0.FinalScriptRule
(a
,b
) -> [([],Ast.FinalScriptRule
(a
,b
))]
1699 (iso
, dropiso
, dependencies
, rule_name
, exists
)),
1700 (plus
, metavars),ruletype
) ->
1702 parse_iso_files global_isos
1703 (List.map
(function x -> Common.Left
x) iso
)
1706 (* check that dropped isos are actually available *)
1709 List.map
(function (_
,_
,nm
) -> nm
) chosen_isos in
1710 let local_iso_names = reserved_names @ iso_names in
1713 (function dropped
->
1714 not
(List.mem dropped
local_iso_names))
1717 ("invalid iso name " ^
bad_dropped ^
" in " ^ rule_name
)
1718 with Not_found
-> ());
1719 if List.mem
"all" dropiso
1721 if List.length dropiso
= 1
1723 else failwith
"disable all should only be by itself"
1724 else (* drop those isos *)
1726 (function (_
,_
,nm
) -> not
(List.mem nm dropiso
))
1728 List.iter
Iso_compile.process chosen_isos;
1730 match reserved_names with
1735 List.filter
(function x -> List.mem
x dropiso
) others
)
1738 "bad list of reserved names - all must be at start" in
1739 let minus = Test_exps.process minus in
1740 let minus = Compute_lines.compute_lines
false minus in
1741 let plus = Compute_lines.compute_lines
false plus in
1743 (* only relevant to Flag.make_hrule *)
1744 (* doesn't handle multiple minirules properly, but since
1745 we don't really handle them in lots of other ways, it
1746 doesn't seem very important *)
1750 [match Ast0.unwrap p
with
1752 (match List.map
Ast0.unwrap
(Ast0.undots c
) with
1753 [Ast0.Exp e
] -> true | _
-> false)
1755 let minus = Arity.minus_arity
minus in
1756 let ((metavars,minus),function_prototypes
) =
1757 Function_prototypes.process
1758 rule_name
metavars dropped_isos minus plus ruletype
in
1759 let plus = Adjust_pragmas.process plus in
1760 (* warning! context_neg side-effects its arguments *)
1761 let (m
,p
) = List.split (Context_neg.context_neg
minus plus) in
1762 Type_infer.type_infer p
;
1763 (if not
!Flag.sgrep_mode2
1764 then Insert_plus.insert_plus m p
(chosen_isos = []));
1765 Type_infer.type_infer
minus;
1766 let (extra_meta
, minus) =
1767 match (chosen_isos,ruletype
) with
1768 (* separate case for [] because applying isos puts
1769 some restrictions on the -+ code *)
1770 ([],_
) | (_
,Ast.Generated
) -> ([],minus)
1771 | _
-> Iso_pattern.apply_isos
chosen_isos minus rule_name
in
1772 (* after iso, because iso can intro ... *)
1773 let minus = Adjacency.compute_adjacency
minus in
1774 let minus = Comm_assoc.comm_assoc
minus rule_name dropiso
in
1776 if !Flag.sgrep_mode2
then minus
1777 else Single_statement.single_statement
minus in
1778 let minus = Simple_assignments.simple_assignments
minus in
1780 Ast0toast.ast0toast rule_name dependencies
dropped_isos
1781 exists
minus is_exp ruletype
in
1783 match function_prototypes
with
1784 None
-> [(extra_meta
@ metavars, minus_ast)]
1785 | Some mv_fp
-> [(extra_meta
@ metavars, minus_ast); mv_fp
])
1786 (* Ast0.CocciRule ((minus, metavarsm, (iso, dropiso, dependencies, rule_name, exists)), (plus, metavars))*)
1788 let parsed = List.concat
parsed in
1789 let disjd = Disjdistr.disj
parsed in
1791 let (metavars,code
,fvs
,neg_pos
,ua
,pos
) = Free_vars.free_vars
disjd in
1792 if !Flag_parsing_cocci.show_SP
1793 then List.iter
Pretty_print_cocci.unparse code
;
1796 Common.profile_code
"get_constants"
1797 (fun () -> Get_constants.get_constants code
) in (* for grep *)
1798 let glimpse_tokens2 =
1799 Common.profile_code
"get_glimpse_constants" (* for glimpse *)
1800 (fun () -> Get_constants2.get_constants code neg_pos
) in
1802 (metavars,code
,fvs
,neg_pos
,ua
,pos
,grep_tokens,glimpse_tokens2)