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.
26 * Copyright 2010, INRIA, University of Copenhagen
27 * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
28 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
29 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
30 * This file is part of Coccinelle.
32 * Coccinelle is free software: you can redistribute it and/or modify
33 * it under the terms of the GNU General Public License as published by
34 * the Free Software Foundation, according to version 2 of the License.
36 * Coccinelle is distributed in the hope that it will be useful,
37 * but WITHOUT ANY WARRANTY; without even the implied warranty of
38 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
39 * GNU General Public License for more details.
41 * You should have received a copy of the GNU General Public License
42 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
44 * The authors reserve the right to distribute this or future versions of
45 * Coccinelle under other licenses.
49 (* splits the entire file into minus and plus fragments, and parses each
50 separately (thus duplicating work for the parsing of the context elements) *)
53 module PC
= Parser_cocci_menhir
54 module V0
= Visitor_ast0
55 module VT0
= Visitor_ast0_types
56 module Ast
= Ast_cocci
57 module Ast0
= Ast0_cocci
59 exception Bad_virt
of string
61 let pr = Printf.sprintf
62 (*let pr2 s = prerr_string s; prerr_string "\n"; flush stderr*)
63 let pr2 s
= Printf.printf
"%s\n" s
65 (* for isomorphisms. all should be at the front!!! *)
67 ["all";"optional_storage";"optional_qualifier";"value_format";"comm_assoc"]
69 (* ----------------------------------------------------------------------- *)
72 let line_type (d
,_
,_
,_
,_
,_
,_
,_
) = d
75 match line_type tok
with
76 D.MINUS
| D.OPTMINUS
| D.UNIQUEMINUS
-> ":-"
79 | D.CONTEXT
| D.UNIQUE
| D.OPT
-> ""
83 PC.TIdentifier
-> "identifier"
85 | PC.TParameter
-> "parameter"
86 | PC.TConstant
-> "constant"
87 | PC.TExpression
-> "expression"
88 | PC.TIdExpression
-> "idexpression"
89 | PC.TInitialiser
-> "initialiser"
90 | PC.TDeclaration
-> "declaration"
91 | PC.TField
-> "field"
92 | PC.TStatement
-> "statement"
93 | PC.TPosition
-> "position"
95 | PC.TFunction
-> "function"
96 | PC.TLocal
-> "local"
98 | PC.TFresh
-> "fresh"
99 | PC.TCppConcatOp
-> "##"
101 | PC.TContext
-> "context"
102 | PC.TTypedef
-> "typedef"
103 | PC.TDeclarer
-> "declarer"
104 | PC.TIterator
-> "iterator"
106 | PC.TRuleName str
-> "rule_name-"^str
107 | PC.TUsing
-> "using"
108 | PC.TVirtual
-> "virtual"
109 | PC.TPathIsoFile str
-> "path_iso_file-"^str
110 | PC.TDisable
-> "disable"
111 | PC.TExtends
-> "extends"
112 | PC.TDepends
-> "depends"
115 | PC.TNever
-> "never"
116 | PC.TExists
-> "exists"
117 | PC.TForall
-> "forall"
118 | PC.TError
-> "error"
119 | PC.TWords
-> "words"
120 | PC.TGenerated
-> "generated"
122 | PC.TNothing
-> "nothing"
124 | PC.Tchar
(clt
) -> "char"^
(line_type2c clt
)
125 | PC.Tshort
(clt
) -> "short"^
(line_type2c clt
)
126 | PC.Tint
(clt
) -> "int"^
(line_type2c clt
)
127 | PC.Tdouble
(clt
) -> "double"^
(line_type2c clt
)
128 | PC.Tfloat
(clt
) -> "float"^
(line_type2c clt
)
129 | PC.Tlong
(clt
) -> "long"^
(line_type2c clt
)
130 | PC.Tvoid
(clt
) -> "void"^
(line_type2c clt
)
131 | PC.Tsize_t
(clt
) -> "size_t"^
(line_type2c clt
)
132 | PC.Tssize_t
(clt
) -> "ssize_t"^
(line_type2c clt
)
133 | PC.Tptrdiff_t
(clt
) -> "ptrdiff_t"^
(line_type2c clt
)
134 | PC.Tstruct
(clt
) -> "struct"^
(line_type2c clt
)
135 | PC.Tunion
(clt
) -> "union"^
(line_type2c clt
)
136 | PC.Tenum
(clt
) -> "enum"^
(line_type2c clt
)
137 | PC.Tunsigned
(clt
) -> "unsigned"^
(line_type2c clt
)
138 | PC.Tsigned
(clt
) -> "signed"^
(line_type2c clt
)
139 | PC.Tstatic
(clt
) -> "static"^
(line_type2c clt
)
140 | PC.Tinline
(clt
) -> "inline"^
(line_type2c clt
)
141 | PC.Ttypedef
(clt
) -> "typedef"^
(line_type2c clt
)
142 | PC.Tattr
(s
,clt
) -> s^
(line_type2c clt
)
143 | PC.Tauto
(clt
) -> "auto"^
(line_type2c clt
)
144 | PC.Tregister
(clt
) -> "register"^
(line_type2c clt
)
145 | PC.Textern
(clt
) -> "extern"^
(line_type2c clt
)
146 | PC.Tconst
(clt
) -> "const"^
(line_type2c clt
)
147 | PC.Tvolatile
(clt
) -> "volatile"^
(line_type2c clt
)
149 | PC.TPragma
(Ast.Noindent s
,_
) -> s
150 | PC.TPragma
(Ast.Indent s
,_
) -> s
151 | PC.TIncludeL
(s
,clt
) -> (pr "#include \"%s\"" s
)^
(line_type2c clt
)
152 | PC.TIncludeNL
(s
,clt
) -> (pr "#include <%s>" s
)^
(line_type2c clt
)
153 | PC.TDefine
(clt
,_
) -> "#define"^
(line_type2c clt
)
154 | PC.TDefineParam
(clt
,_
,_
,_
) -> "#define_param"^
(line_type2c clt
)
155 | PC.TMinusFile
(s
,clt
) -> (pr "--- %s" s
)^
(line_type2c clt
)
156 | PC.TPlusFile
(s
,clt
) -> (pr "+++ %s" s
)^
(line_type2c clt
)
158 | PC.TInc
(clt
) -> "++"^
(line_type2c clt
)
159 | PC.TDec
(clt
) -> "--"^
(line_type2c clt
)
161 | PC.TIf
(clt
) -> "if"^
(line_type2c clt
)
162 | PC.TElse
(clt
) -> "else"^
(line_type2c clt
)
163 | PC.TWhile
(clt
) -> "while"^
(line_type2c clt
)
164 | PC.TFor
(clt
) -> "for"^
(line_type2c clt
)
165 | PC.TDo
(clt
) -> "do"^
(line_type2c clt
)
166 | PC.TSwitch
(clt
) -> "switch"^
(line_type2c clt
)
167 | PC.TCase
(clt
) -> "case"^
(line_type2c clt
)
168 | PC.TDefault
(clt
) -> "default"^
(line_type2c clt
)
169 | PC.TReturn
(clt
) -> "return"^
(line_type2c clt
)
170 | PC.TBreak
(clt
) -> "break"^
(line_type2c clt
)
171 | PC.TContinue
(clt
) -> "continue"^
(line_type2c clt
)
172 | PC.TGoto
(clt
) -> "goto"^
(line_type2c clt
)
173 | PC.TIdent
(s
,clt
) -> (pr "ident-%s" s
)^
(line_type2c clt
)
174 | PC.TTypeId
(s
,clt
) -> (pr "typename-%s" s
)^
(line_type2c clt
)
175 | PC.TDeclarerId
(s
,clt
) -> (pr "declarername-%s" s
)^
(line_type2c clt
)
176 | PC.TIteratorId
(s
,clt
) -> (pr "iteratorname-%s" s
)^
(line_type2c clt
)
177 | PC.TMetaDeclarer
(_
,_
,_
,clt
) -> "declmeta"^
(line_type2c clt
)
178 | PC.TMetaIterator
(_
,_
,_
,clt
) -> "itermeta"^
(line_type2c clt
)
180 | PC.TSizeof
(clt
) -> "sizeof"^
(line_type2c clt
)
182 | PC.TString
(x
,clt
) -> x^
(line_type2c clt
)
183 | PC.TChar
(x
,clt
) -> x^
(line_type2c clt
)
184 | PC.TFloat
(x
,clt
) -> x^
(line_type2c clt
)
185 | PC.TInt
(x
,clt
) -> x^
(line_type2c clt
)
187 | PC.TOrLog
(clt
) -> "||"^
(line_type2c clt
)
188 | PC.TAndLog
(clt
) -> "&&"^
(line_type2c clt
)
189 | PC.TOr
(clt
) -> "|"^
(line_type2c clt
)
190 | PC.TXor
(clt
) -> "^"^
(line_type2c clt
)
191 | PC.TAnd
(clt
) -> "&"^
(line_type2c clt
)
192 | PC.TEqEq
(clt
) -> "=="^
(line_type2c clt
)
193 | PC.TNotEq
(clt
) -> "!="^
(line_type2c clt
)
194 | PC.TSub
(clt
) -> "<="^
(line_type2c clt
)
195 | PC.TTildeEq
(clt
) -> "~="^
(line_type2c clt
)
196 | PC.TTildeExclEq
(clt
) -> "~!="^
(line_type2c clt
)
197 | PC.TLogOp
(op
,clt
) ->
203 | _
-> failwith
"not possible")
205 | PC.TShLOp
(op
,clt
) -> "<<"^
(line_type2c clt
)
206 | PC.TShROp
(op
,clt
) -> ">>"^
(line_type2c clt
)
207 | PC.TPlus
(clt
) -> "+"^
(line_type2c clt
)
208 | PC.TMinus
(clt
) -> "-"^
(line_type2c clt
)
209 | PC.TMul
(clt
) -> "*"^
(line_type2c clt
)
210 | PC.TDmOp
(op
,clt
) ->
214 | _
-> failwith
"not possible")
216 | PC.TTilde
(clt
) -> "~"^
(line_type2c clt
)
218 | PC.TMetaParam
(_
,_
,clt
) -> "parammeta"^
(line_type2c clt
)
219 | PC.TMetaParamList
(_
,_
,_
,clt
) -> "paramlistmeta"^
(line_type2c clt
)
220 | PC.TMetaConst
(_
,_
,_
,_
,clt
) -> "constmeta"^
(line_type2c clt
)
221 | PC.TMetaErr
(_
,_
,_
,clt
) -> "errmeta"^
(line_type2c clt
)
222 | PC.TMetaExp
(_
,_
,_
,_
,clt
) -> "expmeta"^
(line_type2c clt
)
223 | PC.TMetaIdExp
(_
,_
,_
,_
,clt
) -> "idexpmeta"^
(line_type2c clt
)
224 | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
) -> "localidexpmeta"^
(line_type2c clt
)
225 | PC.TMetaExpList
(_
,_
,_
,clt
) -> "explistmeta"^
(line_type2c clt
)
226 | PC.TMetaId
(_
,_
,_
,clt
) -> "idmeta"^
(line_type2c clt
)
227 | PC.TMetaType
(_
,_
,clt
) -> "typemeta"^
(line_type2c clt
)
228 | PC.TMetaInit
(_
,_
,clt
) -> "initmeta"^
(line_type2c clt
)
229 | PC.TMetaDecl
(_
,_
,clt
) -> "declmeta"^
(line_type2c clt
)
230 | PC.TMetaField
(_
,_
,clt
) -> "fieldmeta"^
(line_type2c clt
)
231 | PC.TMetaStm
(_
,_
,clt
) -> "stmmeta"^
(line_type2c clt
)
232 | PC.TMetaStmList
(_
,_
,clt
) -> "stmlistmeta"^
(line_type2c clt
)
233 | PC.TMetaFunc
(_
,_
,_
,clt
) -> "funcmeta"^
(line_type2c clt
)
234 | PC.TMetaLocalFunc
(_
,_
,_
,clt
) -> "funcmeta"^
(line_type2c clt
)
235 | PC.TMetaPos
(_
,_
,_
,clt
) -> "posmeta"
237 | PC.TArobArob
-> "@@"
240 | PC.TScript
-> "script"
241 | PC.TInitialize
-> "initialize"
242 | PC.TFinalize
-> "finalize"
244 | PC.TWhen
(clt
) -> "WHEN"^
(line_type2c clt
)
245 | PC.TWhenTrue
(clt
) -> "WHEN TRUE"^
(line_type2c clt
)
246 | PC.TWhenFalse
(clt
) -> "WHEN FALSE"^
(line_type2c clt
)
247 | PC.TAny
(clt
) -> "ANY"^
(line_type2c clt
)
248 | PC.TStrict
(clt
) -> "STRICT"^
(line_type2c clt
)
249 | PC.TEllipsis
(clt
) -> "..."^
(line_type2c clt
)
251 | PC.TCircles(clt) -> "ooo"^(line_type2c clt)
252 | PC.TStars(clt) -> "***"^(line_type2c clt)
255 | PC.TOEllipsis
(clt
) -> "<..."^
(line_type2c clt
)
256 | PC.TCEllipsis
(clt
) -> "...>"^
(line_type2c clt
)
257 | PC.TPOEllipsis
(clt
) -> "<+..."^
(line_type2c clt
)
258 | PC.TPCEllipsis
(clt
) -> "...+>"^
(line_type2c clt
)
260 | PC.TOCircles(clt) -> "<ooo"^(line_type2c clt)
261 | PC.TCCircles(clt) -> "ooo>"^(line_type2c clt)
262 | PC.TOStars(clt) -> "<***"^(line_type2c clt)
263 | PC.TCStars(clt) -> "***>"^(line_type2c clt)
269 | PC.TWhy
(clt
) -> "?"^
(line_type2c clt
)
270 | PC.TDotDot
(clt
) -> ":"^
(line_type2c clt
)
271 | PC.TBang
(clt
) -> "!"^
(line_type2c clt
)
272 | PC.TOPar
(clt
) -> "("^
(line_type2c clt
)
273 | PC.TOPar0
(clt
) -> "("^
(line_type2c clt
)
274 | PC.TMid0
(clt
) -> "|"^
(line_type2c clt
)
275 | PC.TCPar
(clt
) -> ")"^
(line_type2c clt
)
276 | PC.TCPar0
(clt
) -> ")"^
(line_type2c clt
)
278 | PC.TOBrace
(clt
) -> "{"^
(line_type2c clt
)
279 | PC.TCBrace
(clt
) -> "}"^
(line_type2c clt
)
280 | PC.TOCro
(clt
) -> "["^
(line_type2c clt
)
281 | PC.TCCro
(clt
) -> "]"^
(line_type2c clt
)
282 | PC.TOInit
(clt
) -> "{"^
(line_type2c clt
)
284 | PC.TPtrOp
(clt
) -> "->"^
(line_type2c clt
)
286 | PC.TEq
(clt
) -> "="^
(line_type2c clt
)
287 | PC.TAssign
(_
,clt
) -> "=op"^
(line_type2c clt
)
288 | PC.TDot
(clt
) -> "."^
(line_type2c clt
)
289 | PC.TComma
(clt
) -> ","^
(line_type2c clt
)
290 | PC.TPtVirg
(clt
) -> ";"^
(line_type2c clt
)
293 | PC.TLineEnd
(clt
) -> "line end"
294 | PC.TInvalid
-> "invalid"
295 | PC.TFunDecl
(clt
) -> "fundecl"
298 | PC.TRightIso
-> "=>"
299 | PC.TIsoTopLevel
-> "TopLevel"
300 | PC.TIsoExpression
-> "Expression"
301 | PC.TIsoArgExpression
-> "ArgExpression"
302 | PC.TIsoTestExpression
-> "TestExpression"
303 | PC.TIsoToTestExpression
-> "ToTestExpression"
304 | PC.TIsoStatement
-> "Statement"
305 | PC.TIsoDeclaration
-> "Declaration"
306 | PC.TIsoType
-> "Type"
307 | PC.TUnderscore
-> "_"
308 | PC.TScriptData s
-> s
310 let print_tokens s tokens
=
311 Printf.printf
"%s\n" s
;
312 List.iter
(function x
-> Printf.printf
"%s " (token2c x
)) tokens
;
313 Printf.printf
"\n\n";
316 type plus
= PLUS
| NOTPLUS
| SKIP
318 let plus_attachable only_plus
(tok
,_
) =
320 PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
321 | PC.Tfloat
(clt
) | PC.Tlong
(clt
)
322 | PC.Tsize_t
(clt
) | PC.Tssize_t
(clt
) | PC.Tptrdiff_t
(clt
)
324 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
326 | PC.Tinline
(clt
) | PC.Ttypedef
(clt
) | PC.Tattr
(_
,clt
)
327 | PC.Tauto
(clt
) | PC.Tregister
(clt
)
328 | PC.Textern
(clt
) | PC.Tconst
(clt
) | PC.Tvolatile
(clt
)
330 | PC.TIncludeL
(_
,clt
) | PC.TIncludeNL
(_
,clt
) | PC.TDefine
(clt
,_
)
331 | PC.TDefineParam
(clt
,_
,_
,_
) | PC.TMinusFile
(_
,clt
) | PC.TPlusFile
(_
,clt
)
333 | PC.TInc
(clt
) | PC.TDec
(clt
)
335 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
336 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
) | PC.TReturn
(clt
)
337 | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
) | PC.TIdent
(_
,clt
)
338 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
342 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
)
344 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
345 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TTildeEq
(clt
)
347 | PC.TShLOp
(_
,clt
) | PC.TShROp
(_
,clt
)
348 | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
349 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
)
351 | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
352 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaErr
(_
,_
,_
,clt
)
353 | PC.TMetaExp
(_
,_
,_
,_
,clt
) | PC.TMetaIdExp
(_
,_
,_
,_
,clt
)
354 | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
355 | PC.TMetaExpList
(_
,_
,_
,clt
)
356 | PC.TMetaId
(_
,_
,_
,clt
)
357 | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
) | PC.TMetaStm
(_
,_
,clt
)
358 | PC.TMetaStmList
(_
,_
,clt
) | PC.TMetaDecl
(_
,_
,clt
) | PC.TMetaField
(_
,_
,clt
)
359 | PC.TMetaFunc
(_
,_
,_
,clt
) | PC.TMetaLocalFunc
(_
,_
,_
,clt
)
361 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
)
362 | PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TEllipsis
(clt
)
363 (* | PC.TCircles(clt) | PC.TStars(clt) *)
364 | PC.TOEllipsis
(clt
) | PC.TCEllipsis
(clt
)
365 | PC.TPOEllipsis
(clt
) | PC.TPCEllipsis
(clt
) (* | PC.TOCircles(clt)
366 | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(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
)
378 if List.mem
(line_type clt
) [D.PLUS
;D.PLUSPLUS
]
380 else if only_plus
then NOTPLUS
381 else if line_type clt
= D.CONTEXT
then PLUS
else NOTPLUS
383 | PC.TOPar0
(clt
) | PC.TMid0
(clt
) | PC.TCPar0
(clt
) -> NOTPLUS
384 | PC.TMetaPos
(nm
,_
,_
,_
) -> NOTPLUS
385 | PC.TSub
(clt
) -> NOTPLUS
389 let get_clt (tok
,_
) =
391 PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
392 | PC.Tfloat
(clt
) | PC.Tlong
(clt
) | PC.Tvoid
(clt
)
393 | PC.Tsize_t
(clt
) | PC.Tssize_t
(clt
) | PC.Tptrdiff_t
(clt
)
395 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
397 | PC.Tinline
(clt
) | PC.Tattr
(_
,clt
) | PC.Tauto
(clt
) | PC.Tregister
(clt
)
398 | PC.Textern
(clt
) | PC.Tconst
(clt
) | PC.Tvolatile
(clt
)
400 | PC.TIncludeL
(_
,clt
) | PC.TIncludeNL
(_
,clt
) | PC.TDefine
(clt
,_
)
401 | PC.TDefineParam
(clt
,_
,_
,_
) | PC.TMinusFile
(_
,clt
) | PC.TPlusFile
(_
,clt
)
403 | PC.TInc
(clt
) | PC.TDec
(clt
)
405 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
406 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
) | PC.TReturn
(clt
)
407 | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
) | PC.TIdent
(_
,clt
)
408 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
412 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
)
414 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
415 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TTildeEq
(clt
)
416 | PC.TSub
(clt
) | PC.TLogOp
(_
,clt
)
417 | PC.TShLOp
(_
,clt
) | PC.TShROp
(_
,clt
)
418 | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
419 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
)
421 | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
422 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaErr
(_
,_
,_
,clt
)
423 | PC.TMetaExp
(_
,_
,_
,_
,clt
) | PC.TMetaIdExp
(_
,_
,_
,_
,clt
)
424 | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
425 | PC.TMetaExpList
(_
,_
,_
,clt
)
426 | PC.TMetaId
(_
,_
,_
,clt
)
427 | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
) | PC.TMetaStm
(_
,_
,clt
)
428 | PC.TMetaStmList
(_
,_
,clt
) | PC.TMetaDecl
(_
,_
,clt
) | PC.TMetaField
(_
,_
,clt
)
429 | PC.TMetaFunc
(_
,_
,_
,clt
) | PC.TMetaLocalFunc
(_
,_
,_
,clt
)
430 | PC.TMetaPos
(_
,_
,_
,clt
)
432 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
) |
433 PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TEllipsis
(clt
)
434 (* | PC.TCircles(clt) | PC.TStars(clt) *)
436 | PC.TWhy
(clt
) | PC.TDotDot
(clt
) | PC.TBang
(clt
) | PC.TOPar
(clt
)
439 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOCro
(clt
) | PC.TCCro
(clt
)
444 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
447 | PC.TOPar0
(clt
) | PC.TMid0
(clt
) | PC.TCPar0
(clt
)
448 | PC.TOEllipsis
(clt
) | PC.TCEllipsis
(clt
)
449 | PC.TPOEllipsis
(clt
) | PC.TPCEllipsis
(clt
) (* | PC.TOCircles(clt)
450 | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *) -> clt
452 | _
-> failwith
"no clt"
454 let update_clt (tok
,x
) clt
=
456 PC.Tchar
(_
) -> (PC.Tchar
(clt
),x
)
457 | PC.Tshort
(_
) -> (PC.Tshort
(clt
),x
)
458 | PC.Tint
(_
) -> (PC.Tint
(clt
),x
)
459 | PC.Tdouble
(_
) -> (PC.Tdouble
(clt
),x
)
460 | PC.Tfloat
(_
) -> (PC.Tfloat
(clt
),x
)
461 | PC.Tlong
(_
) -> (PC.Tlong
(clt
),x
)
462 | PC.Tvoid
(_
) -> (PC.Tvoid
(clt
),x
)
463 | PC.Tsize_t
(_
) -> (PC.Tsize_t
(clt
),x
)
464 | PC.Tssize_t
(_
) -> (PC.Tssize_t
(clt
),x
)
465 | PC.Tptrdiff_t
(_
) -> (PC.Tptrdiff_t
(clt
),x
)
466 | PC.Tstruct
(_
) -> (PC.Tstruct
(clt
),x
)
467 | PC.Tunion
(_
) -> (PC.Tunion
(clt
),x
)
468 | PC.Tenum
(_
) -> (PC.Tenum
(clt
),x
)
469 | PC.Tunsigned
(_
) -> (PC.Tunsigned
(clt
),x
)
470 | PC.Tsigned
(_
) -> (PC.Tsigned
(clt
),x
)
471 | PC.Tstatic
(_
) -> (PC.Tstatic
(clt
),x
)
472 | PC.Tinline
(_
) -> (PC.Tinline
(clt
),x
)
473 | PC.Ttypedef
(_
) -> (PC.Ttypedef
(clt
),x
)
474 | PC.Tattr
(s
,_
) -> (PC.Tattr
(s
,clt
),x
)
475 | PC.Tauto
(_
) -> (PC.Tauto
(clt
),x
)
476 | PC.Tregister
(_
) -> (PC.Tregister
(clt
),x
)
477 | PC.Textern
(_
) -> (PC.Textern
(clt
),x
)
478 | PC.Tconst
(_
) -> (PC.Tconst
(clt
),x
)
479 | PC.Tvolatile
(_
) -> (PC.Tvolatile
(clt
),x
)
481 | PC.TIncludeL
(s
,_
) -> (PC.TIncludeL
(s
,clt
),x
)
482 | PC.TIncludeNL
(s
,_
) -> (PC.TIncludeNL
(s
,clt
),x
)
483 | PC.TDefine
(_
,a
) -> (PC.TDefine
(clt
,a
),x
)
484 | PC.TDefineParam
(_
,a
,b
,c
) -> (PC.TDefineParam
(clt
,a
,b
,c
),x
)
485 | PC.TMinusFile
(s
,_
) -> (PC.TMinusFile
(s
,clt
),x
)
486 | PC.TPlusFile
(s
,_
) -> (PC.TPlusFile
(s
,clt
),x
)
488 | PC.TInc
(_
) -> (PC.TInc
(clt
),x
)
489 | PC.TDec
(_
) -> (PC.TDec
(clt
),x
)
491 | PC.TIf
(_
) -> (PC.TIf
(clt
),x
)
492 | PC.TElse
(_
) -> (PC.TElse
(clt
),x
)
493 | PC.TWhile
(_
) -> (PC.TWhile
(clt
),x
)
494 | PC.TFor
(_
) -> (PC.TFor
(clt
),x
)
495 | PC.TDo
(_
) -> (PC.TDo
(clt
),x
)
496 | PC.TSwitch
(_
) -> (PC.TSwitch
(clt
),x
)
497 | PC.TCase
(_
) -> (PC.TCase
(clt
),x
)
498 | PC.TDefault
(_
) -> (PC.TDefault
(clt
),x
)
499 | PC.TReturn
(_
) -> (PC.TReturn
(clt
),x
)
500 | PC.TBreak
(_
) -> (PC.TBreak
(clt
),x
)
501 | PC.TContinue
(_
) -> (PC.TContinue
(clt
),x
)
502 | PC.TGoto
(_
) -> (PC.TGoto
(clt
),x
)
503 | PC.TIdent
(s
,_
) -> (PC.TIdent
(s
,clt
),x
)
504 | PC.TTypeId
(s
,_
) -> (PC.TTypeId
(s
,clt
),x
)
505 | PC.TDeclarerId
(s
,_
) -> (PC.TDeclarerId
(s
,clt
),x
)
506 | PC.TIteratorId
(s
,_
) -> (PC.TIteratorId
(s
,clt
),x
)
508 | PC.TSizeof
(_
) -> (PC.TSizeof
(clt
),x
)
510 | PC.TString
(s
,_
) -> (PC.TString
(s
,clt
),x
)
511 | PC.TChar
(s
,_
) -> (PC.TChar
(s
,clt
),x
)
512 | PC.TFloat
(s
,_
) -> (PC.TFloat
(s
,clt
),x
)
513 | PC.TInt
(s
,_
) -> (PC.TInt
(s
,clt
),x
)
515 | PC.TOrLog
(_
) -> (PC.TOrLog
(clt
),x
)
516 | PC.TAndLog
(_
) -> (PC.TAndLog
(clt
),x
)
517 | PC.TOr
(_
) -> (PC.TOr
(clt
),x
)
518 | PC.TXor
(_
) -> (PC.TXor
(clt
),x
)
519 | PC.TAnd
(_
) -> (PC.TAnd
(clt
),x
)
520 | PC.TEqEq
(_
) -> (PC.TEqEq
(clt
),x
)
521 | PC.TNotEq
(_
) -> (PC.TNotEq
(clt
),x
)
522 | PC.TTildeEq
(_
) -> (PC.TTildeEq
(clt
),x
)
523 | PC.TSub
(_
) -> (PC.TSub
(clt
),x
)
524 | PC.TLogOp
(op
,_
) -> (PC.TLogOp
(op
,clt
),x
)
525 | PC.TShLOp
(op
,_
) -> (PC.TShLOp
(op
,clt
),x
)
526 | PC.TShROp
(op
,_
) -> (PC.TShROp
(op
,clt
),x
)
527 | PC.TPlus
(_
) -> (PC.TPlus
(clt
),x
)
528 | PC.TMinus
(_
) -> (PC.TMinus
(clt
),x
)
529 | PC.TMul
(_
) -> (PC.TMul
(clt
),x
)
530 | PC.TDmOp
(op
,_
) -> (PC.TDmOp
(op
,clt
),x
)
531 | PC.TTilde
(_
) -> (PC.TTilde
(clt
),x
)
533 | PC.TMetaParam
(a
,b
,_
) -> (PC.TMetaParam
(a
,b
,clt
),x
)
534 | PC.TMetaParamList
(a
,b
,c
,_
) -> (PC.TMetaParamList
(a
,b
,c
,clt
),x
)
535 | PC.TMetaConst
(a
,b
,c
,d
,_
) -> (PC.TMetaConst
(a
,b
,c
,d
,clt
),x
)
536 | PC.TMetaErr
(a
,b
,c
,_
) -> (PC.TMetaErr
(a
,b
,c
,clt
),x
)
537 | PC.TMetaExp
(a
,b
,c
,d
,_
) -> (PC.TMetaExp
(a
,b
,c
,d
,clt
),x
)
538 | PC.TMetaIdExp
(a
,b
,c
,d
,_
) -> (PC.TMetaIdExp
(a
,b
,c
,d
,clt
),x
)
539 | PC.TMetaLocalIdExp
(a
,b
,c
,d
,_
) -> (PC.TMetaLocalIdExp
(a
,b
,c
,d
,clt
),x
)
540 | PC.TMetaExpList
(a
,b
,c
,_
) -> (PC.TMetaExpList
(a
,b
,c
,clt
),x
)
541 | PC.TMetaId
(a
,b
,c
,_
) -> (PC.TMetaId
(a
,b
,c
,clt
),x
)
542 | PC.TMetaType
(a
,b
,_
) -> (PC.TMetaType
(a
,b
,clt
),x
)
543 | PC.TMetaInit
(a
,b
,_
) -> (PC.TMetaInit
(a
,b
,clt
),x
)
544 | PC.TMetaDecl
(a
,b
,_
) -> (PC.TMetaDecl
(a
,b
,clt
),x
)
545 | PC.TMetaField
(a
,b
,_
) -> (PC.TMetaField
(a
,b
,clt
),x
)
546 | PC.TMetaStm
(a
,b
,_
) -> (PC.TMetaStm
(a
,b
,clt
),x
)
547 | PC.TMetaStmList
(a
,b
,_
) -> (PC.TMetaStmList
(a
,b
,clt
),x
)
548 | PC.TMetaFunc
(a
,b
,c
,_
) -> (PC.TMetaFunc
(a
,b
,c
,clt
),x
)
549 | PC.TMetaLocalFunc
(a
,b
,c
,_
) -> (PC.TMetaLocalFunc
(a
,b
,c
,clt
),x
)
551 | PC.TWhen
(_
) -> (PC.TWhen
(clt
),x
)
552 | PC.TWhenTrue
(_
) -> (PC.TWhenTrue
(clt
),x
)
553 | PC.TWhenFalse
(_
) -> (PC.TWhenFalse
(clt
),x
)
554 | PC.TAny
(_
) -> (PC.TAny
(clt
),x
)
555 | PC.TStrict
(_
) -> (PC.TStrict
(clt
),x
)
556 | PC.TEllipsis
(_
) -> (PC.TEllipsis
(clt
),x
)
558 | PC.TCircles(_) -> (PC.TCircles(clt),x)
559 | PC.TStars(_) -> (PC.TStars(clt),x)
562 | PC.TOEllipsis
(_
) -> (PC.TOEllipsis
(clt
),x
)
563 | PC.TCEllipsis
(_
) -> (PC.TCEllipsis
(clt
),x
)
564 | PC.TPOEllipsis
(_
) -> (PC.TPOEllipsis
(clt
),x
)
565 | PC.TPCEllipsis
(_
) -> (PC.TPCEllipsis
(clt
),x
)
567 | PC.TOCircles(_) -> (PC.TOCircles(clt),x)
568 | PC.TCCircles(_) -> (PC.TCCircles(clt),x)
569 | PC.TOStars(_) -> (PC.TOStars(clt),x)
570 | PC.TCStars(_) -> (PC.TCStars(clt),x)
573 | PC.TWhy
(_
) -> (PC.TWhy
(clt
),x
)
574 | PC.TDotDot
(_
) -> (PC.TDotDot
(clt
),x
)
575 | PC.TBang
(_
) -> (PC.TBang
(clt
),x
)
576 | PC.TOPar
(_
) -> (PC.TOPar
(clt
),x
)
577 | PC.TOPar0
(_
) -> (PC.TOPar0
(clt
),x
)
578 | PC.TMid0
(_
) -> (PC.TMid0
(clt
),x
)
579 | PC.TCPar
(_
) -> (PC.TCPar
(clt
),x
)
580 | PC.TCPar0
(_
) -> (PC.TCPar0
(clt
),x
)
582 | PC.TOBrace
(_
) -> (PC.TOBrace
(clt
),x
)
583 | PC.TCBrace
(_
) -> (PC.TCBrace
(clt
),x
)
584 | PC.TOCro
(_
) -> (PC.TOCro
(clt
),x
)
585 | PC.TCCro
(_
) -> (PC.TCCro
(clt
),x
)
586 | PC.TOInit
(_
) -> (PC.TOInit
(clt
),x
)
588 | PC.TPtrOp
(_
) -> (PC.TPtrOp
(clt
),x
)
590 | PC.TEq
(_
) -> (PC.TEq
(clt
),x
)
591 | PC.TAssign
(s
,_
) -> (PC.TAssign
(s
,clt
),x
)
592 | PC.TDot
(_
) -> (PC.TDot
(clt
),x
)
593 | PC.TComma
(_
) -> (PC.TComma
(clt
),x
)
594 | PC.TPtVirg
(_
) -> (PC.TPtVirg
(clt
),x
)
596 | PC.TLineEnd
(_
) -> (PC.TLineEnd
(clt
),x
)
597 | PC.TFunDecl
(_
) -> (PC.TFunDecl
(clt
),x
)
599 | _
-> failwith
"no clt"
602 (* ----------------------------------------------------------------------- *)
604 let make_name prefix ln
= Printf.sprintf
"%s starting on line %d" prefix ln
606 (* ----------------------------------------------------------------------- *)
609 let wrap_lexbuf_info lexbuf
=
610 (Lexing.lexeme lexbuf
, Lexing.lexeme_start lexbuf
)
612 let tokens_all_full token table file get_ats lexbuf end_markers
:
613 (bool * ((PC.token
* (string * (int * int) * (int * int))) list
)) =
616 let result = token lexbuf
in
617 let info = (Lexing.lexeme lexbuf
,
618 (table
.(Lexing.lexeme_start lexbuf
)),
619 (Lexing.lexeme_start lexbuf
, Lexing.lexeme_end lexbuf
)) in
623 then failwith
"unexpected end of file in a metavariable declaration"
624 else (false,[(result,info)])
625 else if List.mem
result end_markers
626 then (true,[(result,info)])
628 let (more
,rest
) = aux() in
629 (more
,(result, info)::rest
)
632 e
-> pr2 (Common.error_message file
(wrap_lexbuf_info lexbuf
) ); raise e
634 let tokens_all table file get_ats lexbuf end_markers
:
635 (bool * ((PC.token
* (string * (int * int) * (int * int))) list
)) =
636 tokens_all_full Lexer_cocci.token table file get_ats lexbuf end_markers
638 let tokens_script_all table file get_ats lexbuf end_markers
:
639 (bool * ((PC.token
* (string * (int * int) * (int * int))) list
)) =
640 tokens_all_full Lexer_script.token table file get_ats lexbuf end_markers
642 (* ----------------------------------------------------------------------- *)
643 (* Split tokens into minus and plus fragments *)
646 let (d
,_
,_
,_
,_
,_
,_
,_
) = clt
in
648 D.MINUS
| D.OPTMINUS
| D.UNIQUEMINUS
-> ([t
],[])
649 | D.PLUS
| D.PLUSPLUS
-> ([],[t
])
650 | D.CONTEXT
| D.UNIQUE
| D.OPT
-> ([t
],[t
])
652 let split_token ((tok
,_
) as t
) =
654 PC.TIdentifier
| PC.TConstant
| PC.TExpression
| PC.TIdExpression
655 | PC.TDeclaration
| PC.TField
656 | PC.TStatement
| PC.TPosition
| PC.TPosAny
| PC.TInitialiser
657 | PC.TFunction
| PC.TTypedef
| PC.TDeclarer
| PC.TIterator
| PC.TName
658 | PC.TType
| PC.TParameter
| PC.TLocal
| PC.Tlist
| PC.TFresh
659 | PC.TCppConcatOp
| PC.TPure
660 | PC.TContext
| PC.TRuleName
(_
) | PC.TUsing
| PC.TVirtual
| PC.TDisable
661 | PC.TExtends
| PC.TPathIsoFile
(_
)
662 | PC.TDepends
| PC.TOn
| PC.TEver
| PC.TNever
| PC.TExists
| PC.TForall
663 | PC.TError
| PC.TWords
| PC.TGenerated
| PC.TNothing
-> ([t
],[t
])
665 | PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
666 | PC.Tfloat
(clt
) | PC.Tlong
(clt
) | PC.Tvoid
(clt
)
667 | PC.Tsize_t
(clt
) | PC.Tssize_t
(clt
) | PC.Tptrdiff_t
(clt
)
669 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
670 | PC.Tstatic
(clt
) | PC.Tauto
(clt
) | PC.Tregister
(clt
) | PC.Textern
(clt
)
671 | PC.Tinline
(clt
) | PC.Ttypedef
(clt
) | PC.Tattr
(_
,clt
)
672 | PC.Tconst
(clt
) | PC.Tvolatile
(clt
) -> split t clt
674 | PC.TPragma
(s
,_
) -> ([],[t
]) (* only allowed in + *)
675 | PC.TPlusFile
(s
,clt
) | PC.TMinusFile
(s
,clt
)
676 | PC.TIncludeL
(s
,clt
) | PC.TIncludeNL
(s
,clt
) ->
678 | PC.TDefine
(clt
,_
) | PC.TDefineParam
(clt
,_
,_
,_
) -> split t clt
680 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
681 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
)
683 | PC.TReturn
(clt
) | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
)
685 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
686 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaExp
(_
,_
,_
,_
,clt
)
687 | PC.TMetaIdExp
(_
,_
,_
,_
,clt
) | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
688 | PC.TMetaExpList
(_
,_
,_
,clt
)
689 | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
690 | PC.TMetaId
(_
,_
,_
,clt
) | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
)
691 | PC.TMetaDecl
(_
,_
,clt
) | PC.TMetaField
(_
,_
,clt
)
692 | PC.TMetaStm
(_
,_
,clt
) | PC.TMetaStmList
(_
,_
,clt
) | PC.TMetaErr
(_
,_
,_
,clt
)
693 | PC.TMetaFunc
(_
,_
,_
,clt
) | PC.TMetaLocalFunc
(_
,_
,_
,clt
)
694 | PC.TMetaDeclarer
(_
,_
,_
,clt
) | PC.TMetaIterator
(_
,_
,_
,clt
) -> split t clt
695 | PC.TMPtVirg
| PC.TArob
| PC.TArobArob
| PC.TScript
696 | PC.TInitialize
| PC.TFinalize
-> ([t
],[t
])
697 | PC.TPArob
| PC.TMetaPos
(_
,_
,_
,_
) -> ([t
],[])
700 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
)
701 | PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TLineEnd
(clt
)
702 | PC.TEllipsis
(clt
) (* | PC.TCircles(clt) | PC.TStars(clt) *)
703 | PC.TOEllipsis
(clt
) | PC.TCEllipsis
(clt
)
704 | PC.TPOEllipsis
(clt
) | PC.TPCEllipsis
(clt
) -> split t clt
707 | PC.TOCircles(_) | PC.TCCircles(_) (* clt must be context *)
708 | PC.TOStars
(_
) | PC.TCStars
(_
) (* clt must be context *)
711 | PC.TBang0
| PC.TPlus0
| PC.TWhy0
->
714 | PC.TWhy
(clt
) | PC.TDotDot
(clt
)
715 | PC.TBang
(clt
) | PC.TOPar
(clt
) | PC.TOPar0
(clt
)
716 | PC.TMid0
(clt
) | PC.TCPar
(clt
) | PC.TCPar0
(clt
) -> split t clt
718 | PC.TInc
(clt
) | PC.TDec
(clt
) -> split t clt
720 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
) ->
723 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
724 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TTildeEq
(clt
)
725 | PC.TTildeExclEq
(clt
) | PC.TSub
(clt
) | PC.TLogOp
(_
,clt
)
726 | PC.TShLOp
(_
,clt
) | PC.TShROp
(_
,clt
)
727 | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
728 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
) -> split t clt
730 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOInit
(clt
) -> split t clt
731 | PC.TOCro
(clt
) | PC.TCCro
(clt
) -> split t clt
733 | PC.TPtrOp
(clt
) -> split t clt
735 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
736 | PC.TPtVirg
(clt
) -> split t clt
738 | PC.EOF
| PC.TInvalid
| PC.TUnderscore
-> ([t
],[t
])
740 | PC.TIso
| PC.TRightIso
741 | PC.TIsoExpression
| PC.TIsoStatement
| PC.TIsoDeclaration
| PC.TIsoType
742 | PC.TIsoTopLevel
| PC.TIsoArgExpression
| PC.TIsoTestExpression
743 | PC.TIsoToTestExpression
->
744 failwith
"unexpected tokens"
745 | PC.TScriptData s
-> ([t
],[t
])
747 let split_token_stream tokens
=
748 let rec loop = function
751 let (minus
,plus
) = split_token token
in
752 let (minus_stream
,plus_stream
) = loop tokens
in
753 (minus
@minus_stream
,plus
@plus_stream
) in
756 (* ----------------------------------------------------------------------- *)
757 (* Find function names *)
758 (* This addresses a shift-reduce problem in the parser, allowing us to
759 distinguish a function declaration from a function call even if the latter
760 has no return type. Undoubtedly, this is not very nice, but it doesn't
761 seem very convenient to refactor the grammar to get around the problem. *)
763 let rec find_function_names = function
765 | ((PC.TIdent
(_
,clt
),info) as t1
) :: ((PC.TOPar
(_
),_
) as t2
) :: rest
766 | ((PC.TMetaId
(_
,_
,_
,clt
),info) as t1
) :: ((PC.TOPar
(_
),_
) as t2
) :: rest
767 | ((PC.TMetaFunc
(_
,_
,_
,clt
),info) as t1
) :: ((PC.TOPar
(_
),_
) as t2
) :: rest
768 | ((PC.TMetaLocalFunc
(_
,_
,_
,clt
),info) as t1
)::((PC.TOPar
(_
),_
) as t2
)::rest
770 let rec skip level
= function
772 | ((PC.TCPar
(_
),_
) as t
)::rest
->
773 let level = level - 1 in
776 else let (pre
,found
,post
) = skip level rest
in (t
::pre
,found
,post
)
777 | ((PC.TOPar
(_
),_
) as t
)::rest
->
778 let level = level + 1 in
779 let (pre
,found
,post
) = skip level rest
in (t
::pre
,found
,post
)
780 | ((PC.TArobArob
,_
) as t
)::rest
781 | ((PC.TArob
,_
) as t
)::rest
782 | ((PC.EOF
,_
) as t
)::rest
-> ([t
],false,rest
)
784 let (pre
,found
,post
) = skip level rest
in (t
::pre
,found
,post
) in
785 let (pre
,found
,post
) = skip 1 rest
in
786 (match (found
,post
) with
787 (true,((PC.TOBrace
(_
),_
) as t3
)::rest
) ->
788 (PC.TFunDecl
(clt
),info) :: t1
:: t2
:: pre
@
789 t3
:: (find_function_names rest
)
790 | _
-> t1
:: t2
:: pre
@ find_function_names post
)
791 | t
:: rest
-> t
:: find_function_names rest
793 (* ----------------------------------------------------------------------- *)
794 (* an attribute is an identifier that preceeds another identifier and
797 let rec detect_attr l
=
799 (PC.TIdent
(_
,_
),_
) | (PC.TMetaId
(_
,_
,_
,_
),_
) | (PC.TMetaFunc
(_
,_
,_
,_
),_
)
800 | (PC.TMetaLocalFunc
(_
,_
,_
,_
),_
) -> true
802 let rec loop = function
805 | ((PC.TIdent
(nm
,clt
),info) as t1
)::id
::rest
when is_id id
->
806 if String.length nm
> 2 && String.sub nm
0 2 = "__"
807 then (PC.Tattr
(nm
,clt
),info)::(loop (id
::rest
))
808 else t1
::(loop (id
::rest
))
809 | x
::xs
-> x
::(loop xs
) in
812 (* ----------------------------------------------------------------------- *)
813 (* Look for variable declarations where the name is a typedef name.
814 We assume that C code does not contain a multiplication as a top-level
817 (* bug: once a type, always a type, even if the same name is later intended
818 to be used as a real identifier *)
819 let detect_types in_meta_decls l
=
820 let is_delim infn
= function
821 (PC.TOEllipsis
(_
),_
) (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *)
822 | (PC.TPOEllipsis
(_
),_
) (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *)
823 | (PC.TEllipsis
(_
),_
) (* | (PC.TCircles(_),_) | (PC.TStars(_),_) *)
824 | (PC.TPtVirg
(_
),_
) | (PC.TOBrace
(_
),_
) | (PC.TOInit
(_
),_
)
826 | (PC.TPure
,_
) | (PC.TContext
,_
)
827 | (PC.Tstatic
(_
),_
) | (PC.Textern
(_
),_
)
828 | (PC.Tinline
(_
),_
) | (PC.Ttypedef
(_
),_
) | (PC.Tattr
(_
),_
) -> true
829 | (PC.TComma
(_
),_
) when infn
> 0 or in_meta_decls
-> true
830 | (PC.TDotDot
(_
),_
) when in_meta_decls
-> true
832 let is_choices_delim = function
833 (PC.TOBrace
(_
),_
) | (PC.TComma
(_
),_
) -> true | _
-> false in
835 (PC.TIdent
(_
,_
),_
) | (PC.TMetaId
(_
,_
,_
,_
),_
) | (PC.TMetaFunc
(_
,_
,_
,_
),_
)
836 | (PC.TMetaLocalFunc
(_
,_
,_
,_
),_
) -> true
837 | (PC.TMetaParam
(_
,_
,_
),_
)
838 | (PC.TMetaParamList
(_
,_
,_
,_
),_
)
839 | (PC.TMetaConst
(_
,_
,_
,_
,_
),_
)
840 | (PC.TMetaErr
(_
,_
,_
,_
),_
)
841 | (PC.TMetaExp
(_
,_
,_
,_
,_
),_
)
842 | (PC.TMetaIdExp
(_
,_
,_
,_
,_
),_
)
843 | (PC.TMetaLocalIdExp
(_
,_
,_
,_
,_
),_
)
844 | (PC.TMetaExpList
(_
,_
,_
,_
),_
)
845 | (PC.TMetaType
(_
,_
,_
),_
)
846 | (PC.TMetaInit
(_
,_
,_
),_
)
847 | (PC.TMetaDecl
(_
,_
,_
),_
)
848 | (PC.TMetaField
(_
,_
,_
),_
)
849 | (PC.TMetaStm
(_
,_
,_
),_
)
850 | (PC.TMetaStmList
(_
,_
,_
),_
)
851 | (PC.TMetaPos
(_
,_
,_
,_
),_
) -> in_meta_decls
853 let redo_id ident clt v
=
854 !Data.add_type_name ident
;
855 (PC.TTypeId
(ident
,clt
),v
) in
856 let rec loop start infn type_names
= function
857 (* infn: 0 means not in a function header
858 > 0 means in a function header, after infn - 1 unmatched open parens*)
860 | ((PC.TOBrace
(clt
),v
)::_
) as all
when in_meta_decls
->
861 collect_choices type_names all
(* never a function header *)
862 | delim
::(PC.TIdent
(ident
,clt
),v
)::((PC.TMul
(_
),_
) as x
)::rest
863 when is_delim infn delim
->
864 let newid = redo_id ident clt v
in
865 delim
::newid::x
::(loop false infn
(ident
::type_names
) rest
)
866 | delim
::(PC.TIdent
(ident
,clt
),v
)::id
::rest
867 when is_delim infn delim
&& is_id id
->
868 let newid = redo_id ident clt v
in
869 delim
::newid::id
::(loop false infn
(ident
::type_names
) rest
)
870 | ((PC.TFunDecl
(_
),_
) as fn
)::rest
->
871 fn
::(loop false 1 type_names rest
)
872 | ((PC.TOPar
(_
),_
) as lp
)::rest
when infn
> 0 ->
873 lp
::(loop false (infn
+ 1) type_names rest
)
874 | ((PC.TCPar
(_
),_
) as rp
)::rest
when infn
> 0 ->
876 then rp
::(loop false 0 type_names rest
) (* 0 means not in fn header *)
877 else rp
::(loop false (infn
- 1) type_names rest
)
878 | (PC.TIdent
(ident
,clt
),v
)::((PC.TMul
(_
),_
) as x
)::rest
when start
->
879 let newid = redo_id ident clt v
in
880 newid::x
::(loop false infn
(ident
::type_names
) rest
)
881 | (PC.TIdent
(ident
,clt
),v
)::id
::rest
when start
&& is_id id
->
882 let newid = redo_id ident clt v
in
883 newid::id
::(loop false infn
(ident
::type_names
) rest
)
884 | (PC.TIdent
(ident
,clt
),v
)::rest
when List.mem ident type_names
->
885 (PC.TTypeId
(ident
,clt
),v
)::(loop false infn type_names rest
)
886 | ((PC.TIdent
(ident
,clt
),v
) as x
)::rest
->
887 x
::(loop false infn type_names rest
)
888 | x
::rest
-> x
::(loop false infn type_names rest
)
889 and collect_choices type_names
= function
890 [] -> [] (* should happen, but let the parser detect that *)
891 | (PC.TCBrace
(clt
),v
)::rest
->
892 (PC.TCBrace
(clt
),v
)::(loop false 0 type_names rest
)
893 | delim
::(PC.TIdent
(ident
,clt
),v
)::rest
894 when is_choices_delim delim
->
895 let newid = redo_id ident clt v
in
896 delim
::newid::(collect_choices
(ident
::type_names
) rest
)
897 | x
::rest
-> x
::(collect_choices type_names rest
) in
901 (* ----------------------------------------------------------------------- *)
902 (* Insert TLineEnd tokens at the end of a line that contains a WHEN.
903 WHEN is restricted to a single line, to avoid ambiguity in eg:
907 let token2line (tok
,_
) =
909 PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
910 | PC.Tfloat
(clt
) | PC.Tlong
(clt
) | PC.Tvoid
(clt
)
911 | PC.Tsize_t
(clt
) | PC.Tssize_t
(clt
) | PC.Tptrdiff_t
(clt
)
913 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
914 | PC.Tstatic
(clt
) | PC.Tauto
(clt
) | PC.Tregister
(clt
) | PC.Textern
(clt
)
915 | PC.Tinline
(clt
) | PC.Ttypedef
(clt
) | PC.Tattr
(_
,clt
) | PC.Tconst
(clt
)
918 | PC.TInc
(clt
) | PC.TDec
(clt
)
920 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
921 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
) | PC.TSizeof
(clt
)
922 | PC.TReturn
(clt
) | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
)
924 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
925 | PC.TMetaDeclarer
(_
,_
,_
,clt
) | PC.TMetaIterator
(_
,_
,_
,clt
)
927 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
)
929 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
930 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TLogOp
(_
,clt
)
931 | PC.TShLOp
(_
,clt
) | PC.TShROp
(_
,clt
)
932 | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
933 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
)
935 | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
936 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaExp
(_
,_
,_
,_
,clt
)
937 | PC.TMetaIdExp
(_
,_
,_
,_
,clt
) | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
938 | PC.TMetaExpList
(_
,_
,_
,clt
)
939 | PC.TMetaId
(_
,_
,_
,clt
) | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
)
940 | PC.TMetaDecl
(_
,_
,clt
) | PC.TMetaField
(_
,_
,clt
)
941 | PC.TMetaStm
(_
,_
,clt
) | PC.TMetaStmList
(_
,_
,clt
) | PC.TMetaFunc
(_
,_
,_
,clt
)
942 | PC.TMetaLocalFunc
(_
,_
,_
,clt
) | PC.TMetaPos
(_
,_
,_
,clt
)
945 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
)
946 | PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TEllipsis
(clt
)
947 (* | PC.TCircles(clt) | PC.TStars(clt) *)
949 | PC.TOEllipsis
(clt
) | PC.TCEllipsis
(clt
)
950 | PC.TPOEllipsis
(clt
) | PC.TPCEllipsis
(clt
) (*| PC.TOCircles(clt)
951 | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *)
953 | PC.TWhy
(clt
) | PC.TDotDot
(clt
) | PC.TBang
(clt
) | PC.TOPar
(clt
)
954 | PC.TOPar0
(clt
) | PC.TMid0
(clt
) | PC.TCPar
(clt
)
957 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOCro
(clt
) | PC.TCCro
(clt
)
962 | PC.TDefine
(clt
,_
) | PC.TDefineParam
(clt
,_
,_
,_
)
963 | PC.TIncludeL
(_
,clt
) | PC.TIncludeNL
(_
,clt
)
965 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
967 let (_
,line
,_
,_
,_
,_
,_
,_
) = clt
in Some line
971 let rec insert_line_end = function
973 | (((PC.TWhen
(clt
),q
) as x
)::xs
) ->
974 x
::(find_line_end
true (token2line x
) clt q xs
)
975 | (((PC.TDefine
(clt
,_
),q
) as x
)::xs
)
976 | (((PC.TDefineParam
(clt
,_
,_
,_
),q
) as x
)::xs
) ->
977 x
::(find_line_end
false (token2line x
) clt q xs
)
978 | x
::xs
-> x
::(insert_line_end xs
)
980 and find_line_end inwhen line clt q
= function
981 (* don't know what 2nd component should be so just use the info of
982 the When. Also inherit - of when, if any *)
983 [] -> [(PC.TLineEnd
(clt
),q
)]
984 | ((PC.TIdent
("strict",clt
),a
) as x
)::xs
when token2line x
= line
->
985 (PC.TStrict
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
986 | ((PC.TIdent
("STRICT",clt
),a
) as x
)::xs
when token2line x
= line
->
987 (PC.TStrict
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
988 | ((PC.TIdent
("any",clt
),a
) as x
)::xs
when token2line x
= line
->
989 (PC.TAny
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
990 | ((PC.TIdent
("ANY",clt
),a
) as x
)::xs
when token2line x
= line
->
991 (PC.TAny
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
992 | ((PC.TIdent
("forall",clt
),a
) as x
)::xs
when token2line x
= line
->
993 (PC.TForall
,a
) :: (find_line_end inwhen line clt q xs
)
994 | ((PC.TIdent
("exists",clt
),a
) as x
)::xs
when token2line x
= line
->
995 (PC.TExists
,a
) :: (find_line_end inwhen line clt q xs
)
996 | ((PC.TComma
(clt
),a
) as x
)::xs
when token2line x
= line
->
997 (PC.TComma
(clt
),a
) :: (find_line_end inwhen line clt q xs
)
998 | ((PC.TPArob
,a
) as x
)::xs
-> (* no line #, just assume on the same line *)
999 x
:: (find_line_end inwhen line clt q xs
)
1000 | x
::xs
when token2line x
= line
-> x
:: (find_line_end inwhen line clt q xs
)
1001 | xs
-> (PC.TLineEnd
(clt
),q
)::(insert_line_end xs
)
1003 let rec translate_when_true_false = function
1005 | (PC.TWhen
(clt
),q
)::((PC.TNotEq
(_
),_
) as x
)::(PC.TIdent
("true",_
),_
)::xs
->
1006 (PC.TWhenTrue
(clt
),q
)::x
::(translate_when_true_false xs
)
1007 | (PC.TWhen
(clt
),q
)::((PC.TNotEq
(_
),_
) as x
)::(PC.TIdent
("false",_
),_
)::xs
->
1008 (PC.TWhenFalse
(clt
),q
)::x
::(translate_when_true_false xs
)
1009 | x
::xs
-> x
:: (translate_when_true_false xs
)
1011 (* ----------------------------------------------------------------------- *)
1013 (* In a nest, if the nest is -, all of the nested code must also be -.
1014 All are converted to context, because the next takes care of the -. *)
1015 let check_nests tokens
=
1017 let (line_type,a
,b
,c
,d
,e
,f
,g
) = get_clt t
in
1018 List.mem
line_type [D.MINUS
;D.OPTMINUS
;D.UNIQUEMINUS
] in
1020 let clt = try Some
(get_clt t
) with Failure _
-> None
in
1022 Some
(line_type,a
,b
,c
,d
,e
,f
,g
) ->
1023 (match line_type with
1024 D.MINUS
-> update_clt t
(D.CONTEXT
,a
,b
,c
,d
,e
,f
,g
)
1025 | D.OPTMINUS
-> update_clt t
(D.OPT
,a
,b
,c
,d
,e
,f
,g
)
1026 | D.UNIQUEMINUS
-> update_clt t
(D.UNIQUE
,a
,b
,c
,d
,e
,f
,g
)
1027 | _
-> failwith
"minus token expected")
1029 let rec outside = function
1031 | ((PC.TPOEllipsis
(clt),q
) as t
)::r
when is_minus t
-> t
:: inside
0 r
1032 | t
::r
-> t
:: outside r
1033 and inside stack
= function
1034 [] -> failwith
"missing nest end"
1035 | ((PC.TPCEllipsis
(clt),q
) as t
)::r
->
1037 :: (if stack
= 0 then outside r
else inside
(stack
- 1) r
)
1038 | ((PC.TPOEllipsis
(clt),q
) as t
)::r
->
1039 (drop_minus t
) :: (inside
(stack
+ 1) r
)
1040 | t
:: r
-> (drop_minus t
) :: (inside stack r
) in
1043 let check_parentheses tokens
=
1044 let clt2line (_
,line
,_
,_
,_
,_
,_
,_
) = line
in
1045 let rec loop seen_open
= function
1047 | (PC.TOPar
(clt),q
) :: rest
1048 | (PC.TDefineParam
(clt,_
,_
,_
),q
) :: rest
->
1049 loop (Common.Left
(clt2line clt) :: seen_open
) rest
1050 | (PC.TOPar0
(clt),q
) :: rest
->
1051 loop (Common.Right
(clt2line clt) :: seen_open
) rest
1052 | (PC.TCPar
(clt),q
) :: rest
->
1053 (match seen_open
with
1057 "unexpected close parenthesis in line %d\n" (clt2line clt))
1058 | Common.Left _
:: seen_open
-> loop seen_open rest
1059 | Common.Right open_line
:: _
->
1062 "disjunction parenthesis in line %d column 0 matched to normal parenthesis on line %d\n" open_line
(clt2line clt)))
1063 | (PC.TCPar0
(clt),q
) :: rest
->
1064 (match seen_open
with
1068 "unexpected close parenthesis in line %d\n" (clt2line clt))
1069 | Common.Right _
:: seen_open
-> loop seen_open rest
1070 | Common.Left open_line
:: _
->
1073 "normal parenthesis in line %d matched to disjunction parenthesis on line %d column 0\n" open_line
(clt2line clt)))
1074 | x
::rest
-> loop seen_open rest
in
1077 (* ----------------------------------------------------------------------- *)
1078 (* top level initializers: a sequence of braces followed by a dot *)
1080 let find_top_init tokens
=
1082 (PC.TOBrace
(clt),q
) :: rest
->
1083 let rec dot_start acc
= function
1084 ((PC.TOBrace
(_
),_
) as x
) :: rest
->
1085 dot_start (x
::acc
) rest
1086 | ((PC.TDot
(_
),_
) :: rest
) as x
->
1087 Some
((PC.TOInit
(clt),q
) :: (List.rev acc
) @ x
)
1089 let rec comma_end acc
= function
1090 ((PC.TCBrace
(_
),_
) as x
) :: rest
->
1091 comma_end (x
::acc
) rest
1092 | ((PC.TComma
(_
),_
) :: rest
) as x
->
1093 Some
((PC.TOInit
(clt),q
) :: (List.rev x
) @ acc
)
1095 (match dot_start [] rest
with
1098 (match List.rev rest
with
1099 (* not super sure what this does, but EOF, @, and @@ should be
1100 the same, markind the end of a rule *)
1101 ((PC.EOF
,_
) as x
)::rest
| ((PC.TArob
,_
) as x
)::rest
1102 | ((PC.TArobArob
,_
) as x
)::rest
->
1103 (match comma_end [x
] rest
with
1107 failwith
"unexpected empty token list"))
1110 (* ----------------------------------------------------------------------- *)
1111 (* Integrate pragmas into some adjacent token. + tokens are preferred. Dots
1114 let rec collect_all_pragmas collected
= function
1115 (PC.TPragma
(s
,(_
,line
,logical_line
,offset
,col
,_
,_
,pos
)),_
)::rest
->
1117 { Ast0.line_start
= line
; Ast0.line_end
= line
;
1118 Ast0.logical_start
= logical_line
; Ast0.logical_end
= logical_line
;
1119 Ast0.column
= col
; Ast0.offset
= offset
; } in
1120 collect_all_pragmas ((s
,i)::collected
) rest
1121 | l
-> (List.rev collected
,l
)
1123 let rec collect_pass = function
1126 match plus_attachable false x
with
1128 let (pass
,rest
) = collect_pass xs
in
1132 let plus_attach strict
= function
1134 | Some x
-> plus_attachable strict x
1136 let add_bef = function Some x
-> [x
] | None
-> []
1138 (*skips should be things like line end
1139 skips is things before pragmas that can't be attached to, pass is things
1140 after. pass is used immediately. skips accumulates. *)
1141 let rec process_pragmas bef skips
= function
1142 [] -> add_bef bef
@ List.rev skips
1143 | ((PC.TPragma
(s
,i),_
)::_
) as l
->
1144 let (pragmas
,rest
) = collect_all_pragmas [] l
in
1145 let (pass
,rest0
) = collect_pass rest
in
1147 match rest0
with [] -> (None
,[]) | next
::rest
-> (Some next
,rest
) in
1148 (match (bef
,plus_attach true bef
,next
,plus_attach true next
) with
1149 (Some bef
,PLUS
,_
,_
) ->
1150 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt bef
in
1151 (update_clt bef
(a
,b
,c
,d
,e
,strbef
,pragmas
,pos
))::List.rev skips
@
1152 pass
@process_pragmas None
[] rest0
1153 | (_
,_
,Some next
,PLUS
) ->
1154 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt next
in
1155 (add_bef bef
) @ List.rev skips
@ pass
@
1157 (Some
(update_clt next
(a
,b
,c
,d
,e
,pragmas
,straft
,pos
)))
1160 (match (bef
,plus_attach false bef
,next
,plus_attach false next
) with
1161 (Some bef
,PLUS
,_
,_
) ->
1162 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt bef
in
1163 (update_clt bef
(a
,b
,c
,d
,e
,strbef
,pragmas
,pos
))::List.rev skips
@
1164 pass
@process_pragmas None
[] rest0
1165 | (_
,_
,Some next
,PLUS
) ->
1166 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt next
in
1167 (add_bef bef
) @ List.rev skips
@ pass
@
1169 (Some
(update_clt next
(a
,b
,c
,d
,e
,pragmas
,straft
,pos
)))
1171 | _
-> failwith
"nothing to attach pragma to"))
1173 (match plus_attachable false x
with
1174 SKIP
-> process_pragmas bef
(x
::skips
) xs
1175 | _
-> (add_bef bef
) @ List.rev skips
@ (process_pragmas (Some x
) [] xs
))
1177 (* ----------------------------------------------------------------------- *)
1178 (* Drop ... ... . This is only allowed in + code, and arises when there is
1179 some - code between the ... *)
1180 (* drop whens as well - they serve no purpose in + code and they cause
1181 problems for drop_double_dots *)
1183 let rec drop_when = function
1185 | (PC.TWhen
(clt),info)::xs
->
1186 let rec loop = function
1188 | (PC.TLineEnd
(_
),info)::xs
-> drop_when xs
1189 | x
::xs
-> loop xs
in
1191 | x
::xs
-> x
::drop_when xs
1193 (* instead of dropping the double dots, we put TNothing in between them.
1194 these vanish after the parser, but keeping all the ...s in the + code makes
1195 it easier to align the + and - code in context_neg and in preparation for the
1196 isomorphisms. This shouldn't matter because the context code of the +
1197 slice is mostly ignored anyway *)
1198 let minus_to_nothing l
=
1199 (* for cases like | <..., which may or may not arise from removing minus
1200 code, depending on whether <... is a statement or expression *)
1203 let (d
,_
,_
,_
,_
,_
,_
,_
) = get_clt tok
in
1205 D.MINUS
| D.OPTMINUS
| D.UNIQUEMINUS
-> true
1206 | D.PLUS
| D.PLUSPLUS
-> false
1207 | D.CONTEXT
| D.UNIQUE
| D.OPT
-> false)
1209 let rec minus_loop = function
1211 | (d
::ds
) as l
-> if is_minus d
then minus_loop ds
else l
in
1212 let rec loop = function
1214 | ((PC.TMid0
(clt),i) as x
)::t1
::ts
when is_minus t1
->
1215 (match minus_loop ts
with
1216 ((PC.TOEllipsis
(_
),_
)::_
) | ((PC.TPOEllipsis
(_
),_
)::_
)
1217 | ((PC.TEllipsis
(_
),_
)::_
) as l
-> x
::(PC.TNothing
,i)::(loop l
)
1219 | t
::ts
-> t
::(loop ts
) in
1222 let rec drop_double_dots l
=
1223 let start = function
1224 (PC.TOEllipsis
(_
),_
) | (PC.TPOEllipsis
(_
),_
)
1225 (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *) ->
1228 let middle = function
1229 (PC.TEllipsis
(_
),_
) (* | (PC.TCircles(_),_) | (PC.TStars(_),_) *) -> true
1231 let whenline = function
1232 (PC.TLineEnd
(_
),_
) -> true
1233 (*| (PC.TMid0(_),_) -> true*)
1235 let final = function
1236 (PC.TCEllipsis
(_
),_
) | (PC.TPCEllipsis
(_
),_
)
1237 (* | (PC.TCCircles(_),_) | (PC.TCStars(_),_) *) ->
1240 let any_before x
= start x
or middle x
or final x
or whenline x
in
1241 let any_after x
= start x
or middle x
or final x
in
1242 let rec loop ((_
,i) as prev
) = function
1244 | x
::rest
when any_before prev
&& any_after x
->
1245 (PC.TNothing
,i)::x
::(loop x rest
)
1246 | ((PC.TComma
(_
),_
) as c
)::x
::rest
when any_before prev
&& any_after x
->
1247 c
::(PC.TNothing
,i)::x
::(loop x rest
)
1248 | x
::rest
-> x
:: (loop x rest
) in
1251 | (x
::xs
) -> x
:: loop x xs
1255 if l
= cur then l
else fix f
cur
1257 (* ( | ... | ) also causes parsing problems *)
1261 let rec drop_empty_thing starter
middle ender
= function
1263 | hd
::rest
when starter hd
->
1264 let rec loop = function
1265 x
::rest
when middle x
-> loop rest
1266 | x
::rest
when ender x
-> rest
1267 | _
-> raise Not_empty
in
1268 (match try Some
(loop rest
) with Not_empty
-> None
with
1269 Some x
-> drop_empty_thing starter
middle ender x
1270 | None
-> hd
:: drop_empty_thing starter
middle ender rest
)
1271 | x
::rest
-> x
:: drop_empty_thing starter
middle ender rest
1275 (function (PC.TOPar0
(_
),_
) -> true | _
-> false)
1276 (function (PC.TMid0
(_
),_
) -> true | _
-> false)
1277 (function (PC.TCPar0
(_
),_
) -> true | _
-> false)
1279 let drop_empty_nest = drop_empty_thing
1281 (* ----------------------------------------------------------------------- *)
1284 let get_s_starts (_
, (s
,_
,(starts
, ends
))) =
1285 Printf.printf
"%d %d\n" starts ends
; (s
, starts
)
1288 let v = List.hd
!l
in
1293 PC.reinit (function _
-> PC.TArobArob
(* a handy token *))
1294 (Lexing.from_function
1295 (function buf
-> function n
-> raise
Common.Impossible
))
1297 let parse_one str parsefn file toks
=
1298 let all_tokens = ref toks
in
1299 let cur_tok = ref (List.hd
!all_tokens) in
1301 let lexer_function _
=
1302 let (v, info) = pop2 all_tokens in
1303 cur_tok := (v, info);
1307 Lexing.from_function
1308 (function buf
-> function n
-> raise
Common.Impossible
)
1313 try parsefn
lexer_function lexbuf_fake
1315 Lexer_cocci.Lexical s
->
1317 (Printf.sprintf
"%s: lexical error: %s\n =%s\n" str s
1318 (Common.error_message file
(get_s_starts !cur_tok) ))
1319 | Parser_cocci_menhir.Error
->
1321 (Printf.sprintf
"%s: parse error: \n = %s\n" str
1322 (Common.error_message file
(get_s_starts !cur_tok) ))
1323 | Semantic_cocci.Semantic s
->
1325 (Printf.sprintf
"%s: semantic error: %s\n =%s\n" str s
1326 (Common.error_message file
(get_s_starts !cur_tok) ))
1330 let prepare_tokens tokens
=
1332 (translate_when_true_false (* after insert_line_end *)
1335 (find_function_names
1338 (check_parentheses tokens
)))))))
1340 let prepare_mv_tokens tokens
=
1341 detect_types false (detect_attr tokens
)
1343 let rec consume_minus_positions = function
1345 | ((PC.TOPar0
(_
),_
) as x
)::xs
| ((PC.TCPar0
(_
),_
) as x
)::xs
1346 | ((PC.TMid0
(_
),_
) as x
)::xs
-> x
::consume_minus_positions xs
1347 | x
::(PC.TPArob
,_
)::(PC.TMetaPos
(name
,constraints
,per
,clt),_
)::xs
->
1348 let (arity
,ln
,lln
,offset
,col
,strbef
,straft
,_
) = get_clt x
in
1349 let name = Parse_aux.clt2mcode
name clt in
1352 (arity
,ln
,lln
,offset
,col
,strbef
,straft
,
1353 Ast0.MetaPos
(name,constraints
,per
)) in
1354 x::(consume_minus_positions xs
)
1355 | x::xs
-> x::consume_minus_positions xs
1357 let any_modif rule
=
1359 match Ast0.get_mcode_mcodekind
x with
1360 Ast0.MINUS _
| Ast0.PLUS _
-> true
1362 let donothing r k e
= k e
in
1363 let bind x y
= x or y
in
1364 let option_default = false in
1366 V0.flat_combiner
bind option_default
1367 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1368 donothing donothing donothing donothing donothing donothing
1369 donothing donothing donothing donothing donothing donothing donothing
1370 donothing donothing in
1371 List.exists
fn.VT0.combiner_rec_top_level rule
1373 let eval_virt virt
=
1376 if not
(List.mem
x virt
)
1377 then raise
(Bad_virt
x))
1378 !Flag.defined_virtual_rules
1380 let drop_last extra l
= List.rev
(extra
@(List.tl
(List.rev l
)))
1382 let partition_either l
=
1383 let rec part_either left right
= function
1384 | [] -> (List.rev left
, List.rev right
)
1387 | Common.Left e
-> part_either (e
:: left
) right l
1388 | Common.Right e
-> part_either left
(e
:: right
) l
) in
1391 let get_metavars parse_fn table file lexbuf
=
1392 let rec meta_loop acc
(* read one decl at a time *) =
1396 tokens_all table file
true lexbuf
[PC.TArobArob
;PC.TMPtVirg
]) in
1397 let tokens = prepare_mv_tokens tokens in
1399 [(PC.TArobArob
,_
)] -> List.rev acc
1401 let metavars = parse_one "meta" parse_fn file
tokens in
1402 meta_loop (metavars@acc
) in
1403 partition_either (meta_loop [])
1405 let get_script_metavars parse_fn table file lexbuf
=
1406 let rec meta_loop acc
=
1408 tokens_all table file
true lexbuf
[PC.TArobArob
; PC.TMPtVirg
] in
1409 let tokens = prepare_tokens tokens in
1411 [(PC.TArobArob
, _
)] -> List.rev acc
1413 let metavar = parse_one "scriptmeta" parse_fn file
tokens in
1414 meta_loop (metavar :: acc
)
1418 let get_rule_name parse_fn starts_with_name get_tokens file prefix
=
1419 Data.in_rule_name
:= true;
1420 let mknm _
= make_name prefix
(!Lexer_cocci.line
) in
1424 let (_
,tokens) = get_tokens
[PC.TArob
] in
1425 let check_name = function
1426 None
-> Some
(mknm())
1428 (if List.mem nm
reserved_names
1429 then failwith
(Printf.sprintf
"invalid name %s\n" nm
));
1431 match parse_one "rule name" parse_fn file
tokens with
1432 Ast.CocciRulename
(nm
,a
,b
,c
,d
,e
) ->
1433 Ast.CocciRulename
(check_name nm
,a
,b
,c
,d
,e
)
1434 | Ast.GeneratedRulename
(nm
,a
,b
,c
,d
,e
) ->
1435 Ast.GeneratedRulename
(check_name nm
,a
,b
,c
,d
,e
)
1436 | Ast.ScriptRulename
(nm
,s
,deps
) ->
1437 Ast.ScriptRulename
(check_name nm
,s
,deps
)
1438 | Ast.InitialScriptRulename
(_
,s
,deps
) ->
1439 Ast.InitialScriptRulename
(check_name None
,s
,deps
)
1440 | Ast.FinalScriptRulename
(_
,s
,deps
) ->
1441 Ast.FinalScriptRulename
(check_name None
,s
,deps
)
1443 Ast.CocciRulename
(Some
(mknm()),Ast.NoDep
,[],[],Ast.Undetermined
,false) in
1444 Data.in_rule_name
:= false;
1447 let parse_iso file
=
1448 let table = Common.full_charpos_to_pos file
in
1449 Common.with_open_infile file
(fun channel
->
1450 let lexbuf = Lexing.from_channel channel
in
1451 let get_tokens = tokens_all table file
false lexbuf in
1453 match get_tokens [PC.TArobArob
;PC.TArob
] with
1455 let parse_start start =
1456 let rev = List.rev start in
1457 let (arob
,_
) = List.hd
rev in
1458 (arob
= PC.TArob
,List.rev(List.tl
rev)) in
1459 let (starts_with_name
,start) = parse_start start in
1460 let rec loop starts_with_name
start =
1461 (!Data.init_rule
)();
1462 (* get metavariable declarations - have to be read before the
1464 let (rule_name
,_
,_
,_
,_
,_
) =
1465 match get_rule_name PC.iso_rule_name starts_with_name
get_tokens
1466 file
("iso file "^file
) with
1467 Ast.CocciRulename
(Some n
,a
,b
,c
,d
,e
) -> (n
,a
,b
,c
,d
,e
)
1468 | _
-> failwith
"Script rules cannot appear in isomorphism rules"
1470 Ast0.rule_name
:= rule_name
;
1472 match get_metavars PC.iso_meta_main
table file
lexbuf with
1473 (iso_metavars,[]) -> iso_metavars
1474 | _
-> failwith
"unexpected inheritance in iso" in
1478 [PC.TIsoStatement
;PC.TIsoExpression
;PC.TIsoArgExpression
;
1479 PC.TIsoTestExpression
; PC.TIsoToTestExpression
;
1480 PC.TIsoDeclaration
;PC.TIsoType
;PC.TIsoTopLevel
] in
1481 let next_start = List.hd
(List.rev tokens) in
1482 let dummy_info = ("",(-1,-1),(-1,-1)) in
1483 let tokens = drop_last [(PC.EOF
,dummy_info)] tokens in
1484 let tokens = prepare_tokens (start@tokens) in
1486 print_tokens "iso tokens" tokens;
1488 let entry = parse_one "iso main" PC.iso_main file
tokens in
1489 let entry = List.map
(List.map
Test_exps.process_anything
) entry in
1491 then (* The code below allows a header like Statement list,
1492 which is more than one word. We don't have that any more,
1493 but the code is left here in case it is put back. *)
1494 match get_tokens [PC.TArobArob
;PC.TArob
] with
1496 let (starts_with_name
,start) = parse_start start in
1497 (iso_metavars,entry,rule_name
) ::
1498 (loop starts_with_name
(next_start::start))
1499 | _
-> failwith
"isomorphism ends early"
1500 else [(iso_metavars,entry,rule_name
)] in
1501 loop starts_with_name
start
1502 | (false,_
) -> [] in
1505 let parse_iso_files existing_isos iso_files extra_path
=
1506 let get_names = List.map
(function (_
,_
,nm
) -> nm
) in
1507 let old_names = get_names existing_isos
in
1508 Data.in_iso
:= true;
1511 (function (prev
,names
) ->
1513 Lexer_cocci.init
();
1516 Common.Left
(fl
) -> Filename.concat extra_path fl
1517 | Common.Right
(fl
) -> Filename.concat
Config.path fl
in
1518 let current = parse_iso file in
1519 let new_names = get_names current in
1520 if List.exists
(function x -> List.mem
x names
) new_names
1521 then failwith
(Printf.sprintf
"repeated iso name found in %s" file);
1522 (current::prev
,new_names @ names
))
1523 ([],old_names) iso_files
in
1524 Data.in_iso
:= false;
1525 existing_isos
@(List.concat
(List.rev res))
1527 (* None = dependency not satisfied
1528 Some dep = dependency satisfied or unknown and dep has virts optimized
1530 let eval_depend dep virt
=
1533 Ast.Dep req
| Ast.EverDep req
->
1534 if List.mem req virt
1536 if List.mem req
!Flag.defined_virtual_rules
1540 | Ast.AntiDep antireq
| Ast.NeverDep antireq
->
1541 if List.mem antireq virt
1543 if not
(List.mem antireq
!Flag.defined_virtual_rules
)
1547 | Ast.AndDep
(d1
,d2
) ->
1548 (match (loop d1
, loop d2
) with
1549 (None
,_
) | (_
,None
) -> None
1550 | (Some
Ast.NoDep
,x) | (x,Some
Ast.NoDep
) -> x
1551 | (Some
x,Some y
) -> Some
(Ast.AndDep
(x,y
)))
1552 | Ast.OrDep
(d1
,d2
) ->
1553 (match (loop d1
, loop d2
) with
1555 | (Some
Ast.NoDep
,x) | (x,Some
Ast.NoDep
) -> Some
Ast.NoDep
1556 | (None
,x) | (x,None
) -> x
1557 | (Some
x,Some y
) -> Some
(Ast.OrDep
(x,y
)))
1558 | Ast.NoDep
| Ast.FailDep
-> Some dep
1564 let rec parse_loop file =
1565 Lexer_cocci.include_init
();
1566 let table = Common.full_charpos_to_pos
file in
1567 Common.with_open_infile
file (fun channel
->
1568 let lexbuf = Lexing.from_channel channel
in
1569 let get_tokens = tokens_all table file false lexbuf in
1570 Data.in_prolog
:= true;
1571 let initial_tokens = get_tokens [PC.TArobArob
;PC.TArob
] in
1572 Data.in_prolog
:= false;
1574 match initial_tokens with
1576 (match List.rev data
with
1577 ((PC.TArobArob
as x),_
)::_
| ((PC.TArob
as x),_
)::_
->
1578 let include_and_iso_files =
1579 parse_one "include and iso file names" PC.include_main
file data
in
1581 let (include_files
,iso_files
,virt
) =
1583 (function (include_files
,iso_files
,virt
) ->
1585 Data.Include s
-> (s
::include_files
,iso_files
,virt
)
1586 | Data.Iso s
-> (include_files
,s
::iso_files
,virt
)
1587 | Data.Virt l
-> (include_files
,iso_files
,l
@virt
))
1588 ([],[],[]) include_and_iso_files in
1590 List.iter
(function x -> Hashtbl.add
Lexer_cocci.rule_names
x ())
1593 let (extra_iso_files
, extra_rules
, extra_virt
, extra_metas
) =
1594 let rec loop = function
1596 | (a
,b
,c
,d
)::rest
->
1597 let (x,y
,z
,zz
) = loop rest
in
1598 (a
::x,b
::y
,c
::z
,d
@zz
) in
1599 loop (List.map
parse_loop include_files
) in
1601 let parse_cocci_rule ruletype old_metas
1602 (rule_name
, dependencies
, iso
, dropiso
, exists
, is_expression
) =
1603 let dropiso = !Flag_parsing_cocci.disabled_isos
@ dropiso in
1604 Ast0.rule_name
:= rule_name
;
1605 Data.inheritable_positions
:=
1606 rule_name
:: !Data.inheritable_positions
;
1608 (* get metavariable declarations *)
1609 let (metavars, inherited_metavars
) =
1610 get_metavars PC.meta_main
table file lexbuf in
1611 Hashtbl.add
Data.all_metadecls rule_name
metavars;
1612 Hashtbl.add
Lexer_cocci.rule_names rule_name
();
1613 Hashtbl.add
Lexer_cocci.all_metavariables rule_name
1615 (fun key
v rest
-> (key
,v)::rest
)
1616 Lexer_cocci.metavariables
[]);
1618 (* get transformation rules *)
1619 let (more
, tokens) = get_tokens [PC.TArobArob
; PC.TArob
] in
1620 let (minus_tokens
, _
) = split_token_stream tokens in
1621 let (_
, plus_tokens
) =
1622 split_token_stream (minus_to_nothing tokens) in
1625 print_tokens "minus tokens" minus_tokens;
1626 print_tokens "plus tokens" plus_tokens;
1629 let minus_tokens = consume_minus_positions minus_tokens in
1630 let minus_tokens = prepare_tokens minus_tokens in
1631 let plus_tokens = prepare_tokens plus_tokens in
1634 print_tokens "minus tokens" minus_tokens;
1635 print_tokens "plus tokens" plus_tokens;
1639 process_pragmas None
[]
1640 (fix (function x -> drop_double_dots (drop_empty_or x))
1641 (drop_when plus_tokens)) in
1643 print_tokens "plus tokens" plus_tokens;
1644 Printf.printf "before minus parse\n";
1648 then parse_one "minus" PC.minus_exp_main
file minus_tokens
1649 else parse_one "minus" PC.minus_main
file minus_tokens in
1651 Unparse_ast0.unparse minus_res;
1652 Printf.printf "before plus parse\n";
1655 (* put ignore_patch_or_match with * case, which is less
1657 if !Flag.sgrep_mode2
or !D.ignore_patch_or_match
1658 then (* not actually used for anything, except context_neg *)
1660 (Iso_pattern.rebuild_mcode None
).VT0.rebuilder_rec_top_level
1664 then parse_one "plus" PC.plus_exp_main
file plus_tokens
1665 else parse_one "plus" PC.plus_main
file plus_tokens in
1667 Printf.printf "after plus parse\n";
1670 (if not
!Flag.sgrep_mode2
&&
1671 (any_modif minus_res or any_modif plus_res) &&
1672 not
(dependencies
= Ast.FailDep
)
1673 then Data.inheritable_positions
:= []);
1675 Check_meta.check_meta rule_name old_metas inherited_metavars
1676 metavars minus_res plus_res;
1678 (more
, Ast0.CocciRule
((minus_res, metavars,
1679 (iso
, dropiso, dependencies
, rule_name
, exists
)),
1680 (plus_res, metavars), ruletype
), metavars, tokens) in
1682 let rec collect_script_tokens = function
1683 [(PC.EOF
,_
)] | [(PC.TArobArob
,_
)] | [(PC.TArob
,_
)] -> ""
1684 | (PC.TScriptData
(s
),_
)::xs
-> s^
(collect_script_tokens xs
)
1688 Printf.printf
"%s\n" (token2c x))
1690 failwith
"Malformed script rule" in
1692 let parse_script_rule name language old_metas deps
=
1693 let get_tokens = tokens_script_all table file false lexbuf in
1695 (* meta-variables *)
1699 get_script_metavars PC.script_meta_main
table file lexbuf) in
1700 let (metavars,script_metavars
) =
1702 (function (metavars,script_metavars
) ->
1704 (script_var
,Some
(parent
,var
)) ->
1705 ((script_var
,parent
,var
) :: metavars, script_metavars
)
1706 | ((Some script_var
,None
),None
) ->
1707 (metavars, (name,script_var
) :: script_metavars
)
1708 | _
-> failwith
"not possible")
1710 let metavars = List.rev metavars in
1711 let script_metavars = List.rev script_metavars in
1713 Hashtbl.add
Data.all_metadecls
name
1714 (List.map
(function x -> Ast.MetaIdDecl
(Ast.NONE
,x))
1716 Hashtbl.add
Lexer_cocci.rule_names
name ();
1717 (*TODOHashtbl.add Lexer_cocci.all_metavariables name script_metavars;*)
1720 let exists_in old_metas (py,(r,m)) =
1722 let test (rr,mr) x =
1723 let (ro,vo) = Ast.get_meta_name x in
1724 ro = rr && vo = mr in
1725 List.exists (test (r,m)) old_metas in
1729 let meta2c (r,n) = Printf.sprintf "%s.%s" r n in
1730 if not (exists_in old_metas x) then
1733 "Script references unknown meta-variable: %s"
1738 let (more
, tokens) = get_tokens [PC.TArobArob
; PC.TArob
] in
1739 let data = collect_script_tokens tokens in
1741 Ast0.ScriptRule
(name, language
, deps
, metavars,
1742 script_metavars, data),
1745 let parse_if_script_rule k
name language _ deps
=
1746 let get_tokens = tokens_script_all table file false lexbuf in
1749 let (more
, tokens) = get_tokens [PC.TArobArob
; PC.TArob
] in
1750 let data = collect_script_tokens tokens in
1751 (more
,k
(name, language
, deps
, data),[],tokens) in
1753 let parse_iscript_rule =
1754 parse_if_script_rule
1755 (function (name,language
,deps
,data) ->
1756 Ast0.InitialScriptRule
(name,language
,deps
,data)) in
1758 let parse_fscript_rule =
1759 parse_if_script_rule
1760 (function (name,language
,deps
,data) ->
1761 Ast0.FinalScriptRule
(name,language
,deps
,data)) in
1763 let do_parse_script_rule fn name l old_metas deps
=
1764 match eval_depend deps virt
with
1765 Some deps
-> fn name l old_metas deps
1766 | None
-> fn name l old_metas
Ast.FailDep
in
1768 let parse_rule old_metas starts_with_name
=
1770 get_rule_name PC.rule_name starts_with_name
get_tokens file
1773 Ast.CocciRulename
(Some s
, dep
, b
, c
, d
, e
) ->
1774 (match eval_depend dep virt
with
1776 parse_cocci_rule Ast.Normal old_metas
(s
,dep
,b
,c
,d
,e
)
1778 D.ignore_patch_or_match
:= true;
1780 parse_cocci_rule Ast.Normal old_metas
1781 (s
, Ast.FailDep
, b
, c
, d
, e
) in
1782 D.ignore_patch_or_match
:= false;
1784 | Ast.GeneratedRulename
(Some s
, dep
, b
, c
, d
, e
) ->
1785 (match eval_depend dep virt
with
1787 Data.in_generating
:= true;
1789 parse_cocci_rule Ast.Generated old_metas
1791 Data.in_generating
:= false;
1794 D.ignore_patch_or_match
:= true;
1795 Data.in_generating
:= true;
1797 parse_cocci_rule Ast.Generated old_metas
1798 (s
, Ast.FailDep
, b
, c
, d
, e
) in
1799 D.ignore_patch_or_match
:= false;
1800 Data.in_generating
:= false;
1802 | Ast.ScriptRulename
(Some s
,l
,deps
) ->
1803 do_parse_script_rule parse_script_rule s l old_metas deps
1804 | Ast.InitialScriptRulename
(Some s
,l
,deps
) ->
1805 do_parse_script_rule parse_iscript_rule s l old_metas deps
1806 | Ast.FinalScriptRulename
(Some s
,l
,deps
) ->
1807 do_parse_script_rule parse_fscript_rule s l old_metas deps
1808 | _
-> failwith
"Malformed rule name" in
1810 let rec loop old_metas starts_with_name
=
1811 (!Data.init_rule
)();
1813 let gen_starts_with_name more
tokens =
1815 (match List.hd
(List.rev tokens) with
1816 (PC.TArobArob
,_
) -> false
1817 | (PC.TArob
,_
) -> true
1818 | _
-> failwith
"unexpected token")
1821 let (more
, rule
, metavars, tokens) =
1822 parse_rule old_metas starts_with_name
in
1823 let all_metas = metavars @ old_metas
in
1826 let (all_rules
,all_metas) =
1827 loop all_metas (gen_starts_with_name more
tokens) in
1828 (rule
::all_rules
,all_metas)
1829 else ([rule
],all_metas) in
1831 let (all_rules
,all_metas) =
1832 loop extra_metas
(x = PC.TArob
) in
1835 (function prev
-> function cur -> Common.union_set
cur prev
)
1836 iso_files extra_iso_files
,
1837 (* included rules first *)
1838 List.fold_left
(function prev
-> function cur -> cur@prev
)
1839 all_rules
(List.rev extra_rules
),
1840 List.fold_left
(@) virt extra_virt
(*no dups allowed*),
1841 (all_metas : 'a list
))
1842 | _
-> failwith
"unexpected code before the first rule\n")
1843 | (false,[(PC.TArobArob
,_
)]) | (false,[(PC.TArob
,_
)]) ->
1844 ([],([] : Ast0.parsed_rule list
),[] (*virtual rules*), [] (*all metas*))
1845 | _
-> failwith
"unexpected code before the first rule\n" in
1849 (* parse to ast0 and then convert to ast *)
1850 let process file isofile verbose
=
1851 let extra_path = Filename.dirname
file in
1852 let (iso_files
, rules
, virt
, _metas
) = parse file in
1857 | Some iso_file
-> parse_iso_files [] [Common.Left iso_file
] "" in
1858 let global_isos = parse_iso_files std_isos iso_files
extra_path in
1859 let rules = Unitary_ast0.do_unitary
rules in
1863 Ast0.ScriptRule
(a
,b
,c
,d
,fv
,e
) ->
1864 [([],Ast.ScriptRule
(a
,b
,c
,d
,fv
,e
))]
1865 | Ast0.InitialScriptRule
(a
,b
,c
,d
) ->
1866 [([],Ast.InitialScriptRule
(a
,b
,c
,d
))]
1867 | Ast0.FinalScriptRule
(a
,b
,c
,d
) ->
1868 [([],Ast.FinalScriptRule
(a
,b
,c
,d
))]
1871 (iso
, dropiso, dependencies
, rule_name
, exists
)),
1872 (plus
, metavars),ruletype
) ->
1874 parse_iso_files global_isos
1875 (List.map
(function x -> Common.Left
x) iso
)
1878 (* check that dropped isos are actually available *)
1881 List.map
(function (_
,_
,nm
) -> nm
) chosen_isos in
1882 let local_iso_names = reserved_names @ iso_names in
1885 (function dropped
->
1886 not
(List.mem dropped
local_iso_names))
1889 ("invalid iso name " ^
bad_dropped ^
" in " ^ rule_name
)
1890 with Not_found
-> ());
1891 if List.mem
"all" dropiso
1893 if List.length
dropiso = 1
1895 else failwith
"disable all should only be by itself"
1896 else (* drop those isos *)
1898 (function (_
,_
,nm
) -> not
(List.mem nm
dropiso))
1900 List.iter
Iso_compile.process chosen_isos;
1902 match reserved_names with
1907 List.filter
(function x -> List.mem
x dropiso) others
)
1910 "bad list of reserved names - all must be at start" in
1911 let minus = Test_exps.process minus in
1912 let minus = Compute_lines.compute_lines
false minus in
1913 let plus = Compute_lines.compute_lines
false plus in
1915 (* only relevant to Flag.make_hrule *)
1916 (* doesn't handle multiple minirules properly, but since
1917 we don't really handle them in lots of other ways, it
1918 doesn't seem very important *)
1922 [match Ast0.unwrap p
with
1924 (match List.map
Ast0.unwrap
(Ast0.undots c
) with
1925 [Ast0.Exp e
] -> true | _
-> false)
1927 let minus = Arity.minus_arity
minus in
1928 let ((metavars,minus),function_prototypes
) =
1929 Function_prototypes.process
1930 rule_name
metavars dropped_isos minus plus ruletype
in
1931 let plus = Adjust_pragmas.process plus in
1932 (* warning! context_neg side-effects its arguments *)
1933 let (m
,p
) = List.split (Context_neg.context_neg
minus plus) in
1934 Type_infer.type_infer p
;
1935 (if not
!Flag.sgrep_mode2
1936 then Insert_plus.insert_plus m p
(chosen_isos = []));
1937 Type_infer.type_infer
minus;
1938 let (extra_meta
, minus) =
1939 match (chosen_isos,ruletype
) with
1940 (* separate case for [] because applying isos puts
1941 some restrictions on the -+ code *)
1942 ([],_
) | (_
,Ast.Generated
) -> ([],minus)
1943 | _
-> Iso_pattern.apply_isos
chosen_isos minus rule_name
in
1944 (* after iso, because iso can intro ... *)
1945 let minus = Adjacency.compute_adjacency
minus in
1946 let minus = Comm_assoc.comm_assoc
minus rule_name
dropiso in
1948 if !Flag.sgrep_mode2
then minus
1949 else Single_statement.single_statement
minus in
1950 let minus = Simple_assignments.simple_assignments
minus in
1952 Ast0toast.ast0toast rule_name dependencies
dropped_isos
1953 exists
minus is_exp ruletype
in
1955 match function_prototypes
with
1956 None
-> [(extra_meta
@ metavars, minus_ast)]
1957 | Some mv_fp
-> [(extra_meta
@ metavars, minus_ast); mv_fp
])
1958 (* Ast0.CocciRule ((minus, metavarsm, (iso, dropiso, dependencies, rule_name, exists)), (plus, metavars))*)
1960 let parsed = List.concat
parsed in
1961 let disjd = Disjdistr.disj
parsed in
1963 let (metavars,code
,fvs
,neg_pos
,ua
,pos
) = Free_vars.free_vars
disjd in
1964 if !Flag_parsing_cocci.show_SP
1965 then List.iter
Pretty_print_cocci.unparse code
;
1968 Common.profile_code
"get_glimpse_constants" (* for glimpse *)
1969 (fun () -> Get_constants2.get_constants code neg_pos
) in
1971 (metavars,code
,fvs
,neg_pos
,ua
,pos
,search_tokens)