2 * Copyright 2010, INRIA, University of Copenhagen
3 * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
4 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
5 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
6 * This file is part of Coccinelle.
8 * Coccinelle is free software: you can redistribute it and/or modify
9 * it under the terms of the GNU General Public License as published by
10 * the Free Software Foundation, according to version 2 of the License.
12 * Coccinelle is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
17 * You should have received a copy of the GNU General Public License
18 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
20 * The authors reserve the right to distribute this or future versions of
21 * Coccinelle under other licenses.
25 (* splits the entire file into minus and plus fragments, and parses each
26 separately (thus duplicating work for the parsing of the context elements) *)
29 module PC
= Parser_cocci_menhir
30 module V0
= Visitor_ast0
31 module VT0
= Visitor_ast0_types
32 module Ast
= Ast_cocci
33 module Ast0
= Ast0_cocci
35 exception Bad_virt
of string
37 let pr = Printf.sprintf
38 (*let pr2 s = prerr_string s; prerr_string "\n"; flush stderr*)
39 let pr2 s
= Printf.printf
"%s\n" s
41 (* for isomorphisms. all should be at the front!!! *)
43 ["all";"optional_storage";"optional_qualifier";"value_format";"comm_assoc"]
45 (* ----------------------------------------------------------------------- *)
48 let line_type (d
,_
,_
,_
,_
,_
,_
,_
) = d
51 match line_type tok
with
52 D.MINUS
| D.OPTMINUS
| D.UNIQUEMINUS
-> ":-"
55 | D.CONTEXT
| D.UNIQUE
| D.OPT
-> ""
59 PC.TIdentifier
-> "identifier"
61 | PC.TParameter
-> "parameter"
62 | PC.TConstant
-> "constant"
63 | PC.TExpression
-> "expression"
64 | PC.TIdExpression
-> "idexpression"
65 | PC.TInitialiser
-> "initialiser"
66 | PC.TDeclaration
-> "declaration"
67 | PC.TField
-> "field"
68 | PC.TStatement
-> "statement"
69 | PC.TPosition
-> "position"
71 | PC.TFunction
-> "function"
72 | PC.TLocal
-> "local"
74 | PC.TFresh
-> "fresh"
75 | PC.TCppConcatOp
-> "##"
77 | PC.TContext
-> "context"
78 | PC.TTypedef
-> "typedef"
79 | PC.TDeclarer
-> "declarer"
80 | PC.TIterator
-> "iterator"
82 | PC.TRuleName str
-> "rule_name-"^str
83 | PC.TUsing
-> "using"
84 | PC.TVirtual
-> "virtual"
85 | PC.TPathIsoFile str
-> "path_iso_file-"^str
86 | PC.TDisable
-> "disable"
87 | PC.TExtends
-> "extends"
88 | PC.TDepends
-> "depends"
91 | PC.TNever
-> "never"
92 | PC.TExists
-> "exists"
93 | PC.TForall
-> "forall"
94 | PC.TError
-> "error"
95 | PC.TWords
-> "words"
96 | PC.TGenerated
-> "generated"
98 | PC.TNothing
-> "nothing"
100 | PC.Tchar
(clt
) -> "char"^
(line_type2c clt
)
101 | PC.Tshort
(clt
) -> "short"^
(line_type2c clt
)
102 | PC.Tint
(clt
) -> "int"^
(line_type2c clt
)
103 | PC.Tdouble
(clt
) -> "double"^
(line_type2c clt
)
104 | PC.Tfloat
(clt
) -> "float"^
(line_type2c clt
)
105 | PC.Tlong
(clt
) -> "long"^
(line_type2c clt
)
106 | PC.Tvoid
(clt
) -> "void"^
(line_type2c clt
)
107 | PC.Tsize_t
(clt
) -> "size_t"^
(line_type2c clt
)
108 | PC.Tssize_t
(clt
) -> "ssize_t"^
(line_type2c clt
)
109 | PC.Tptrdiff_t
(clt
) -> "ptrdiff_t"^
(line_type2c clt
)
110 | PC.Tstruct
(clt
) -> "struct"^
(line_type2c clt
)
111 | PC.Tunion
(clt
) -> "union"^
(line_type2c clt
)
112 | PC.Tenum
(clt
) -> "enum"^
(line_type2c clt
)
113 | PC.Tunsigned
(clt
) -> "unsigned"^
(line_type2c clt
)
114 | PC.Tsigned
(clt
) -> "signed"^
(line_type2c clt
)
115 | PC.Tstatic
(clt
) -> "static"^
(line_type2c clt
)
116 | PC.Tinline
(clt
) -> "inline"^
(line_type2c clt
)
117 | PC.Ttypedef
(clt
) -> "typedef"^
(line_type2c clt
)
118 | PC.Tattr
(s
,clt
) -> s^
(line_type2c clt
)
119 | PC.Tauto
(clt
) -> "auto"^
(line_type2c clt
)
120 | PC.Tregister
(clt
) -> "register"^
(line_type2c clt
)
121 | PC.Textern
(clt
) -> "extern"^
(line_type2c clt
)
122 | PC.Tconst
(clt
) -> "const"^
(line_type2c clt
)
123 | PC.Tvolatile
(clt
) -> "volatile"^
(line_type2c clt
)
125 | PC.TPragma
(Ast.Noindent s
,_
) -> s
126 | PC.TPragma
(Ast.Indent s
,_
) -> s
127 | PC.TIncludeL
(s
,clt
) -> (pr "#include \"%s\"" s
)^
(line_type2c clt
)
128 | PC.TIncludeNL
(s
,clt
) -> (pr "#include <%s>" s
)^
(line_type2c clt
)
129 | PC.TDefine
(clt
,_
) -> "#define"^
(line_type2c clt
)
130 | PC.TDefineParam
(clt
,_
,_
,_
) -> "#define_param"^
(line_type2c clt
)
131 | PC.TMinusFile
(s
,clt
) -> (pr "--- %s" s
)^
(line_type2c clt
)
132 | PC.TPlusFile
(s
,clt
) -> (pr "+++ %s" s
)^
(line_type2c clt
)
134 | PC.TInc
(clt
) -> "++"^
(line_type2c clt
)
135 | PC.TDec
(clt
) -> "--"^
(line_type2c clt
)
137 | PC.TIf
(clt
) -> "if"^
(line_type2c clt
)
138 | PC.TElse
(clt
) -> "else"^
(line_type2c clt
)
139 | PC.TWhile
(clt
) -> "while"^
(line_type2c clt
)
140 | PC.TFor
(clt
) -> "for"^
(line_type2c clt
)
141 | PC.TDo
(clt
) -> "do"^
(line_type2c clt
)
142 | PC.TSwitch
(clt
) -> "switch"^
(line_type2c clt
)
143 | PC.TCase
(clt
) -> "case"^
(line_type2c clt
)
144 | PC.TDefault
(clt
) -> "default"^
(line_type2c clt
)
145 | PC.TReturn
(clt
) -> "return"^
(line_type2c clt
)
146 | PC.TBreak
(clt
) -> "break"^
(line_type2c clt
)
147 | PC.TContinue
(clt
) -> "continue"^
(line_type2c clt
)
148 | PC.TGoto
(clt
) -> "goto"^
(line_type2c clt
)
149 | PC.TIdent
(s
,clt
) -> (pr "ident-%s" s
)^
(line_type2c clt
)
150 | PC.TTypeId
(s
,clt
) -> (pr "typename-%s" s
)^
(line_type2c clt
)
151 | PC.TDeclarerId
(s
,clt
) -> (pr "declarername-%s" s
)^
(line_type2c clt
)
152 | PC.TIteratorId
(s
,clt
) -> (pr "iteratorname-%s" s
)^
(line_type2c clt
)
153 | PC.TMetaDeclarer
(_
,_
,_
,clt
) -> "declmeta"^
(line_type2c clt
)
154 | PC.TMetaIterator
(_
,_
,_
,clt
) -> "itermeta"^
(line_type2c clt
)
156 | PC.TSizeof
(clt
) -> "sizeof"^
(line_type2c clt
)
158 | PC.TString
(x
,clt
) -> x^
(line_type2c clt
)
159 | PC.TChar
(x
,clt
) -> x^
(line_type2c clt
)
160 | PC.TFloat
(x
,clt
) -> x^
(line_type2c clt
)
161 | PC.TInt
(x
,clt
) -> x^
(line_type2c clt
)
163 | PC.TOrLog
(clt
) -> "||"^
(line_type2c clt
)
164 | PC.TAndLog
(clt
) -> "&&"^
(line_type2c clt
)
165 | PC.TOr
(clt
) -> "|"^
(line_type2c clt
)
166 | PC.TXor
(clt
) -> "^"^
(line_type2c clt
)
167 | PC.TAnd
(clt
) -> "&"^
(line_type2c clt
)
168 | PC.TEqEq
(clt
) -> "=="^
(line_type2c clt
)
169 | PC.TNotEq
(clt
) -> "!="^
(line_type2c clt
)
170 | PC.TSub
(clt
) -> "<="^
(line_type2c clt
)
171 | PC.TTildeEq
(clt
) -> "~="^
(line_type2c clt
)
172 | PC.TTildeExclEq
(clt
) -> "~!="^
(line_type2c clt
)
173 | PC.TLogOp
(op
,clt
) ->
179 | _
-> failwith
"not possible")
181 | PC.TShLOp
(op
,clt
) -> "<<"^
(line_type2c clt
)
182 | PC.TShROp
(op
,clt
) -> ">>"^
(line_type2c clt
)
183 | PC.TPlus
(clt
) -> "+"^
(line_type2c clt
)
184 | PC.TMinus
(clt
) -> "-"^
(line_type2c clt
)
185 | PC.TMul
(clt
) -> "*"^
(line_type2c clt
)
186 | PC.TDmOp
(op
,clt
) ->
190 | _
-> failwith
"not possible")
192 | PC.TTilde
(clt
) -> "~"^
(line_type2c clt
)
194 | PC.TMetaParam
(_
,_
,clt
) -> "parammeta"^
(line_type2c clt
)
195 | PC.TMetaParamList
(_
,_
,_
,clt
) -> "paramlistmeta"^
(line_type2c clt
)
196 | PC.TMetaConst
(_
,_
,_
,_
,clt
) -> "constmeta"^
(line_type2c clt
)
197 | PC.TMetaErr
(_
,_
,_
,clt
) -> "errmeta"^
(line_type2c clt
)
198 | PC.TMetaExp
(_
,_
,_
,_
,clt
) -> "expmeta"^
(line_type2c clt
)
199 | PC.TMetaIdExp
(_
,_
,_
,_
,clt
) -> "idexpmeta"^
(line_type2c clt
)
200 | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
) -> "localidexpmeta"^
(line_type2c clt
)
201 | PC.TMetaExpList
(_
,_
,_
,clt
) -> "explistmeta"^
(line_type2c clt
)
202 | PC.TMetaId
(_
,_
,_
,clt
) -> "idmeta"^
(line_type2c clt
)
203 | PC.TMetaType
(_
,_
,clt
) -> "typemeta"^
(line_type2c clt
)
204 | PC.TMetaInit
(_
,_
,clt
) -> "initmeta"^
(line_type2c clt
)
205 | PC.TMetaDecl
(_
,_
,clt
) -> "declmeta"^
(line_type2c clt
)
206 | PC.TMetaField
(_
,_
,clt
) -> "fieldmeta"^
(line_type2c clt
)
207 | PC.TMetaStm
(_
,_
,clt
) -> "stmmeta"^
(line_type2c clt
)
208 | PC.TMetaStmList
(_
,_
,clt
) -> "stmlistmeta"^
(line_type2c clt
)
209 | PC.TMetaFunc
(_
,_
,_
,clt
) -> "funcmeta"^
(line_type2c clt
)
210 | PC.TMetaLocalFunc
(_
,_
,_
,clt
) -> "funcmeta"^
(line_type2c clt
)
211 | PC.TMetaPos
(_
,_
,_
,clt
) -> "posmeta"
213 | PC.TArobArob
-> "@@"
216 | PC.TScript
-> "script"
217 | PC.TInitialize
-> "initialize"
218 | PC.TFinalize
-> "finalize"
220 | PC.TWhen
(clt
) -> "WHEN"^
(line_type2c clt
)
221 | PC.TWhenTrue
(clt
) -> "WHEN TRUE"^
(line_type2c clt
)
222 | PC.TWhenFalse
(clt
) -> "WHEN FALSE"^
(line_type2c clt
)
223 | PC.TAny
(clt
) -> "ANY"^
(line_type2c clt
)
224 | PC.TStrict
(clt
) -> "STRICT"^
(line_type2c clt
)
225 | PC.TEllipsis
(clt
) -> "..."^
(line_type2c clt
)
227 | PC.TCircles(clt) -> "ooo"^(line_type2c clt)
228 | PC.TStars(clt) -> "***"^(line_type2c clt)
231 | PC.TOEllipsis
(clt
) -> "<..."^
(line_type2c clt
)
232 | PC.TCEllipsis
(clt
) -> "...>"^
(line_type2c clt
)
233 | PC.TPOEllipsis
(clt
) -> "<+..."^
(line_type2c clt
)
234 | PC.TPCEllipsis
(clt
) -> "...+>"^
(line_type2c clt
)
236 | PC.TOCircles(clt) -> "<ooo"^(line_type2c clt)
237 | PC.TCCircles(clt) -> "ooo>"^(line_type2c clt)
238 | PC.TOStars(clt) -> "<***"^(line_type2c clt)
239 | PC.TCStars(clt) -> "***>"^(line_type2c clt)
245 | PC.TWhy
(clt
) -> "?"^
(line_type2c clt
)
246 | PC.TDotDot
(clt
) -> ":"^
(line_type2c clt
)
247 | PC.TBang
(clt
) -> "!"^
(line_type2c clt
)
248 | PC.TOPar
(clt
) -> "("^
(line_type2c clt
)
249 | PC.TOPar0
(clt
) -> "("^
(line_type2c clt
)
250 | PC.TMid0
(clt
) -> "|"^
(line_type2c clt
)
251 | PC.TCPar
(clt
) -> ")"^
(line_type2c clt
)
252 | PC.TCPar0
(clt
) -> ")"^
(line_type2c clt
)
254 | PC.TOBrace
(clt
) -> "{"^
(line_type2c clt
)
255 | PC.TCBrace
(clt
) -> "}"^
(line_type2c clt
)
256 | PC.TOCro
(clt
) -> "["^
(line_type2c clt
)
257 | PC.TCCro
(clt
) -> "]"^
(line_type2c clt
)
258 | PC.TOInit
(clt
) -> "{"^
(line_type2c clt
)
260 | PC.TPtrOp
(clt
) -> "->"^
(line_type2c clt
)
262 | PC.TEq
(clt
) -> "="^
(line_type2c clt
)
263 | PC.TAssign
(_
,clt
) -> "=op"^
(line_type2c clt
)
264 | PC.TDot
(clt
) -> "."^
(line_type2c clt
)
265 | PC.TComma
(clt
) -> ","^
(line_type2c clt
)
266 | PC.TPtVirg
(clt
) -> ";"^
(line_type2c clt
)
269 | PC.TLineEnd
(clt
) -> "line end"
270 | PC.TInvalid
-> "invalid"
271 | PC.TFunDecl
(clt
) -> "fundecl"
274 | PC.TRightIso
-> "=>"
275 | PC.TIsoTopLevel
-> "TopLevel"
276 | PC.TIsoExpression
-> "Expression"
277 | PC.TIsoArgExpression
-> "ArgExpression"
278 | PC.TIsoTestExpression
-> "TestExpression"
279 | PC.TIsoToTestExpression
-> "ToTestExpression"
280 | PC.TIsoStatement
-> "Statement"
281 | PC.TIsoDeclaration
-> "Declaration"
282 | PC.TIsoType
-> "Type"
283 | PC.TUnderscore
-> "_"
284 | PC.TScriptData s
-> s
286 let print_tokens s tokens
=
287 Printf.printf
"%s\n" s
;
288 List.iter
(function x
-> Printf.printf
"%s " (token2c x
)) tokens
;
289 Printf.printf
"\n\n";
292 type plus
= PLUS
| NOTPLUS
| SKIP
294 let plus_attachable only_plus
(tok
,_
) =
296 PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
297 | PC.Tfloat
(clt
) | PC.Tlong
(clt
)
298 | PC.Tsize_t
(clt
) | PC.Tssize_t
(clt
) | PC.Tptrdiff_t
(clt
)
300 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
302 | PC.Tinline
(clt
) | PC.Ttypedef
(clt
) | PC.Tattr
(_
,clt
)
303 | PC.Tauto
(clt
) | PC.Tregister
(clt
)
304 | PC.Textern
(clt
) | PC.Tconst
(clt
) | PC.Tvolatile
(clt
)
306 | PC.TIncludeL
(_
,clt
) | PC.TIncludeNL
(_
,clt
) | PC.TDefine
(clt
,_
)
307 | PC.TDefineParam
(clt
,_
,_
,_
) | PC.TMinusFile
(_
,clt
) | PC.TPlusFile
(_
,clt
)
309 | PC.TInc
(clt
) | PC.TDec
(clt
)
311 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
312 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
) | PC.TReturn
(clt
)
313 | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
) | PC.TIdent
(_
,clt
)
314 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
318 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
)
320 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
321 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TTildeEq
(clt
)
323 | PC.TShLOp
(_
,clt
) | PC.TShROp
(_
,clt
)
324 | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
325 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
)
327 | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
328 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaErr
(_
,_
,_
,clt
)
329 | PC.TMetaExp
(_
,_
,_
,_
,clt
) | PC.TMetaIdExp
(_
,_
,_
,_
,clt
)
330 | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
331 | PC.TMetaExpList
(_
,_
,_
,clt
)
332 | PC.TMetaId
(_
,_
,_
,clt
)
333 | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
) | PC.TMetaStm
(_
,_
,clt
)
334 | PC.TMetaStmList
(_
,_
,clt
) | PC.TMetaDecl
(_
,_
,clt
) | PC.TMetaField
(_
,_
,clt
)
335 | PC.TMetaFunc
(_
,_
,_
,clt
) | PC.TMetaLocalFunc
(_
,_
,_
,clt
)
337 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
)
338 | PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TEllipsis
(clt
)
339 (* | PC.TCircles(clt) | PC.TStars(clt) *)
340 | PC.TOEllipsis
(clt
) | PC.TCEllipsis
(clt
)
341 | PC.TPOEllipsis
(clt
) | PC.TPCEllipsis
(clt
) (* | PC.TOCircles(clt)
342 | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *)
344 | PC.TWhy
(clt
) | PC.TDotDot
(clt
) | PC.TBang
(clt
) | PC.TOPar
(clt
)
347 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOCro
(clt
) | PC.TCCro
(clt
)
352 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
354 if List.mem
(line_type clt
) [D.PLUS
;D.PLUSPLUS
]
356 else if only_plus
then NOTPLUS
357 else if line_type clt
= D.CONTEXT
then PLUS
else NOTPLUS
359 | PC.TOPar0
(clt
) | PC.TMid0
(clt
) | PC.TCPar0
(clt
) -> NOTPLUS
360 | PC.TMetaPos
(nm
,_
,_
,_
) -> NOTPLUS
361 | PC.TSub
(clt
) -> NOTPLUS
365 let get_clt (tok
,_
) =
367 PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
368 | PC.Tfloat
(clt
) | PC.Tlong
(clt
) | PC.Tvoid
(clt
)
369 | PC.Tsize_t
(clt
) | PC.Tssize_t
(clt
) | PC.Tptrdiff_t
(clt
)
371 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
373 | PC.Tinline
(clt
) | PC.Tattr
(_
,clt
) | PC.Tauto
(clt
) | PC.Tregister
(clt
)
374 | PC.Textern
(clt
) | PC.Tconst
(clt
) | PC.Tvolatile
(clt
)
376 | PC.TIncludeL
(_
,clt
) | PC.TIncludeNL
(_
,clt
) | PC.TDefine
(clt
,_
)
377 | PC.TDefineParam
(clt
,_
,_
,_
) | PC.TMinusFile
(_
,clt
) | PC.TPlusFile
(_
,clt
)
379 | PC.TInc
(clt
) | PC.TDec
(clt
)
381 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
382 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
) | PC.TReturn
(clt
)
383 | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
) | PC.TIdent
(_
,clt
)
384 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
388 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
)
390 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
391 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TTildeEq
(clt
)
392 | PC.TSub
(clt
) | PC.TLogOp
(_
,clt
)
393 | PC.TShLOp
(_
,clt
) | PC.TShROp
(_
,clt
)
394 | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
395 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
)
397 | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
398 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaErr
(_
,_
,_
,clt
)
399 | PC.TMetaExp
(_
,_
,_
,_
,clt
) | PC.TMetaIdExp
(_
,_
,_
,_
,clt
)
400 | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
401 | PC.TMetaExpList
(_
,_
,_
,clt
)
402 | PC.TMetaId
(_
,_
,_
,clt
)
403 | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
) | PC.TMetaStm
(_
,_
,clt
)
404 | PC.TMetaStmList
(_
,_
,clt
) | PC.TMetaDecl
(_
,_
,clt
) | PC.TMetaField
(_
,_
,clt
)
405 | PC.TMetaFunc
(_
,_
,_
,clt
) | PC.TMetaLocalFunc
(_
,_
,_
,clt
)
406 | PC.TMetaPos
(_
,_
,_
,clt
)
408 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
) |
409 PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TEllipsis
(clt
)
410 (* | PC.TCircles(clt) | PC.TStars(clt) *)
412 | PC.TWhy
(clt
) | PC.TDotDot
(clt
) | PC.TBang
(clt
) | PC.TOPar
(clt
)
415 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOCro
(clt
) | PC.TCCro
(clt
)
420 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
423 | PC.TOPar0
(clt
) | PC.TMid0
(clt
) | PC.TCPar0
(clt
)
424 | PC.TOEllipsis
(clt
) | PC.TCEllipsis
(clt
)
425 | PC.TPOEllipsis
(clt
) | PC.TPCEllipsis
(clt
) (* | PC.TOCircles(clt)
426 | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *) -> clt
428 | _
-> failwith
"no clt"
430 let update_clt (tok
,x
) clt
=
432 PC.Tchar
(_
) -> (PC.Tchar
(clt
),x
)
433 | PC.Tshort
(_
) -> (PC.Tshort
(clt
),x
)
434 | PC.Tint
(_
) -> (PC.Tint
(clt
),x
)
435 | PC.Tdouble
(_
) -> (PC.Tdouble
(clt
),x
)
436 | PC.Tfloat
(_
) -> (PC.Tfloat
(clt
),x
)
437 | PC.Tlong
(_
) -> (PC.Tlong
(clt
),x
)
438 | PC.Tvoid
(_
) -> (PC.Tvoid
(clt
),x
)
439 | PC.Tsize_t
(_
) -> (PC.Tsize_t
(clt
),x
)
440 | PC.Tssize_t
(_
) -> (PC.Tssize_t
(clt
),x
)
441 | PC.Tptrdiff_t
(_
) -> (PC.Tptrdiff_t
(clt
),x
)
442 | PC.Tstruct
(_
) -> (PC.Tstruct
(clt
),x
)
443 | PC.Tunion
(_
) -> (PC.Tunion
(clt
),x
)
444 | PC.Tenum
(_
) -> (PC.Tenum
(clt
),x
)
445 | PC.Tunsigned
(_
) -> (PC.Tunsigned
(clt
),x
)
446 | PC.Tsigned
(_
) -> (PC.Tsigned
(clt
),x
)
447 | PC.Tstatic
(_
) -> (PC.Tstatic
(clt
),x
)
448 | PC.Tinline
(_
) -> (PC.Tinline
(clt
),x
)
449 | PC.Ttypedef
(_
) -> (PC.Ttypedef
(clt
),x
)
450 | PC.Tattr
(s
,_
) -> (PC.Tattr
(s
,clt
),x
)
451 | PC.Tauto
(_
) -> (PC.Tauto
(clt
),x
)
452 | PC.Tregister
(_
) -> (PC.Tregister
(clt
),x
)
453 | PC.Textern
(_
) -> (PC.Textern
(clt
),x
)
454 | PC.Tconst
(_
) -> (PC.Tconst
(clt
),x
)
455 | PC.Tvolatile
(_
) -> (PC.Tvolatile
(clt
),x
)
457 | PC.TIncludeL
(s
,_
) -> (PC.TIncludeL
(s
,clt
),x
)
458 | PC.TIncludeNL
(s
,_
) -> (PC.TIncludeNL
(s
,clt
),x
)
459 | PC.TDefine
(_
,a
) -> (PC.TDefine
(clt
,a
),x
)
460 | PC.TDefineParam
(_
,a
,b
,c
) -> (PC.TDefineParam
(clt
,a
,b
,c
),x
)
461 | PC.TMinusFile
(s
,_
) -> (PC.TMinusFile
(s
,clt
),x
)
462 | PC.TPlusFile
(s
,_
) -> (PC.TPlusFile
(s
,clt
),x
)
464 | PC.TInc
(_
) -> (PC.TInc
(clt
),x
)
465 | PC.TDec
(_
) -> (PC.TDec
(clt
),x
)
467 | PC.TIf
(_
) -> (PC.TIf
(clt
),x
)
468 | PC.TElse
(_
) -> (PC.TElse
(clt
),x
)
469 | PC.TWhile
(_
) -> (PC.TWhile
(clt
),x
)
470 | PC.TFor
(_
) -> (PC.TFor
(clt
),x
)
471 | PC.TDo
(_
) -> (PC.TDo
(clt
),x
)
472 | PC.TSwitch
(_
) -> (PC.TSwitch
(clt
),x
)
473 | PC.TCase
(_
) -> (PC.TCase
(clt
),x
)
474 | PC.TDefault
(_
) -> (PC.TDefault
(clt
),x
)
475 | PC.TReturn
(_
) -> (PC.TReturn
(clt
),x
)
476 | PC.TBreak
(_
) -> (PC.TBreak
(clt
),x
)
477 | PC.TContinue
(_
) -> (PC.TContinue
(clt
),x
)
478 | PC.TGoto
(_
) -> (PC.TGoto
(clt
),x
)
479 | PC.TIdent
(s
,_
) -> (PC.TIdent
(s
,clt
),x
)
480 | PC.TTypeId
(s
,_
) -> (PC.TTypeId
(s
,clt
),x
)
481 | PC.TDeclarerId
(s
,_
) -> (PC.TDeclarerId
(s
,clt
),x
)
482 | PC.TIteratorId
(s
,_
) -> (PC.TIteratorId
(s
,clt
),x
)
484 | PC.TSizeof
(_
) -> (PC.TSizeof
(clt
),x
)
486 | PC.TString
(s
,_
) -> (PC.TString
(s
,clt
),x
)
487 | PC.TChar
(s
,_
) -> (PC.TChar
(s
,clt
),x
)
488 | PC.TFloat
(s
,_
) -> (PC.TFloat
(s
,clt
),x
)
489 | PC.TInt
(s
,_
) -> (PC.TInt
(s
,clt
),x
)
491 | PC.TOrLog
(_
) -> (PC.TOrLog
(clt
),x
)
492 | PC.TAndLog
(_
) -> (PC.TAndLog
(clt
),x
)
493 | PC.TOr
(_
) -> (PC.TOr
(clt
),x
)
494 | PC.TXor
(_
) -> (PC.TXor
(clt
),x
)
495 | PC.TAnd
(_
) -> (PC.TAnd
(clt
),x
)
496 | PC.TEqEq
(_
) -> (PC.TEqEq
(clt
),x
)
497 | PC.TNotEq
(_
) -> (PC.TNotEq
(clt
),x
)
498 | PC.TTildeEq
(_
) -> (PC.TTildeEq
(clt
),x
)
499 | PC.TSub
(_
) -> (PC.TSub
(clt
),x
)
500 | PC.TLogOp
(op
,_
) -> (PC.TLogOp
(op
,clt
),x
)
501 | PC.TShLOp
(op
,_
) -> (PC.TShLOp
(op
,clt
),x
)
502 | PC.TShROp
(op
,_
) -> (PC.TShROp
(op
,clt
),x
)
503 | PC.TPlus
(_
) -> (PC.TPlus
(clt
),x
)
504 | PC.TMinus
(_
) -> (PC.TMinus
(clt
),x
)
505 | PC.TMul
(_
) -> (PC.TMul
(clt
),x
)
506 | PC.TDmOp
(op
,_
) -> (PC.TDmOp
(op
,clt
),x
)
507 | PC.TTilde
(_
) -> (PC.TTilde
(clt
),x
)
509 | PC.TMetaParam
(a
,b
,_
) -> (PC.TMetaParam
(a
,b
,clt
),x
)
510 | PC.TMetaParamList
(a
,b
,c
,_
) -> (PC.TMetaParamList
(a
,b
,c
,clt
),x
)
511 | PC.TMetaConst
(a
,b
,c
,d
,_
) -> (PC.TMetaConst
(a
,b
,c
,d
,clt
),x
)
512 | PC.TMetaErr
(a
,b
,c
,_
) -> (PC.TMetaErr
(a
,b
,c
,clt
),x
)
513 | PC.TMetaExp
(a
,b
,c
,d
,_
) -> (PC.TMetaExp
(a
,b
,c
,d
,clt
),x
)
514 | PC.TMetaIdExp
(a
,b
,c
,d
,_
) -> (PC.TMetaIdExp
(a
,b
,c
,d
,clt
),x
)
515 | PC.TMetaLocalIdExp
(a
,b
,c
,d
,_
) -> (PC.TMetaLocalIdExp
(a
,b
,c
,d
,clt
),x
)
516 | PC.TMetaExpList
(a
,b
,c
,_
) -> (PC.TMetaExpList
(a
,b
,c
,clt
),x
)
517 | PC.TMetaId
(a
,b
,c
,_
) -> (PC.TMetaId
(a
,b
,c
,clt
),x
)
518 | PC.TMetaType
(a
,b
,_
) -> (PC.TMetaType
(a
,b
,clt
),x
)
519 | PC.TMetaInit
(a
,b
,_
) -> (PC.TMetaInit
(a
,b
,clt
),x
)
520 | PC.TMetaDecl
(a
,b
,_
) -> (PC.TMetaDecl
(a
,b
,clt
),x
)
521 | PC.TMetaField
(a
,b
,_
) -> (PC.TMetaField
(a
,b
,clt
),x
)
522 | PC.TMetaStm
(a
,b
,_
) -> (PC.TMetaStm
(a
,b
,clt
),x
)
523 | PC.TMetaStmList
(a
,b
,_
) -> (PC.TMetaStmList
(a
,b
,clt
),x
)
524 | PC.TMetaFunc
(a
,b
,c
,_
) -> (PC.TMetaFunc
(a
,b
,c
,clt
),x
)
525 | PC.TMetaLocalFunc
(a
,b
,c
,_
) -> (PC.TMetaLocalFunc
(a
,b
,c
,clt
),x
)
527 | PC.TWhen
(_
) -> (PC.TWhen
(clt
),x
)
528 | PC.TWhenTrue
(_
) -> (PC.TWhenTrue
(clt
),x
)
529 | PC.TWhenFalse
(_
) -> (PC.TWhenFalse
(clt
),x
)
530 | PC.TAny
(_
) -> (PC.TAny
(clt
),x
)
531 | PC.TStrict
(_
) -> (PC.TStrict
(clt
),x
)
532 | PC.TEllipsis
(_
) -> (PC.TEllipsis
(clt
),x
)
534 | PC.TCircles(_) -> (PC.TCircles(clt),x)
535 | PC.TStars(_) -> (PC.TStars(clt),x)
538 | PC.TOEllipsis
(_
) -> (PC.TOEllipsis
(clt
),x
)
539 | PC.TCEllipsis
(_
) -> (PC.TCEllipsis
(clt
),x
)
540 | PC.TPOEllipsis
(_
) -> (PC.TPOEllipsis
(clt
),x
)
541 | PC.TPCEllipsis
(_
) -> (PC.TPCEllipsis
(clt
),x
)
543 | PC.TOCircles(_) -> (PC.TOCircles(clt),x)
544 | PC.TCCircles(_) -> (PC.TCCircles(clt),x)
545 | PC.TOStars(_) -> (PC.TOStars(clt),x)
546 | PC.TCStars(_) -> (PC.TCStars(clt),x)
549 | PC.TWhy
(_
) -> (PC.TWhy
(clt
),x
)
550 | PC.TDotDot
(_
) -> (PC.TDotDot
(clt
),x
)
551 | PC.TBang
(_
) -> (PC.TBang
(clt
),x
)
552 | PC.TOPar
(_
) -> (PC.TOPar
(clt
),x
)
553 | PC.TOPar0
(_
) -> (PC.TOPar0
(clt
),x
)
554 | PC.TMid0
(_
) -> (PC.TMid0
(clt
),x
)
555 | PC.TCPar
(_
) -> (PC.TCPar
(clt
),x
)
556 | PC.TCPar0
(_
) -> (PC.TCPar0
(clt
),x
)
558 | PC.TOBrace
(_
) -> (PC.TOBrace
(clt
),x
)
559 | PC.TCBrace
(_
) -> (PC.TCBrace
(clt
),x
)
560 | PC.TOCro
(_
) -> (PC.TOCro
(clt
),x
)
561 | PC.TCCro
(_
) -> (PC.TCCro
(clt
),x
)
562 | PC.TOInit
(_
) -> (PC.TOInit
(clt
),x
)
564 | PC.TPtrOp
(_
) -> (PC.TPtrOp
(clt
),x
)
566 | PC.TEq
(_
) -> (PC.TEq
(clt
),x
)
567 | PC.TAssign
(s
,_
) -> (PC.TAssign
(s
,clt
),x
)
568 | PC.TDot
(_
) -> (PC.TDot
(clt
),x
)
569 | PC.TComma
(_
) -> (PC.TComma
(clt
),x
)
570 | PC.TPtVirg
(_
) -> (PC.TPtVirg
(clt
),x
)
572 | PC.TLineEnd
(_
) -> (PC.TLineEnd
(clt
),x
)
573 | PC.TFunDecl
(_
) -> (PC.TFunDecl
(clt
),x
)
575 | _
-> failwith
"no clt"
578 (* ----------------------------------------------------------------------- *)
580 let make_name prefix ln
= Printf.sprintf
"%s starting on line %d" prefix ln
582 (* ----------------------------------------------------------------------- *)
585 let wrap_lexbuf_info lexbuf
=
586 (Lexing.lexeme lexbuf
, Lexing.lexeme_start lexbuf
)
588 let tokens_all_full token table file get_ats lexbuf end_markers
:
589 (bool * ((PC.token
* (string * (int * int) * (int * int))) list
)) =
592 let result = token lexbuf
in
593 let info = (Lexing.lexeme lexbuf
,
594 (table
.(Lexing.lexeme_start lexbuf
)),
595 (Lexing.lexeme_start lexbuf
, Lexing.lexeme_end lexbuf
)) in
599 then failwith
"unexpected end of file in a metavariable declaration"
600 else (false,[(result,info)])
601 else if List.mem
result end_markers
602 then (true,[(result,info)])
604 let (more
,rest
) = aux() in
605 (more
,(result, info)::rest
)
608 e
-> pr2 (Common.error_message file
(wrap_lexbuf_info lexbuf
) ); raise e
610 let tokens_all table file get_ats lexbuf end_markers
:
611 (bool * ((PC.token
* (string * (int * int) * (int * int))) list
)) =
612 tokens_all_full Lexer_cocci.token table file get_ats lexbuf end_markers
614 let tokens_script_all table file get_ats lexbuf end_markers
:
615 (bool * ((PC.token
* (string * (int * int) * (int * int))) list
)) =
616 tokens_all_full Lexer_script.token table file get_ats lexbuf end_markers
618 (* ----------------------------------------------------------------------- *)
619 (* Split tokens into minus and plus fragments *)
622 let (d
,_
,_
,_
,_
,_
,_
,_
) = clt
in
624 D.MINUS
| D.OPTMINUS
| D.UNIQUEMINUS
-> ([t
],[])
625 | D.PLUS
| D.PLUSPLUS
-> ([],[t
])
626 | D.CONTEXT
| D.UNIQUE
| D.OPT
-> ([t
],[t
])
628 let split_token ((tok
,_
) as t
) =
630 PC.TIdentifier
| PC.TConstant
| PC.TExpression
| PC.TIdExpression
631 | PC.TDeclaration
| PC.TField
632 | PC.TStatement
| PC.TPosition
| PC.TPosAny
| PC.TInitialiser
633 | PC.TFunction
| PC.TTypedef
| PC.TDeclarer
| PC.TIterator
| PC.TName
634 | PC.TType
| PC.TParameter
| PC.TLocal
| PC.Tlist
| PC.TFresh
635 | PC.TCppConcatOp
| PC.TPure
636 | PC.TContext
| PC.TRuleName
(_
) | PC.TUsing
| PC.TVirtual
| PC.TDisable
637 | PC.TExtends
| PC.TPathIsoFile
(_
)
638 | PC.TDepends
| PC.TOn
| PC.TEver
| PC.TNever
| PC.TExists
| PC.TForall
639 | PC.TError
| PC.TWords
| PC.TGenerated
| PC.TNothing
-> ([t
],[t
])
641 | PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
642 | PC.Tfloat
(clt
) | PC.Tlong
(clt
) | PC.Tvoid
(clt
)
643 | PC.Tsize_t
(clt
) | PC.Tssize_t
(clt
) | PC.Tptrdiff_t
(clt
)
645 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
646 | PC.Tstatic
(clt
) | PC.Tauto
(clt
) | PC.Tregister
(clt
) | PC.Textern
(clt
)
647 | PC.Tinline
(clt
) | PC.Ttypedef
(clt
) | PC.Tattr
(_
,clt
)
648 | PC.Tconst
(clt
) | PC.Tvolatile
(clt
) -> split t clt
650 | PC.TPragma
(s
,_
) -> ([],[t
]) (* only allowed in + *)
651 | PC.TPlusFile
(s
,clt
) | PC.TMinusFile
(s
,clt
)
652 | PC.TIncludeL
(s
,clt
) | PC.TIncludeNL
(s
,clt
) ->
654 | PC.TDefine
(clt
,_
) | PC.TDefineParam
(clt
,_
,_
,_
) -> split t clt
656 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
657 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
)
659 | PC.TReturn
(clt
) | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
)
661 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
662 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaExp
(_
,_
,_
,_
,clt
)
663 | PC.TMetaIdExp
(_
,_
,_
,_
,clt
) | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
664 | PC.TMetaExpList
(_
,_
,_
,clt
)
665 | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
666 | PC.TMetaId
(_
,_
,_
,clt
) | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
)
667 | PC.TMetaDecl
(_
,_
,clt
) | PC.TMetaField
(_
,_
,clt
)
668 | PC.TMetaStm
(_
,_
,clt
) | PC.TMetaStmList
(_
,_
,clt
) | PC.TMetaErr
(_
,_
,_
,clt
)
669 | PC.TMetaFunc
(_
,_
,_
,clt
) | PC.TMetaLocalFunc
(_
,_
,_
,clt
)
670 | PC.TMetaDeclarer
(_
,_
,_
,clt
) | PC.TMetaIterator
(_
,_
,_
,clt
) -> split t clt
671 | PC.TMPtVirg
| PC.TArob
| PC.TArobArob
| PC.TScript
672 | PC.TInitialize
| PC.TFinalize
-> ([t
],[t
])
673 | PC.TPArob
| PC.TMetaPos
(_
,_
,_
,_
) -> ([t
],[])
676 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
)
677 | PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TLineEnd
(clt
)
678 | PC.TEllipsis
(clt
) (* | PC.TCircles(clt) | PC.TStars(clt) *)
679 | PC.TOEllipsis
(clt
) | PC.TCEllipsis
(clt
)
680 | PC.TPOEllipsis
(clt
) | PC.TPCEllipsis
(clt
) -> split t clt
683 | PC.TOCircles(_) | PC.TCCircles(_) (* clt must be context *)
684 | PC.TOStars
(_
) | PC.TCStars
(_
) (* clt must be context *)
687 | PC.TBang0
| PC.TPlus0
| PC.TWhy0
->
690 | PC.TWhy
(clt
) | PC.TDotDot
(clt
)
691 | PC.TBang
(clt
) | PC.TOPar
(clt
) | PC.TOPar0
(clt
)
692 | PC.TMid0
(clt
) | PC.TCPar
(clt
) | PC.TCPar0
(clt
) -> split t clt
694 | PC.TInc
(clt
) | PC.TDec
(clt
) -> split t clt
696 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
) ->
699 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
700 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TTildeEq
(clt
)
701 | PC.TTildeExclEq
(clt
) | PC.TSub
(clt
) | PC.TLogOp
(_
,clt
)
702 | PC.TShLOp
(_
,clt
) | PC.TShROp
(_
,clt
)
703 | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
704 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
) -> split t clt
706 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOInit
(clt
) -> split t clt
707 | PC.TOCro
(clt
) | PC.TCCro
(clt
) -> split t clt
709 | PC.TPtrOp
(clt
) -> split t clt
711 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
712 | PC.TPtVirg
(clt
) -> split t clt
714 | PC.EOF
| PC.TInvalid
| PC.TUnderscore
-> ([t
],[t
])
716 | PC.TIso
| PC.TRightIso
717 | PC.TIsoExpression
| PC.TIsoStatement
| PC.TIsoDeclaration
| PC.TIsoType
718 | PC.TIsoTopLevel
| PC.TIsoArgExpression
| PC.TIsoTestExpression
719 | PC.TIsoToTestExpression
->
720 failwith
"unexpected tokens"
721 | PC.TScriptData s
-> ([t
],[t
])
723 let split_token_stream tokens
=
724 let rec loop = function
727 let (minus
,plus
) = split_token token
in
728 let (minus_stream
,plus_stream
) = loop tokens
in
729 (minus
@minus_stream
,plus
@plus_stream
) in
732 (* ----------------------------------------------------------------------- *)
733 (* Find function names *)
734 (* This addresses a shift-reduce problem in the parser, allowing us to
735 distinguish a function declaration from a function call even if the latter
736 has no return type. Undoubtedly, this is not very nice, but it doesn't
737 seem very convenient to refactor the grammar to get around the problem. *)
739 let rec find_function_names = function
741 | ((PC.TIdent
(_
,clt
),info) as t1
) :: ((PC.TOPar
(_
),_
) as t2
) :: rest
742 | ((PC.TMetaId
(_
,_
,_
,clt
),info) as t1
) :: ((PC.TOPar
(_
),_
) as t2
) :: rest
743 | ((PC.TMetaFunc
(_
,_
,_
,clt
),info) as t1
) :: ((PC.TOPar
(_
),_
) as t2
) :: rest
744 | ((PC.TMetaLocalFunc
(_
,_
,_
,clt
),info) as t1
)::((PC.TOPar
(_
),_
) as t2
)::rest
746 let rec skip level
= function
748 | ((PC.TCPar
(_
),_
) as t
)::rest
->
749 let level = level - 1 in
752 else let (pre
,found
,post
) = skip level rest
in (t
::pre
,found
,post
)
753 | ((PC.TOPar
(_
),_
) as t
)::rest
->
754 let level = level + 1 in
755 let (pre
,found
,post
) = skip level rest
in (t
::pre
,found
,post
)
756 | ((PC.TArobArob
,_
) as t
)::rest
757 | ((PC.TArob
,_
) as t
)::rest
758 | ((PC.EOF
,_
) as t
)::rest
-> ([t
],false,rest
)
760 let (pre
,found
,post
) = skip level rest
in (t
::pre
,found
,post
) in
761 let (pre
,found
,post
) = skip 1 rest
in
762 (match (found
,post
) with
763 (true,((PC.TOBrace
(_
),_
) as t3
)::rest
) ->
764 (PC.TFunDecl
(clt
),info) :: t1
:: t2
:: pre
@
765 t3
:: (find_function_names rest
)
766 | _
-> t1
:: t2
:: pre
@ find_function_names post
)
767 | t
:: rest
-> t
:: find_function_names rest
769 (* ----------------------------------------------------------------------- *)
770 (* an attribute is an identifier that preceeds another identifier and
773 let rec detect_attr l
=
775 (PC.TIdent
(_
,_
),_
) | (PC.TMetaId
(_
,_
,_
,_
),_
) | (PC.TMetaFunc
(_
,_
,_
,_
),_
)
776 | (PC.TMetaLocalFunc
(_
,_
,_
,_
),_
) -> true
778 let rec loop = function
781 | ((PC.TIdent
(nm
,clt
),info) as t1
)::id
::rest
when is_id id
->
782 if String.length nm
> 2 && String.sub nm
0 2 = "__"
783 then (PC.Tattr
(nm
,clt
),info)::(loop (id
::rest
))
784 else t1
::(loop (id
::rest
))
785 | x
::xs
-> x
::(loop xs
) in
788 (* ----------------------------------------------------------------------- *)
789 (* Look for variable declarations where the name is a typedef name.
790 We assume that C code does not contain a multiplication as a top-level
793 (* bug: once a type, always a type, even if the same name is later intended
794 to be used as a real identifier *)
795 let detect_types in_meta_decls l
=
796 let is_delim infn
= function
797 (PC.TOEllipsis
(_
),_
) (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *)
798 | (PC.TPOEllipsis
(_
),_
) (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *)
799 | (PC.TEllipsis
(_
),_
) (* | (PC.TCircles(_),_) | (PC.TStars(_),_) *)
800 | (PC.TPtVirg
(_
),_
) | (PC.TOBrace
(_
),_
) | (PC.TOInit
(_
),_
)
802 | (PC.TPure
,_
) | (PC.TContext
,_
)
803 | (PC.Tstatic
(_
),_
) | (PC.Textern
(_
),_
)
804 | (PC.Tinline
(_
),_
) | (PC.Ttypedef
(_
),_
) | (PC.Tattr
(_
),_
) -> true
805 | (PC.TComma
(_
),_
) when infn
> 0 or in_meta_decls
-> true
806 | (PC.TDotDot
(_
),_
) when in_meta_decls
-> true
808 let is_choices_delim = function
809 (PC.TOBrace
(_
),_
) | (PC.TComma
(_
),_
) -> true | _
-> false in
811 (PC.TIdent
(_
,_
),_
) | (PC.TMetaId
(_
,_
,_
,_
),_
) | (PC.TMetaFunc
(_
,_
,_
,_
),_
)
812 | (PC.TMetaLocalFunc
(_
,_
,_
,_
),_
) -> true
813 | (PC.TMetaParam
(_
,_
,_
),_
)
814 | (PC.TMetaParamList
(_
,_
,_
,_
),_
)
815 | (PC.TMetaConst
(_
,_
,_
,_
,_
),_
)
816 | (PC.TMetaErr
(_
,_
,_
,_
),_
)
817 | (PC.TMetaExp
(_
,_
,_
,_
,_
),_
)
818 | (PC.TMetaIdExp
(_
,_
,_
,_
,_
),_
)
819 | (PC.TMetaLocalIdExp
(_
,_
,_
,_
,_
),_
)
820 | (PC.TMetaExpList
(_
,_
,_
,_
),_
)
821 | (PC.TMetaType
(_
,_
,_
),_
)
822 | (PC.TMetaInit
(_
,_
,_
),_
)
823 | (PC.TMetaDecl
(_
,_
,_
),_
)
824 | (PC.TMetaField
(_
,_
,_
),_
)
825 | (PC.TMetaStm
(_
,_
,_
),_
)
826 | (PC.TMetaStmList
(_
,_
,_
),_
)
827 | (PC.TMetaPos
(_
,_
,_
,_
),_
) -> in_meta_decls
829 let redo_id ident clt v
=
830 !Data.add_type_name ident
;
831 (PC.TTypeId
(ident
,clt
),v
) in
832 let rec loop start infn type_names
= function
833 (* infn: 0 means not in a function header
834 > 0 means in a function header, after infn - 1 unmatched open parens*)
836 | ((PC.TOBrace
(clt
),v
)::_
) as all
when in_meta_decls
->
837 collect_choices type_names all
(* never a function header *)
838 | delim
::(PC.TIdent
(ident
,clt
),v
)::((PC.TMul
(_
),_
) as x
)::rest
839 when is_delim infn delim
->
840 let newid = redo_id ident clt v
in
841 delim
::newid::x
::(loop false infn
(ident
::type_names
) rest
)
842 | delim
::(PC.TIdent
(ident
,clt
),v
)::id
::rest
843 when is_delim infn delim
&& is_id id
->
844 let newid = redo_id ident clt v
in
845 delim
::newid::id
::(loop false infn
(ident
::type_names
) rest
)
846 | ((PC.TFunDecl
(_
),_
) as fn
)::rest
->
847 fn
::(loop false 1 type_names rest
)
848 | ((PC.TOPar
(_
),_
) as lp
)::rest
when infn
> 0 ->
849 lp
::(loop false (infn
+ 1) type_names rest
)
850 | ((PC.TCPar
(_
),_
) as rp
)::rest
when infn
> 0 ->
852 then rp
::(loop false 0 type_names rest
) (* 0 means not in fn header *)
853 else rp
::(loop false (infn
- 1) type_names rest
)
854 | (PC.TIdent
(ident
,clt
),v
)::((PC.TMul
(_
),_
) as x
)::rest
when start
->
855 let newid = redo_id ident clt v
in
856 newid::x
::(loop false infn
(ident
::type_names
) rest
)
857 | (PC.TIdent
(ident
,clt
),v
)::id
::rest
when start
&& is_id id
->
858 let newid = redo_id ident clt v
in
859 newid::id
::(loop false infn
(ident
::type_names
) rest
)
860 | (PC.TIdent
(ident
,clt
),v
)::rest
when List.mem ident type_names
->
861 (PC.TTypeId
(ident
,clt
),v
)::(loop false infn type_names rest
)
862 | ((PC.TIdent
(ident
,clt
),v
) as x
)::rest
->
863 x
::(loop false infn type_names rest
)
864 | x
::rest
-> x
::(loop false infn type_names rest
)
865 and collect_choices type_names
= function
866 [] -> [] (* should happen, but let the parser detect that *)
867 | (PC.TCBrace
(clt
),v
)::rest
->
868 (PC.TCBrace
(clt
),v
)::(loop false 0 type_names rest
)
869 | delim
::(PC.TIdent
(ident
,clt
),v
)::rest
870 when is_choices_delim delim
->
871 let newid = redo_id ident clt v
in
872 delim
::newid::(collect_choices
(ident
::type_names
) rest
)
873 | x
::rest
-> x
::(collect_choices type_names rest
) in
877 (* ----------------------------------------------------------------------- *)
878 (* Insert TLineEnd tokens at the end of a line that contains a WHEN.
879 WHEN is restricted to a single line, to avoid ambiguity in eg:
883 let token2line (tok
,_
) =
885 PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
886 | PC.Tfloat
(clt
) | PC.Tlong
(clt
) | PC.Tvoid
(clt
)
887 | PC.Tsize_t
(clt
) | PC.Tssize_t
(clt
) | PC.Tptrdiff_t
(clt
)
889 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
890 | PC.Tstatic
(clt
) | PC.Tauto
(clt
) | PC.Tregister
(clt
) | PC.Textern
(clt
)
891 | PC.Tinline
(clt
) | PC.Ttypedef
(clt
) | PC.Tattr
(_
,clt
) | PC.Tconst
(clt
)
894 | PC.TInc
(clt
) | PC.TDec
(clt
)
896 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
897 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
) | PC.TSizeof
(clt
)
898 | PC.TReturn
(clt
) | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
)
900 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
901 | PC.TMetaDeclarer
(_
,_
,_
,clt
) | PC.TMetaIterator
(_
,_
,_
,clt
)
903 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
)
905 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
906 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TLogOp
(_
,clt
)
907 | PC.TShLOp
(_
,clt
) | PC.TShROp
(_
,clt
)
908 | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
909 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
)
911 | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
912 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaExp
(_
,_
,_
,_
,clt
)
913 | PC.TMetaIdExp
(_
,_
,_
,_
,clt
) | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
914 | PC.TMetaExpList
(_
,_
,_
,clt
)
915 | PC.TMetaId
(_
,_
,_
,clt
) | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
)
916 | PC.TMetaDecl
(_
,_
,clt
) | PC.TMetaField
(_
,_
,clt
)
917 | PC.TMetaStm
(_
,_
,clt
) | PC.TMetaStmList
(_
,_
,clt
) | PC.TMetaFunc
(_
,_
,_
,clt
)
918 | PC.TMetaLocalFunc
(_
,_
,_
,clt
) | PC.TMetaPos
(_
,_
,_
,clt
)
921 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
)
922 | PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TEllipsis
(clt
)
923 (* | PC.TCircles(clt) | PC.TStars(clt) *)
925 | PC.TOEllipsis
(clt
) | PC.TCEllipsis
(clt
)
926 | PC.TPOEllipsis
(clt
) | PC.TPCEllipsis
(clt
) (*| PC.TOCircles(clt)
927 | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *)
929 | PC.TWhy
(clt
) | PC.TDotDot
(clt
) | PC.TBang
(clt
) | PC.TOPar
(clt
)
930 | PC.TOPar0
(clt
) | PC.TMid0
(clt
) | PC.TCPar
(clt
)
933 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOCro
(clt
) | PC.TCCro
(clt
)
938 | PC.TDefine
(clt
,_
) | PC.TDefineParam
(clt
,_
,_
,_
)
939 | PC.TIncludeL
(_
,clt
) | PC.TIncludeNL
(_
,clt
)
941 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
943 let (_
,line
,_
,_
,_
,_
,_
,_
) = clt
in Some line
947 let rec insert_line_end = function
949 | (((PC.TWhen
(clt
),q
) as x
)::xs
) ->
950 x
::(find_line_end
true (token2line x
) clt q xs
)
951 | (((PC.TDefine
(clt
,_
),q
) as x
)::xs
)
952 | (((PC.TDefineParam
(clt
,_
,_
,_
),q
) as x
)::xs
) ->
953 x
::(find_line_end
false (token2line x
) clt q xs
)
954 | x
::xs
-> x
::(insert_line_end xs
)
956 and find_line_end inwhen line clt q
= function
957 (* don't know what 2nd component should be so just use the info of
958 the When. Also inherit - of when, if any *)
959 [] -> [(PC.TLineEnd
(clt
),q
)]
960 | ((PC.TIdent
("strict",clt
),a
) as x
)::xs
when token2line x
= line
->
961 (PC.TStrict
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
962 | ((PC.TIdent
("STRICT",clt
),a
) as x
)::xs
when token2line x
= line
->
963 (PC.TStrict
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
964 | ((PC.TIdent
("any",clt
),a
) as x
)::xs
when token2line x
= line
->
965 (PC.TAny
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
966 | ((PC.TIdent
("ANY",clt
),a
) as x
)::xs
when token2line x
= line
->
967 (PC.TAny
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
968 | ((PC.TIdent
("forall",clt
),a
) as x
)::xs
when token2line x
= line
->
969 (PC.TForall
,a
) :: (find_line_end inwhen line clt q xs
)
970 | ((PC.TIdent
("exists",clt
),a
) as x
)::xs
when token2line x
= line
->
971 (PC.TExists
,a
) :: (find_line_end inwhen line clt q xs
)
972 | ((PC.TComma
(clt
),a
) as x
)::xs
when token2line x
= line
->
973 (PC.TComma
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
974 | ((PC.TPArob
,a
) as x
)::xs
-> (* no line #, just assume on the same line *)
975 x
:: (find_line_end inwhen line clt q xs
)
976 | x
::xs
when token2line x
= line
-> x
:: (find_line_end inwhen line clt q xs
)
977 | xs
-> (PC.TLineEnd
(clt
),q
)::(insert_line_end xs
)
979 let rec translate_when_true_false = function
981 | (PC.TWhen
(clt
),q
)::((PC.TNotEq
(_
),_
) as x
)::(PC.TIdent
("true",_
),_
)::xs
->
982 (PC.TWhenTrue
(clt
),q
)::x
::(translate_when_true_false xs
)
983 | (PC.TWhen
(clt
),q
)::((PC.TNotEq
(_
),_
) as x
)::(PC.TIdent
("false",_
),_
)::xs
->
984 (PC.TWhenFalse
(clt
),q
)::x
::(translate_when_true_false xs
)
985 | x
::xs
-> x
:: (translate_when_true_false xs
)
987 (* ----------------------------------------------------------------------- *)
989 (* In a nest, if the nest is -, all of the nested code must also be -.
990 All are converted to context, because the next takes care of the -. *)
991 let check_nests tokens
=
993 let (line_type,a
,b
,c
,d
,e
,f
,g
) = get_clt t
in
994 List.mem
line_type [D.MINUS
;D.OPTMINUS
;D.UNIQUEMINUS
] in
996 let clt = try Some
(get_clt t
) with Failure _
-> None
in
998 Some
(line_type,a
,b
,c
,d
,e
,f
,g
) ->
999 (match line_type with
1000 D.MINUS
-> update_clt t
(D.CONTEXT
,a
,b
,c
,d
,e
,f
,g
)
1001 | D.OPTMINUS
-> update_clt t
(D.OPT
,a
,b
,c
,d
,e
,f
,g
)
1002 | D.UNIQUEMINUS
-> update_clt t
(D.UNIQUE
,a
,b
,c
,d
,e
,f
,g
)
1003 | _
-> failwith
"minus token expected")
1005 let rec outside = function
1007 | ((PC.TPOEllipsis
(clt),q
) as t
)::r
when is_minus t
-> t
:: inside
0 r
1008 | t
::r
-> t
:: outside r
1009 and inside stack
= function
1010 [] -> failwith
"missing nest end"
1011 | ((PC.TPCEllipsis
(clt),q
) as t
)::r
->
1013 :: (if stack
= 0 then outside r
else inside
(stack
- 1) r
)
1014 | ((PC.TPOEllipsis
(clt),q
) as t
)::r
->
1015 (drop_minus t
) :: (inside
(stack
+ 1) r
)
1016 | t
:: r
-> (drop_minus t
) :: (inside stack r
) in
1019 let check_parentheses tokens
=
1020 let clt2line (_
,line
,_
,_
,_
,_
,_
,_
) = line
in
1021 let rec loop seen_open
= function
1023 | (PC.TOPar
(clt),q
) :: rest
1024 | (PC.TDefineParam
(clt,_
,_
,_
),q
) :: rest
->
1025 loop (Common.Left
(clt2line clt) :: seen_open
) rest
1026 | (PC.TOPar0
(clt),q
) :: rest
->
1027 loop (Common.Right
(clt2line clt) :: seen_open
) rest
1028 | (PC.TCPar
(clt),q
) :: rest
->
1029 (match seen_open
with
1033 "unexpected close parenthesis in line %d\n" (clt2line clt))
1034 | Common.Left _
:: seen_open
-> loop seen_open rest
1035 | Common.Right open_line
:: _
->
1038 "disjunction parenthesis in line %d column 0 matched to normal parenthesis on line %d\n" open_line
(clt2line clt)))
1039 | (PC.TCPar0
(clt),q
) :: rest
->
1040 (match seen_open
with
1044 "unexpected close parenthesis in line %d\n" (clt2line clt))
1045 | Common.Right _
:: seen_open
-> loop seen_open rest
1046 | Common.Left open_line
:: _
->
1049 "normal parenthesis in line %d matched to disjunction parenthesis on line %d column 0\n" open_line
(clt2line clt)))
1050 | x
::rest
-> loop seen_open rest
in
1053 (* ----------------------------------------------------------------------- *)
1054 (* top level initializers: a sequence of braces followed by a dot *)
1056 let find_top_init tokens
=
1058 (PC.TOBrace
(clt),q
) :: rest
->
1059 let rec dot_start acc
= function
1060 ((PC.TOBrace
(_
),_
) as x
) :: rest
->
1061 dot_start (x
::acc
) rest
1062 | ((PC.TDot
(_
),_
) :: rest
) as x
->
1063 Some
((PC.TOInit
(clt),q
) :: (List.rev acc
) @ x
)
1065 let rec comma_end acc
= function
1066 ((PC.TCBrace
(_
),_
) as x
) :: rest
->
1067 comma_end (x
::acc
) rest
1068 | ((PC.TComma
(_
),_
) :: rest
) as x
->
1069 Some
((PC.TOInit
(clt),q
) :: (List.rev x
) @ acc
)
1071 (match dot_start [] rest
with
1074 (match List.rev rest
with
1075 (* not super sure what this does, but EOF, @, and @@ should be
1076 the same, markind the end of a rule *)
1077 ((PC.EOF
,_
) as x
)::rest
| ((PC.TArob
,_
) as x
)::rest
1078 | ((PC.TArobArob
,_
) as x
)::rest
->
1079 (match comma_end [x
] rest
with
1083 failwith
"unexpected empty token list"))
1086 (* ----------------------------------------------------------------------- *)
1087 (* Integrate pragmas into some adjacent token. + tokens are preferred. Dots
1090 let rec collect_all_pragmas collected
= function
1091 (PC.TPragma
(s
,(_
,line
,logical_line
,offset
,col
,_
,_
,pos
)),_
)::rest
->
1093 { Ast0.line_start
= line
; Ast0.line_end
= line
;
1094 Ast0.logical_start
= logical_line
; Ast0.logical_end
= logical_line
;
1095 Ast0.column
= col
; Ast0.offset
= offset
; } in
1096 collect_all_pragmas ((s
,i)::collected
) rest
1097 | l
-> (List.rev collected
,l
)
1099 let rec collect_pass = function
1102 match plus_attachable false x
with
1104 let (pass
,rest
) = collect_pass xs
in
1108 let plus_attach strict
= function
1110 | Some x
-> plus_attachable strict x
1112 let add_bef = function Some x
-> [x
] | None
-> []
1114 (*skips should be things like line end
1115 skips is things before pragmas that can't be attached to, pass is things
1116 after. pass is used immediately. skips accumulates. *)
1117 let rec process_pragmas bef skips
= function
1118 [] -> add_bef bef
@ List.rev skips
1119 | ((PC.TPragma
(s
,i),_
)::_
) as l
->
1120 let (pragmas
,rest
) = collect_all_pragmas [] l
in
1121 let (pass
,rest0
) = collect_pass rest
in
1123 match rest0
with [] -> (None
,[]) | next
::rest
-> (Some next
,rest
) in
1124 (match (bef
,plus_attach true bef
,next
,plus_attach true next
) with
1125 (Some bef
,PLUS
,_
,_
) ->
1126 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt bef
in
1127 (update_clt bef
(a
,b
,c
,d
,e
,strbef
,pragmas
,pos
))::List.rev skips
@
1128 pass
@process_pragmas None
[] rest0
1129 | (_
,_
,Some next
,PLUS
) ->
1130 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt next
in
1131 (add_bef bef
) @ List.rev skips
@ pass
@
1133 (Some
(update_clt next
(a
,b
,c
,d
,e
,pragmas
,straft
,pos
)))
1136 (match (bef
,plus_attach false bef
,next
,plus_attach false next
) with
1137 (Some bef
,PLUS
,_
,_
) ->
1138 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt bef
in
1139 (update_clt bef
(a
,b
,c
,d
,e
,strbef
,pragmas
,pos
))::List.rev skips
@
1140 pass
@process_pragmas None
[] rest0
1141 | (_
,_
,Some next
,PLUS
) ->
1142 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt next
in
1143 (add_bef bef
) @ List.rev skips
@ pass
@
1145 (Some
(update_clt next
(a
,b
,c
,d
,e
,pragmas
,straft
,pos
)))
1147 | _
-> failwith
"nothing to attach pragma to"))
1149 (match plus_attachable false x
with
1150 SKIP
-> process_pragmas bef
(x
::skips
) xs
1151 | _
-> (add_bef bef
) @ List.rev skips
@ (process_pragmas (Some x
) [] xs
))
1153 (* ----------------------------------------------------------------------- *)
1154 (* Drop ... ... . This is only allowed in + code, and arises when there is
1155 some - code between the ... *)
1156 (* drop whens as well - they serve no purpose in + code and they cause
1157 problems for drop_double_dots *)
1159 let rec drop_when = function
1161 | (PC.TWhen
(clt),info)::xs
->
1162 let rec loop = function
1164 | (PC.TLineEnd
(_
),info)::xs
-> drop_when xs
1165 | x
::xs
-> loop xs
in
1167 | x
::xs
-> x
::drop_when xs
1169 (* instead of dropping the double dots, we put TNothing in between them.
1170 these vanish after the parser, but keeping all the ...s in the + code makes
1171 it easier to align the + and - code in context_neg and in preparation for the
1172 isomorphisms. This shouldn't matter because the context code of the +
1173 slice is mostly ignored anyway *)
1174 let minus_to_nothing l
=
1175 (* for cases like | <..., which may or may not arise from removing minus
1176 code, depending on whether <... is a statement or expression *)
1179 let (d
,_
,_
,_
,_
,_
,_
,_
) = get_clt tok
in
1181 D.MINUS
| D.OPTMINUS
| D.UNIQUEMINUS
-> true
1182 | D.PLUS
| D.PLUSPLUS
-> false
1183 | D.CONTEXT
| D.UNIQUE
| D.OPT
-> false)
1185 let rec minus_loop = function
1187 | (d
::ds
) as l
-> if is_minus d
then minus_loop ds
else l
in
1188 let rec loop = function
1190 | ((PC.TMid0
(clt),i) as x
)::t1
::ts
when is_minus t1
->
1191 (match minus_loop ts
with
1192 ((PC.TOEllipsis
(_
),_
)::_
) | ((PC.TPOEllipsis
(_
),_
)::_
)
1193 | ((PC.TEllipsis
(_
),_
)::_
) as l
-> x
::(PC.TNothing
,i)::(loop l
)
1195 | t
::ts
-> t
::(loop ts
) in
1198 let rec drop_double_dots l
=
1199 let start = function
1200 (PC.TOEllipsis
(_
),_
) | (PC.TPOEllipsis
(_
),_
)
1201 (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *) ->
1204 let middle = function
1205 (PC.TEllipsis
(_
),_
) (* | (PC.TCircles(_),_) | (PC.TStars(_),_) *) -> true
1207 let whenline = function
1208 (PC.TLineEnd
(_
),_
) -> true
1209 (*| (PC.TMid0(_),_) -> true*)
1211 let final = function
1212 (PC.TCEllipsis
(_
),_
) | (PC.TPCEllipsis
(_
),_
)
1213 (* | (PC.TCCircles(_),_) | (PC.TCStars(_),_) *) ->
1216 let any_before x
= start x
or middle x
or final x
or whenline x
in
1217 let any_after x
= start x
or middle x
or final x
in
1218 let rec loop ((_
,i) as prev
) = function
1220 | x
::rest
when any_before prev
&& any_after x
->
1221 (PC.TNothing
,i)::x
::(loop x rest
)
1222 | ((PC.TComma
(_
),_
) as c
)::x
::rest
when any_before prev
&& any_after x
->
1223 c
::(PC.TNothing
,i)::x
::(loop x rest
)
1224 | x
::rest
-> x
:: (loop x rest
) in
1227 | (x
::xs
) -> x
:: loop x xs
1231 if l
= cur then l
else fix f
cur
1233 (* ( | ... | ) also causes parsing problems *)
1237 let rec drop_empty_thing starter
middle ender
= function
1239 | hd
::rest
when starter hd
->
1240 let rec loop = function
1241 x
::rest
when middle x
-> loop rest
1242 | x
::rest
when ender x
-> rest
1243 | _
-> raise Not_empty
in
1244 (match try Some
(loop rest
) with Not_empty
-> None
with
1245 Some x
-> drop_empty_thing starter
middle ender x
1246 | None
-> hd
:: drop_empty_thing starter
middle ender rest
)
1247 | x
::rest
-> x
:: drop_empty_thing starter
middle ender rest
1251 (function (PC.TOPar0
(_
),_
) -> true | _
-> false)
1252 (function (PC.TMid0
(_
),_
) -> true | _
-> false)
1253 (function (PC.TCPar0
(_
),_
) -> true | _
-> false)
1255 let drop_empty_nest = drop_empty_thing
1257 (* ----------------------------------------------------------------------- *)
1260 let get_s_starts (_
, (s
,_
,(starts
, ends
))) =
1261 Printf.printf
"%d %d\n" starts ends
; (s
, starts
)
1264 let v = List.hd
!l
in
1269 PC.reinit (function _
-> PC.TArobArob
(* a handy token *))
1270 (Lexing.from_function
1271 (function buf
-> function n
-> raise
Common.Impossible
))
1273 let parse_one str parsefn file toks
=
1274 let all_tokens = ref toks
in
1275 let cur_tok = ref (List.hd
!all_tokens) in
1277 let lexer_function _
=
1278 let (v, info) = pop2 all_tokens in
1279 cur_tok := (v, info);
1283 Lexing.from_function
1284 (function buf
-> function n
-> raise
Common.Impossible
)
1289 try parsefn
lexer_function lexbuf_fake
1291 Lexer_cocci.Lexical s
->
1293 (Printf.sprintf
"%s: lexical error: %s\n =%s\n" str s
1294 (Common.error_message file
(get_s_starts !cur_tok) ))
1295 | Parser_cocci_menhir.Error
->
1297 (Printf.sprintf
"%s: parse error: \n = %s\n" str
1298 (Common.error_message file
(get_s_starts !cur_tok) ))
1299 | Semantic_cocci.Semantic s
->
1301 (Printf.sprintf
"%s: semantic error: %s\n =%s\n" str s
1302 (Common.error_message file
(get_s_starts !cur_tok) ))
1306 let prepare_tokens tokens
=
1308 (translate_when_true_false (* after insert_line_end *)
1311 (find_function_names
1314 (check_parentheses tokens
)))))))
1316 let prepare_mv_tokens tokens
=
1317 detect_types false (detect_attr tokens
)
1319 let rec consume_minus_positions = function
1321 | ((PC.TOPar0
(_
),_
) as x
)::xs
| ((PC.TCPar0
(_
),_
) as x
)::xs
1322 | ((PC.TMid0
(_
),_
) as x
)::xs
-> x
::consume_minus_positions xs
1323 | x
::(PC.TPArob
,_
)::(PC.TMetaPos
(name
,constraints
,per
,clt),_
)::xs
->
1324 let (arity
,ln
,lln
,offset
,col
,strbef
,straft
,_
) = get_clt x
in
1325 let name = Parse_aux.clt2mcode
name clt in
1328 (arity
,ln
,lln
,offset
,col
,strbef
,straft
,
1329 Ast0.MetaPos
(name,constraints
,per
)) in
1330 x::(consume_minus_positions xs
)
1331 | x::xs
-> x::consume_minus_positions xs
1333 let any_modif rule
=
1335 match Ast0.get_mcode_mcodekind
x with
1336 Ast0.MINUS _
| Ast0.PLUS _
-> true
1338 let donothing r k e
= k e
in
1339 let bind x y
= x or y
in
1340 let option_default = false in
1342 V0.flat_combiner
bind option_default
1343 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1344 donothing donothing donothing donothing donothing donothing
1345 donothing donothing donothing donothing donothing donothing donothing
1346 donothing donothing in
1347 List.exists
fn.VT0.combiner_rec_top_level rule
1349 let eval_virt virt
=
1352 if not
(List.mem
x virt
)
1353 then raise
(Bad_virt
x))
1354 !Flag.defined_virtual_rules
1356 let drop_last extra l
= List.rev
(extra
@(List.tl
(List.rev l
)))
1358 let partition_either l
=
1359 let rec part_either left right
= function
1360 | [] -> (List.rev left
, List.rev right
)
1363 | Common.Left e
-> part_either (e
:: left
) right l
1364 | Common.Right e
-> part_either left
(e
:: right
) l
) in
1367 let get_metavars parse_fn table file lexbuf
=
1368 let rec meta_loop acc
(* read one decl at a time *) =
1372 tokens_all table file
true lexbuf
[PC.TArobArob
;PC.TMPtVirg
]) in
1373 let tokens = prepare_mv_tokens tokens in
1375 [(PC.TArobArob
,_
)] -> List.rev acc
1377 let metavars = parse_one "meta" parse_fn file
tokens in
1378 meta_loop (metavars@acc
) in
1379 partition_either (meta_loop [])
1381 let get_script_metavars parse_fn table file lexbuf
=
1382 let rec meta_loop acc
=
1384 tokens_all table file
true lexbuf
[PC.TArobArob
; PC.TMPtVirg
] in
1385 let tokens = prepare_tokens tokens in
1387 [(PC.TArobArob
, _
)] -> List.rev acc
1389 let metavar = parse_one "scriptmeta" parse_fn file
tokens in
1390 meta_loop (metavar :: acc
)
1394 let get_rule_name parse_fn starts_with_name get_tokens file prefix
=
1395 Data.in_rule_name
:= true;
1396 let mknm _
= make_name prefix
(!Lexer_cocci.line
) in
1400 let (_
,tokens) = get_tokens
[PC.TArob
] in
1401 let check_name = function
1402 None
-> Some
(mknm())
1404 (if List.mem nm
reserved_names
1405 then failwith
(Printf.sprintf
"invalid name %s\n" nm
));
1407 match parse_one "rule name" parse_fn file
tokens with
1408 Ast.CocciRulename
(nm
,a
,b
,c
,d
,e
) ->
1409 Ast.CocciRulename
(check_name nm
,a
,b
,c
,d
,e
)
1410 | Ast.GeneratedRulename
(nm
,a
,b
,c
,d
,e
) ->
1411 Ast.GeneratedRulename
(check_name nm
,a
,b
,c
,d
,e
)
1412 | Ast.ScriptRulename
(nm
,s
,deps
) ->
1413 Ast.ScriptRulename
(check_name nm
,s
,deps
)
1414 | Ast.InitialScriptRulename
(_
,s
,deps
) ->
1415 Ast.InitialScriptRulename
(check_name None
,s
,deps
)
1416 | Ast.FinalScriptRulename
(_
,s
,deps
) ->
1417 Ast.FinalScriptRulename
(check_name None
,s
,deps
)
1419 Ast.CocciRulename
(Some
(mknm()),Ast.NoDep
,[],[],Ast.Undetermined
,false) in
1420 Data.in_rule_name
:= false;
1423 let parse_iso file
=
1424 let table = Common.full_charpos_to_pos file
in
1425 Common.with_open_infile file
(fun channel
->
1426 let lexbuf = Lexing.from_channel channel
in
1427 let get_tokens = tokens_all table file
false lexbuf in
1429 match get_tokens [PC.TArobArob
;PC.TArob
] with
1431 let parse_start start =
1432 let rev = List.rev start in
1433 let (arob
,_
) = List.hd
rev in
1434 (arob
= PC.TArob
,List.rev(List.tl
rev)) in
1435 let (starts_with_name
,start) = parse_start start in
1436 let rec loop starts_with_name
start =
1437 (!Data.init_rule
)();
1438 (* get metavariable declarations - have to be read before the
1440 let (rule_name
,_
,_
,_
,_
,_
) =
1441 match get_rule_name PC.iso_rule_name starts_with_name
get_tokens
1442 file
("iso file "^file
) with
1443 Ast.CocciRulename
(Some n
,a
,b
,c
,d
,e
) -> (n
,a
,b
,c
,d
,e
)
1444 | _
-> failwith
"Script rules cannot appear in isomorphism rules"
1446 Ast0.rule_name
:= rule_name
;
1448 match get_metavars PC.iso_meta_main
table file
lexbuf with
1449 (iso_metavars,[]) -> iso_metavars
1450 | _
-> failwith
"unexpected inheritance in iso" in
1454 [PC.TIsoStatement
;PC.TIsoExpression
;PC.TIsoArgExpression
;
1455 PC.TIsoTestExpression
; PC.TIsoToTestExpression
;
1456 PC.TIsoDeclaration
;PC.TIsoType
;PC.TIsoTopLevel
] in
1457 let next_start = List.hd
(List.rev tokens) in
1458 let dummy_info = ("",(-1,-1),(-1,-1)) in
1459 let tokens = drop_last [(PC.EOF
,dummy_info)] tokens in
1460 let tokens = prepare_tokens (start@tokens) in
1462 print_tokens "iso tokens" tokens;
1464 let entry = parse_one "iso main" PC.iso_main file
tokens in
1465 let entry = List.map
(List.map
Test_exps.process_anything
) entry in
1467 then (* The code below allows a header like Statement list,
1468 which is more than one word. We don't have that any more,
1469 but the code is left here in case it is put back. *)
1470 match get_tokens [PC.TArobArob
;PC.TArob
] with
1472 let (starts_with_name
,start) = parse_start start in
1473 (iso_metavars,entry,rule_name
) ::
1474 (loop starts_with_name
(next_start::start))
1475 | _
-> failwith
"isomorphism ends early"
1476 else [(iso_metavars,entry,rule_name
)] in
1477 loop starts_with_name
start
1478 | (false,_
) -> [] in
1481 let parse_iso_files existing_isos iso_files extra_path
=
1482 let get_names = List.map
(function (_
,_
,nm
) -> nm
) in
1483 let old_names = get_names existing_isos
in
1484 Data.in_iso
:= true;
1487 (function (prev
,names
) ->
1489 Lexer_cocci.init
();
1492 Common.Left
(fl
) -> Filename.concat extra_path fl
1493 | Common.Right
(fl
) -> Filename.concat
Config.path fl
in
1494 let current = parse_iso file in
1495 let new_names = get_names current in
1496 if List.exists
(function x -> List.mem
x names
) new_names
1497 then failwith
(Printf.sprintf
"repeated iso name found in %s" file);
1498 (current::prev
,new_names @ names
))
1499 ([],old_names) iso_files
in
1500 Data.in_iso
:= false;
1501 existing_isos
@(List.concat
(List.rev res))
1503 (* None = dependency not satisfied
1504 Some dep = dependency satisfied or unknown and dep has virts optimized
1506 let eval_depend dep virt
=
1509 Ast.Dep req
| Ast.EverDep req
->
1510 if List.mem req virt
1512 if List.mem req
!Flag.defined_virtual_rules
1516 | Ast.AntiDep antireq
| Ast.NeverDep antireq
->
1517 if List.mem antireq virt
1519 if not
(List.mem antireq
!Flag.defined_virtual_rules
)
1523 | Ast.AndDep
(d1
,d2
) ->
1524 (match (loop d1
, loop d2
) with
1525 (None
,_
) | (_
,None
) -> None
1526 | (Some
Ast.NoDep
,x) | (x,Some
Ast.NoDep
) -> x
1527 | (Some
x,Some y
) -> Some
(Ast.AndDep
(x,y
)))
1528 | Ast.OrDep
(d1
,d2
) ->
1529 (match (loop d1
, loop d2
) with
1531 | (Some
Ast.NoDep
,x) | (x,Some
Ast.NoDep
) -> Some
Ast.NoDep
1532 | (None
,x) | (x,None
) -> x
1533 | (Some
x,Some y
) -> Some
(Ast.OrDep
(x,y
)))
1534 | Ast.NoDep
| Ast.FailDep
-> Some dep
1540 let rec parse_loop file =
1541 Lexer_cocci.include_init
();
1542 let table = Common.full_charpos_to_pos
file in
1543 Common.with_open_infile
file (fun channel
->
1544 let lexbuf = Lexing.from_channel channel
in
1545 let get_tokens = tokens_all table file false lexbuf in
1546 Data.in_prolog
:= true;
1547 let initial_tokens = get_tokens [PC.TArobArob
;PC.TArob
] in
1548 Data.in_prolog
:= false;
1550 match initial_tokens with
1552 (match List.rev data
with
1553 ((PC.TArobArob
as x),_
)::_
| ((PC.TArob
as x),_
)::_
->
1554 let include_and_iso_files =
1555 parse_one "include and iso file names" PC.include_main
file data
in
1557 let (include_files
,iso_files
,virt
) =
1559 (function (include_files
,iso_files
,virt
) ->
1561 Data.Include s
-> (s
::include_files
,iso_files
,virt
)
1562 | Data.Iso s
-> (include_files
,s
::iso_files
,virt
)
1563 | Data.Virt l
-> (include_files
,iso_files
,l
@virt
))
1564 ([],[],[]) include_and_iso_files in
1566 List.iter
(function x -> Hashtbl.add
Lexer_cocci.rule_names
x ())
1569 let (extra_iso_files
, extra_rules
, extra_virt
, extra_metas
) =
1570 let rec loop = function
1572 | (a
,b
,c
,d
)::rest
->
1573 let (x,y
,z
,zz
) = loop rest
in
1574 (a
::x,b
::y
,c
::z
,d
@zz
) in
1575 loop (List.map
parse_loop include_files
) in
1577 let parse_cocci_rule ruletype old_metas
1578 (rule_name
, dependencies
, iso
, dropiso
, exists
, is_expression
) =
1579 let dropiso = !Flag_parsing_cocci.disabled_isos
@ dropiso in
1580 Ast0.rule_name
:= rule_name
;
1581 Data.inheritable_positions
:=
1582 rule_name
:: !Data.inheritable_positions
;
1584 (* get metavariable declarations *)
1585 let (metavars, inherited_metavars
) =
1586 get_metavars PC.meta_main
table file lexbuf in
1587 Hashtbl.add
Data.all_metadecls rule_name
metavars;
1588 Hashtbl.add
Lexer_cocci.rule_names rule_name
();
1589 Hashtbl.add
Lexer_cocci.all_metavariables rule_name
1591 (fun key
v rest
-> (key
,v)::rest
)
1592 Lexer_cocci.metavariables
[]);
1594 (* get transformation rules *)
1595 let (more
, tokens) = get_tokens [PC.TArobArob
; PC.TArob
] in
1596 let (minus_tokens
, _
) = split_token_stream tokens in
1597 let (_
, plus_tokens
) =
1598 split_token_stream (minus_to_nothing tokens) in
1601 print_tokens "minus tokens" minus_tokens;
1602 print_tokens "plus tokens" plus_tokens;
1605 let minus_tokens = consume_minus_positions minus_tokens in
1606 let minus_tokens = prepare_tokens minus_tokens in
1607 let plus_tokens = prepare_tokens plus_tokens in
1610 print_tokens "minus tokens" minus_tokens;
1611 print_tokens "plus tokens" plus_tokens;
1615 process_pragmas None
[]
1616 (fix (function x -> drop_double_dots (drop_empty_or x))
1617 (drop_when plus_tokens)) in
1619 print_tokens "plus tokens" plus_tokens;
1620 Printf.printf "before minus parse\n";
1624 then parse_one "minus" PC.minus_exp_main
file minus_tokens
1625 else parse_one "minus" PC.minus_main
file minus_tokens in
1627 Unparse_ast0.unparse minus_res;
1628 Printf.printf "before plus parse\n";
1631 (* put ignore_patch_or_match with * case, which is less
1633 if !Flag.sgrep_mode2
or !D.ignore_patch_or_match
1634 then (* not actually used for anything, except context_neg *)
1636 (Iso_pattern.rebuild_mcode None
).VT0.rebuilder_rec_top_level
1640 then parse_one "plus" PC.plus_exp_main
file plus_tokens
1641 else parse_one "plus" PC.plus_main
file plus_tokens in
1643 Printf.printf "after plus parse\n";
1646 (if not
!Flag.sgrep_mode2
&&
1647 (any_modif minus_res or any_modif plus_res) &&
1648 not
(dependencies
= Ast.FailDep
)
1649 then Data.inheritable_positions
:= []);
1651 Check_meta.check_meta rule_name old_metas inherited_metavars
1652 metavars minus_res plus_res;
1654 (more
, Ast0.CocciRule
((minus_res, metavars,
1655 (iso
, dropiso, dependencies
, rule_name
, exists
)),
1656 (plus_res, metavars), ruletype
), metavars, tokens) in
1658 let rec collect_script_tokens = function
1659 [(PC.EOF
,_
)] | [(PC.TArobArob
,_
)] | [(PC.TArob
,_
)] -> ""
1660 | (PC.TScriptData
(s
),_
)::xs
-> s^
(collect_script_tokens xs
)
1664 Printf.printf
"%s\n" (token2c x))
1666 failwith
"Malformed script rule" in
1668 let parse_script_rule name language old_metas deps
=
1669 let get_tokens = tokens_script_all table file false lexbuf in
1671 (* meta-variables *)
1675 get_script_metavars PC.script_meta_main
table file lexbuf) in
1676 let (metavars,script_metavars
) =
1678 (function (metavars,script_metavars
) ->
1680 (script_var
,Some
(parent
,var
)) ->
1681 ((script_var
,parent
,var
) :: metavars, script_metavars
)
1682 | ((Some script_var
,None
),None
) ->
1683 (metavars, (name,script_var
) :: script_metavars
)
1684 | _
-> failwith
"not possible")
1686 let metavars = List.rev metavars in
1687 let script_metavars = List.rev script_metavars in
1689 Hashtbl.add
Data.all_metadecls
name
1690 (List.map
(function x -> Ast.MetaIdDecl
(Ast.NONE
,x))
1692 Hashtbl.add
Lexer_cocci.rule_names
name ();
1693 (*TODOHashtbl.add Lexer_cocci.all_metavariables name script_metavars;*)
1696 let exists_in old_metas (py,(r,m)) =
1698 let test (rr,mr) x =
1699 let (ro,vo) = Ast.get_meta_name x in
1700 ro = rr && vo = mr in
1701 List.exists (test (r,m)) old_metas in
1705 let meta2c (r,n) = Printf.sprintf "%s.%s" r n in
1706 if not (exists_in old_metas x) then
1709 "Script references unknown meta-variable: %s"
1714 let (more
, tokens) = get_tokens [PC.TArobArob
; PC.TArob
] in
1715 let data = collect_script_tokens tokens in
1717 Ast0.ScriptRule
(name, language
, deps
, metavars,
1718 script_metavars, data),
1721 let parse_if_script_rule k
name language _ deps
=
1722 let get_tokens = tokens_script_all table file false lexbuf in
1725 let (more
, tokens) = get_tokens [PC.TArobArob
; PC.TArob
] in
1726 let data = collect_script_tokens tokens in
1727 (more
,k
(name, language
, deps
, data),[],tokens) in
1729 let parse_iscript_rule =
1730 parse_if_script_rule
1731 (function (name,language
,deps
,data) ->
1732 Ast0.InitialScriptRule
(name,language
,deps
,data)) in
1734 let parse_fscript_rule =
1735 parse_if_script_rule
1736 (function (name,language
,deps
,data) ->
1737 Ast0.FinalScriptRule
(name,language
,deps
,data)) in
1739 let do_parse_script_rule fn name l old_metas deps
=
1740 match eval_depend deps virt
with
1741 Some deps
-> fn name l old_metas deps
1742 | None
-> fn name l old_metas
Ast.FailDep
in
1744 let parse_rule old_metas starts_with_name
=
1746 get_rule_name PC.rule_name starts_with_name
get_tokens file
1749 Ast.CocciRulename
(Some s
, dep
, b
, c
, d
, e
) ->
1750 (match eval_depend dep virt
with
1752 parse_cocci_rule Ast.Normal old_metas
(s
,dep
,b
,c
,d
,e
)
1754 D.ignore_patch_or_match
:= true;
1756 parse_cocci_rule Ast.Normal old_metas
1757 (s
, Ast.FailDep
, b
, c
, d
, e
) in
1758 D.ignore_patch_or_match
:= false;
1760 | Ast.GeneratedRulename
(Some s
, dep
, b
, c
, d
, e
) ->
1761 (match eval_depend dep virt
with
1763 Data.in_generating
:= true;
1765 parse_cocci_rule Ast.Generated old_metas
1767 Data.in_generating
:= false;
1770 D.ignore_patch_or_match
:= true;
1771 Data.in_generating
:= true;
1773 parse_cocci_rule Ast.Generated old_metas
1774 (s
, Ast.FailDep
, b
, c
, d
, e
) in
1775 D.ignore_patch_or_match
:= false;
1776 Data.in_generating
:= false;
1778 | Ast.ScriptRulename
(Some s
,l
,deps
) ->
1779 do_parse_script_rule parse_script_rule s l old_metas deps
1780 | Ast.InitialScriptRulename
(Some s
,l
,deps
) ->
1781 do_parse_script_rule parse_iscript_rule s l old_metas deps
1782 | Ast.FinalScriptRulename
(Some s
,l
,deps
) ->
1783 do_parse_script_rule parse_fscript_rule s l old_metas deps
1784 | _
-> failwith
"Malformed rule name" in
1786 let rec loop old_metas starts_with_name
=
1787 (!Data.init_rule
)();
1789 let gen_starts_with_name more
tokens =
1791 (match List.hd
(List.rev tokens) with
1792 (PC.TArobArob
,_
) -> false
1793 | (PC.TArob
,_
) -> true
1794 | _
-> failwith
"unexpected token")
1797 let (more
, rule
, metavars, tokens) =
1798 parse_rule old_metas starts_with_name
in
1799 let all_metas = metavars @ old_metas
in
1802 let (all_rules
,all_metas) =
1803 loop all_metas (gen_starts_with_name more
tokens) in
1804 (rule
::all_rules
,all_metas)
1805 else ([rule
],all_metas) in
1807 let (all_rules
,all_metas) =
1808 loop extra_metas
(x = PC.TArob
) in
1811 (function prev
-> function cur -> Common.union_set
cur prev
)
1812 iso_files extra_iso_files
,
1813 (* included rules first *)
1814 List.fold_left
(function prev
-> function cur -> cur@prev
)
1815 all_rules
(List.rev extra_rules
),
1816 List.fold_left
(@) virt extra_virt
(*no dups allowed*),
1817 (all_metas : 'a list
))
1818 | _
-> failwith
"unexpected code before the first rule\n")
1819 | (false,[(PC.TArobArob
,_
)]) | (false,[(PC.TArob
,_
)]) ->
1820 ([],([] : Ast0.parsed_rule list
),[] (*virtual rules*), [] (*all metas*))
1821 | _
-> failwith
"unexpected code before the first rule\n" in
1825 (* parse to ast0 and then convert to ast *)
1826 let process file isofile verbose
=
1827 let extra_path = Filename.dirname
file in
1828 let (iso_files
, rules
, virt
, _metas
) = parse file in
1833 | Some iso_file
-> parse_iso_files [] [Common.Left iso_file
] "" in
1834 let global_isos = parse_iso_files std_isos iso_files
extra_path in
1835 let rules = Unitary_ast0.do_unitary
rules in
1839 Ast0.ScriptRule
(a
,b
,c
,d
,fv
,e
) ->
1840 [([],Ast.ScriptRule
(a
,b
,c
,d
,fv
,e
))]
1841 | Ast0.InitialScriptRule
(a
,b
,c
,d
) ->
1842 [([],Ast.InitialScriptRule
(a
,b
,c
,d
))]
1843 | Ast0.FinalScriptRule
(a
,b
,c
,d
) ->
1844 [([],Ast.FinalScriptRule
(a
,b
,c
,d
))]
1847 (iso
, dropiso, dependencies
, rule_name
, exists
)),
1848 (plus
, metavars),ruletype
) ->
1850 parse_iso_files global_isos
1851 (List.map
(function x -> Common.Left
x) iso
)
1854 (* check that dropped isos are actually available *)
1857 List.map
(function (_
,_
,nm
) -> nm
) chosen_isos in
1858 let local_iso_names = reserved_names @ iso_names in
1861 (function dropped
->
1862 not
(List.mem dropped
local_iso_names))
1865 ("invalid iso name " ^
bad_dropped ^
" in " ^ rule_name
)
1866 with Not_found
-> ());
1867 if List.mem
"all" dropiso
1869 if List.length
dropiso = 1
1871 else failwith
"disable all should only be by itself"
1872 else (* drop those isos *)
1874 (function (_
,_
,nm
) -> not
(List.mem nm
dropiso))
1876 List.iter
Iso_compile.process chosen_isos;
1878 match reserved_names with
1883 List.filter
(function x -> List.mem
x dropiso) others
)
1886 "bad list of reserved names - all must be at start" in
1887 let minus = Test_exps.process minus in
1888 let minus = Compute_lines.compute_lines
false minus in
1889 let plus = Compute_lines.compute_lines
false plus in
1891 (* only relevant to Flag.make_hrule *)
1892 (* doesn't handle multiple minirules properly, but since
1893 we don't really handle them in lots of other ways, it
1894 doesn't seem very important *)
1898 [match Ast0.unwrap p
with
1900 (match List.map
Ast0.unwrap
(Ast0.undots c
) with
1901 [Ast0.Exp e
] -> true | _
-> false)
1903 let minus = Arity.minus_arity
minus in
1904 let ((metavars,minus),function_prototypes
) =
1905 Function_prototypes.process
1906 rule_name
metavars dropped_isos minus plus ruletype
in
1907 let plus = Adjust_pragmas.process plus in
1908 (* warning! context_neg side-effects its arguments *)
1909 let (m
,p
) = List.split (Context_neg.context_neg
minus plus) in
1910 Type_infer.type_infer p
;
1911 (if not
!Flag.sgrep_mode2
1912 then Insert_plus.insert_plus m p
(chosen_isos = []));
1913 Type_infer.type_infer
minus;
1914 let (extra_meta
, minus) =
1915 match (chosen_isos,ruletype
) with
1916 (* separate case for [] because applying isos puts
1917 some restrictions on the -+ code *)
1918 ([],_
) | (_
,Ast.Generated
) -> ([],minus)
1919 | _
-> Iso_pattern.apply_isos
chosen_isos minus rule_name
in
1920 (* after iso, because iso can intro ... *)
1921 let minus = Adjacency.compute_adjacency
minus in
1922 let minus = Comm_assoc.comm_assoc
minus rule_name
dropiso in
1924 if !Flag.sgrep_mode2
then minus
1925 else Single_statement.single_statement
minus in
1926 let minus = Simple_assignments.simple_assignments
minus in
1928 Ast0toast.ast0toast rule_name dependencies
dropped_isos
1929 exists
minus is_exp ruletype
in
1931 match function_prototypes
with
1932 None
-> [(extra_meta
@ metavars, minus_ast)]
1933 | Some mv_fp
-> [(extra_meta
@ metavars, minus_ast); mv_fp
])
1934 (* Ast0.CocciRule ((minus, metavarsm, (iso, dropiso, dependencies, rule_name, exists)), (plus, metavars))*)
1936 let parsed = List.concat
parsed in
1937 let disjd = Disjdistr.disj
parsed in
1939 let (metavars,code
,fvs
,neg_pos
,ua
,pos
) = Free_vars.free_vars
disjd in
1940 if !Flag_parsing_cocci.show_SP
1941 then List.iter
Pretty_print_cocci.unparse code
;
1944 Common.profile_code
"get_glimpse_constants" (* for glimpse *)
1945 (fun () -> Get_constants2.get_constants code neg_pos
) in
1947 (metavars,code
,fvs
,neg_pos
,ua
,pos
,search_tokens)