2 * Copyright 2012, INRIA
3 * Julia Lawall, Gilles Muller
4 * Copyright 2010-2011, INRIA, University of Copenhagen
5 * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
6 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
7 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
8 * This file is part of Coccinelle.
10 * Coccinelle is free software: you can redistribute it and/or modify
11 * it under the terms of the GNU General Public License as published by
12 * the Free Software Foundation, according to version 2 of the License.
14 * Coccinelle is distributed in the hope that it will be useful,
15 * but WITHOUT ANY WARRANTY; without even the implied warranty of
16 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 * GNU General Public License for more details.
19 * You should have received a copy of the GNU General Public License
20 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
22 * The authors reserve the right to distribute this or future versions of
23 * Coccinelle under other licenses.
27 (* splits the entire file into minus and plus fragments, and parses each
28 separately (thus duplicating work for the parsing of the context elements) *)
31 module PC
= Parser_cocci_menhir
32 module V0
= Visitor_ast0
33 module VT0
= Visitor_ast0_types
34 module Ast
= Ast_cocci
35 module Ast0
= Ast0_cocci
37 exception Bad_virt
of string
39 let pr = Printf.sprintf
40 (*let pr2 s = prerr_string s; prerr_string "\n"; flush stderr*)
41 let pr2 s
= Printf.printf
"%s\n" s
43 (* for isomorphisms. all should be at the front!!! *)
45 ["all";"optional_storage";"optional_qualifier";"value_format";"comm_assoc"]
47 (* ----------------------------------------------------------------------- *)
50 let line_type (d
,_
,_
,_
,_
,_
,_
,_
) = d
53 match line_type tok
with
54 D.MINUS
| D.OPTMINUS
| D.UNIQUEMINUS
-> ":-"
57 | D.CONTEXT
| D.UNIQUE
| D.OPT
-> ""
61 PC.TMetavariable
-> "metavariable"
62 | PC.TIdentifier
-> "identifier"
64 | PC.TParameter
-> "parameter"
65 | PC.TConstant
-> "constant"
66 | PC.TExpression
-> "expression"
67 | PC.TIdExpression
-> "idexpression"
68 | PC.TInitialiser
-> "initialiser"
69 | PC.TSymbol
-> "symbol"
70 | PC.TDeclaration
-> "declaration"
71 | PC.TField
-> "field"
72 | PC.TStatement
-> "statement"
73 | PC.TPosition
-> "position"
75 | PC.TFunction
-> "function"
76 | PC.TLocal
-> "local"
78 | PC.TFresh
-> "fresh"
79 | PC.TCppConcatOp
-> "##"
81 | PC.TContext
-> "context"
82 | PC.TTypedef
-> "typedef"
83 | PC.TDeclarer
-> "declarer"
84 | PC.TIterator
-> "iterator"
86 | PC.TRuleName str
-> "rule_name-"^str
87 | PC.TUsing
-> "using"
88 | PC.TVirtual
-> "virtual"
89 | PC.TPathIsoFile str
-> "path_iso_file-"^str
90 | PC.TDisable
-> "disable"
91 | PC.TExtends
-> "extends"
92 | PC.TDepends
-> "depends"
95 | PC.TNever
-> "never"
96 | PC.TExists
-> "exists"
97 | PC.TForall
-> "forall"
98 | PC.TError
-> "error"
99 | PC.TWords
-> "words"
100 | PC.TGenerated
-> "generated"
102 | PC.TNothing
-> "nothing"
104 | PC.Tchar
(clt
) -> "char"^
(line_type2c clt
)
105 | PC.Tshort
(clt
) -> "short"^
(line_type2c clt
)
106 | PC.Tint
(clt
) -> "int"^
(line_type2c clt
)
107 | PC.Tdouble
(clt
) -> "double"^
(line_type2c clt
)
108 | PC.Tfloat
(clt
) -> "float"^
(line_type2c clt
)
109 | PC.Tlong
(clt
) -> "long"^
(line_type2c clt
)
110 | PC.Tvoid
(clt
) -> "void"^
(line_type2c clt
)
111 | PC.Tsize_t
(clt
) -> "size_t"^
(line_type2c clt
)
112 | PC.Tssize_t
(clt
) -> "ssize_t"^
(line_type2c clt
)
113 | PC.Tptrdiff_t
(clt
) -> "ptrdiff_t"^
(line_type2c clt
)
114 | PC.Tstruct
(clt
) -> "struct"^
(line_type2c clt
)
115 | PC.Tunion
(clt
) -> "union"^
(line_type2c clt
)
116 | PC.Tenum
(clt
) -> "enum"^
(line_type2c clt
)
117 | PC.Tunsigned
(clt
) -> "unsigned"^
(line_type2c clt
)
118 | PC.Tsigned
(clt
) -> "signed"^
(line_type2c clt
)
119 | PC.Tstatic
(clt
) -> "static"^
(line_type2c clt
)
120 | PC.Tinline
(clt
) -> "inline"^
(line_type2c clt
)
121 | PC.Ttypedef
(clt
) -> "typedef"^
(line_type2c clt
)
122 | PC.Tattr
(s
,clt
) -> s^
(line_type2c clt
)
123 | PC.Tauto
(clt
) -> "auto"^
(line_type2c clt
)
124 | PC.Tregister
(clt
) -> "register"^
(line_type2c clt
)
125 | PC.Textern
(clt
) -> "extern"^
(line_type2c clt
)
126 | PC.Tconst
(clt
) -> "const"^
(line_type2c clt
)
127 | PC.Tvolatile
(clt
) -> "volatile"^
(line_type2c clt
)
129 | PC.TPragma
(Ast.Noindent s
,_
) -> s
130 | PC.TPragma
(Ast.Indent s
,_
) -> s
131 | PC.TPragma
(Ast.Space s
,_
) -> s
132 | PC.TIncludeL
(s
,clt
) -> (pr "#include \"%s\"" s
)^
(line_type2c clt
)
133 | PC.TIncludeNL
(s
,clt
) -> (pr "#include <%s>" s
)^
(line_type2c clt
)
134 | PC.TUndef
(clt
,_
) -> "#undef"^
(line_type2c clt
)
135 | PC.TDefine
(clt
,_
) -> "#define"^
(line_type2c clt
)
136 | PC.TDefineParam
(clt
,_
,_
,_
) -> "#define_param"^
(line_type2c clt
)
137 | PC.TMinusFile
(s
,clt
) -> (pr "--- %s" s
)^
(line_type2c clt
)
138 | PC.TPlusFile
(s
,clt
) -> (pr "+++ %s" s
)^
(line_type2c clt
)
140 | PC.TInc
(clt
) -> "++"^
(line_type2c clt
)
141 | PC.TDec
(clt
) -> "--"^
(line_type2c clt
)
143 | PC.TIf
(clt
) -> "if"^
(line_type2c clt
)
144 | PC.TElse
(clt
) -> "else"^
(line_type2c clt
)
145 | PC.TWhile
(clt
) -> "while"^
(line_type2c clt
)
146 | PC.TFor
(clt
) -> "for"^
(line_type2c clt
)
147 | PC.TDo
(clt
) -> "do"^
(line_type2c clt
)
148 | PC.TSwitch
(clt
) -> "switch"^
(line_type2c clt
)
149 | PC.TCase
(clt
) -> "case"^
(line_type2c clt
)
150 | PC.TDefault
(clt
) -> "default"^
(line_type2c clt
)
151 | PC.TReturn
(clt
) -> "return"^
(line_type2c clt
)
152 | PC.TBreak
(clt
) -> "break"^
(line_type2c clt
)
153 | PC.TContinue
(clt
) -> "continue"^
(line_type2c clt
)
154 | PC.TGoto
(clt
) -> "goto"^
(line_type2c clt
)
155 | PC.TIdent
(s
,clt
) -> (pr "ident-%s" s
)^
(line_type2c clt
)
156 | PC.TTypeId
(s
,clt
) -> (pr "typename-%s" s
)^
(line_type2c clt
)
157 | PC.TDeclarerId
(s
,clt
) -> (pr "declarername-%s" s
)^
(line_type2c clt
)
158 | PC.TIteratorId
(s
,clt
) -> (pr "iteratorname-%s" s
)^
(line_type2c clt
)
159 | PC.TSymId
(s
,clt
) -> (pr "symbol-%s" s
)^
(line_type2c clt
)
160 | PC.TMetaDeclarer
(_
,_
,_
,clt
) -> "declmeta"^
(line_type2c clt
)
161 | PC.TMetaIterator
(_
,_
,_
,clt
) -> "itermeta"^
(line_type2c clt
)
163 | PC.TSizeof
(clt
) -> "sizeof"^
(line_type2c clt
)
165 | PC.TString
(x
,clt
) -> x^
(line_type2c clt
)
166 | PC.TChar
(x
,clt
) -> x^
(line_type2c clt
)
167 | PC.TFloat
(x
,clt
) -> x^
(line_type2c clt
)
168 | PC.TInt
(x
,clt
) -> x^
(line_type2c clt
)
170 | PC.TOrLog
(clt
) -> "||"^
(line_type2c clt
)
171 | PC.TAndLog
(clt
) -> "&&"^
(line_type2c clt
)
172 | PC.TOr
(clt
) -> "|"^
(line_type2c clt
)
173 | PC.TXor
(clt
) -> "^"^
(line_type2c clt
)
174 | PC.TAnd
(clt
) -> "&"^
(line_type2c clt
)
175 | PC.TEqEq
(clt
) -> "=="^
(line_type2c clt
)
176 | PC.TNotEq
(clt
) -> "!="^
(line_type2c clt
)
177 | PC.TSub
(clt
) -> "<="^
(line_type2c clt
)
178 | PC.TTildeEq
(clt
) -> "~="^
(line_type2c clt
)
179 | PC.TTildeExclEq
(clt
) -> "~!="^
(line_type2c clt
)
180 | PC.TLogOp
(op
,clt
) ->
186 | _
-> failwith
"not possible")
188 | PC.TShLOp
(op
,clt
) -> "<<"^
(line_type2c clt
)
189 | PC.TShROp
(op
,clt
) -> ">>"^
(line_type2c clt
)
190 | PC.TPlus
(clt
) -> "+"^
(line_type2c clt
)
191 | PC.TMinus
(clt
) -> "-"^
(line_type2c clt
)
192 | PC.TMul
(clt
) -> "*"^
(line_type2c clt
)
193 | PC.TDmOp
(op
,clt
) ->
197 | _
-> failwith
"not possible")
199 | PC.TTilde
(clt
) -> "~"^
(line_type2c clt
)
201 | PC.TMeta
(_
,_
,clt
) -> "meta"^
(line_type2c clt
)
202 | PC.TMetaParam
(_
,_
,clt
) -> "parammeta"^
(line_type2c clt
)
203 | PC.TMetaParamList
(_
,_
,_
,clt
) -> "paramlistmeta"^
(line_type2c clt
)
204 | PC.TMetaConst
(_
,_
,_
,_
,clt
) -> "constmeta"^
(line_type2c clt
)
205 | PC.TMetaErr
(_
,_
,_
,clt
) -> "errmeta"^
(line_type2c clt
)
206 | PC.TMetaExp
(_
,_
,_
,_
,clt
) -> "expmeta"^
(line_type2c clt
)
207 | PC.TMetaIdExp
(_
,_
,_
,_
,clt
) -> "idexpmeta"^
(line_type2c clt
)
208 | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
) -> "localidexpmeta"^
(line_type2c clt
)
209 | PC.TMetaExpList
(_
,_
,_
,clt
) -> "explistmeta"^
(line_type2c clt
)
210 | PC.TMetaId
(nm
,_
,_
,_
,clt
) -> "idmeta-"^
(Dumper.dump nm
)^
(line_type2c clt
)
211 | PC.TMetaType
(_
,_
,clt
) -> "typemeta"^
(line_type2c clt
)
212 | PC.TMetaInit
(_
,_
,clt
) -> "initmeta"^
(line_type2c clt
)
213 | PC.TMetaInitList
(_
,_
,_
,clt
) -> "initlistmeta"^
(line_type2c clt
)
214 | PC.TMetaDecl
(_
,_
,clt
) -> "declmeta"^
(line_type2c clt
)
215 | PC.TMetaField
(_
,_
,clt
) -> "fieldmeta"^
(line_type2c clt
)
216 | PC.TMetaFieldList
(_
,_
,_
,clt
) -> "fieldlistmeta"^
(line_type2c clt
)
217 | PC.TMetaStm
(_
,_
,clt
) -> "stmmeta"^
(line_type2c clt
)
218 | PC.TMetaStmList
(_
,_
,clt
) -> "stmlistmeta"^
(line_type2c clt
)
219 | PC.TMetaFunc
(_
,_
,_
,clt
) -> "funcmeta"^
(line_type2c clt
)
220 | PC.TMetaLocalFunc
(_
,_
,_
,clt
) -> "funcmeta"^
(line_type2c clt
)
221 | PC.TMetaPos
(_
,_
,_
,clt
) -> "posmeta"
223 | PC.TArobArob
-> "@@"
225 | PC.TPArob clt
-> "P@"
226 | PC.TScript
-> "script"
227 | PC.TInitialize
-> "initialize"
228 | PC.TFinalize
-> "finalize"
230 | PC.TWhen
(clt
) -> "WHEN"^
(line_type2c clt
)
231 | PC.TWhenTrue
(clt
) -> "WHEN TRUE"^
(line_type2c clt
)
232 | PC.TWhenFalse
(clt
) -> "WHEN FALSE"^
(line_type2c clt
)
233 | PC.TAny
(clt
) -> "ANY"^
(line_type2c clt
)
234 | PC.TStrict
(clt
) -> "STRICT"^
(line_type2c clt
)
235 | PC.TEllipsis
(clt
) -> "..."^
(line_type2c clt
)
237 | PC.TCircles(clt) -> "ooo"^(line_type2c clt)
238 | PC.TStars(clt) -> "***"^(line_type2c clt)
241 | PC.TOEllipsis
(clt
) -> "<..."^
(line_type2c clt
)
242 | PC.TCEllipsis
(clt
) -> "...>"^
(line_type2c clt
)
243 | PC.TPOEllipsis
(clt
) -> "<+..."^
(line_type2c clt
)
244 | PC.TPCEllipsis
(clt
) -> "...+>"^
(line_type2c clt
)
246 | PC.TOCircles(clt) -> "<ooo"^(line_type2c clt)
247 | PC.TCCircles(clt) -> "ooo>"^(line_type2c clt)
248 | PC.TOStars(clt) -> "<***"^(line_type2c clt)
249 | PC.TCStars(clt) -> "***>"^(line_type2c clt)
255 | PC.TWhy
(clt
) -> "?"^
(line_type2c clt
)
256 | PC.TDotDot
(clt
) -> ":"^
(line_type2c clt
)
257 | PC.TBang
(clt
) -> "!"^
(line_type2c clt
)
258 | PC.TOPar
(clt
) -> "("^
(line_type2c clt
)
259 | PC.TOPar0
(clt
) -> "("^
(line_type2c clt
)
260 | PC.TMid0
(clt
) -> "|"^
(line_type2c clt
)
261 | PC.TCPar
(clt
) -> ")"^
(line_type2c clt
)
262 | PC.TCPar0
(clt
) -> ")"^
(line_type2c clt
)
264 | PC.TOBrace
(clt
) -> "{"^
(line_type2c clt
)
265 | PC.TCBrace
(clt
) -> "}"^
(line_type2c clt
)
266 | PC.TOCro
(clt
) -> "["^
(line_type2c clt
)
267 | PC.TCCro
(clt
) -> "]"^
(line_type2c clt
)
268 | PC.TOInit
(clt
) -> "{"^
(line_type2c clt
)
270 | PC.TPtrOp
(clt
) -> "->"^
(line_type2c clt
)
272 | PC.TEq
(clt
) -> "="^
(line_type2c clt
)
273 | PC.TAssign
(_
,clt
) -> "=op"^
(line_type2c clt
)
274 | PC.TDot
(clt
) -> "."^
(line_type2c clt
)
275 | PC.TComma
(clt
) -> ","^
(line_type2c clt
)
276 | PC.TPtVirg
(clt
) -> ";"^
(line_type2c clt
)
279 | PC.TLineEnd
(clt
) -> "line end"
280 | PC.TInvalid
-> "invalid"
281 | PC.TFunDecl
(clt
) -> "fundecl"
284 | PC.TRightIso
-> "=>"
285 | PC.TIsoTopLevel
-> "TopLevel"
286 | PC.TIsoExpression
-> "Expression"
287 | PC.TIsoArgExpression
-> "ArgExpression"
288 | PC.TIsoTestExpression
-> "TestExpression"
289 | PC.TIsoToTestExpression
-> "ToTestExpression"
290 | PC.TIsoStatement
-> "Statement"
291 | PC.TIsoDeclaration
-> "Declaration"
292 | PC.TIsoType
-> "Type"
293 | PC.TUnderscore
-> "_"
294 | PC.TScriptData s
-> s
296 let print_tokens s tokens
=
297 Printf.printf
"%s\n" s
;
298 List.iter
(function x
-> Printf.printf
"|%s| " (token2c x
)) tokens
;
299 Printf.printf
"\n\n";
302 type plus
= PLUS
| NOTPLUS
| SKIP
304 let plus_attachable only_plus
(tok
,_
) =
306 PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
307 | PC.Tfloat
(clt
) | PC.Tlong
(clt
)
308 | PC.Tsize_t
(clt
) | PC.Tssize_t
(clt
) | PC.Tptrdiff_t
(clt
)
310 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
312 | PC.Tinline
(clt
) | PC.Ttypedef
(clt
) | PC.Tattr
(_
,clt
)
313 | PC.Tauto
(clt
) | PC.Tregister
(clt
)
314 | PC.Textern
(clt
) | PC.Tconst
(clt
) | PC.Tvolatile
(clt
)
316 | PC.TIncludeL
(_
,clt
) | PC.TIncludeNL
(_
,clt
) | PC.TUndef
(clt
,_
)
318 | PC.TDefineParam
(clt
,_
,_
,_
) | PC.TMinusFile
(_
,clt
) | PC.TPlusFile
(_
,clt
)
320 | PC.TInc
(clt
) | PC.TDec
(clt
)
322 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
323 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
) | PC.TReturn
(clt
)
324 | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
) | PC.TIdent
(_
,clt
)
325 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
329 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
)
331 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
332 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TTildeEq
(clt
)
334 | PC.TShLOp
(_
,clt
) | PC.TShROp
(_
,clt
)
335 | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
336 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
)
338 | PC.TMeta
(_
,_
,clt
) | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
339 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaErr
(_
,_
,_
,clt
)
340 | PC.TMetaExp
(_
,_
,_
,_
,clt
) | PC.TMetaIdExp
(_
,_
,_
,_
,clt
)
341 | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
342 | PC.TMetaExpList
(_
,_
,_
,clt
)
343 | PC.TMetaId
(_
,_
,_
,_
,clt
)
344 | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
) | PC.TMetaInitList
(_
,_
,_
,clt
)
345 | PC.TMetaStm
(_
,_
,clt
)
346 | PC.TMetaStmList
(_
,_
,clt
)
347 | PC.TMetaDecl
(_
,_
,clt
) | PC.TMetaField
(_
,_
,clt
)
348 | PC.TMetaFieldList
(_
,_
,_
,clt
)
349 | PC.TMetaFunc
(_
,_
,_
,clt
) | PC.TMetaLocalFunc
(_
,_
,_
,clt
)
351 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
)
352 | PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TEllipsis
(clt
)
353 (* | PC.TCircles(clt) | PC.TStars(clt) *)
354 | PC.TOEllipsis
(clt
) | PC.TCEllipsis
(clt
)
355 | PC.TPOEllipsis
(clt
) | PC.TPCEllipsis
(clt
) (* | PC.TOCircles(clt)
356 | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *)
358 | PC.TWhy
(clt
) | PC.TDotDot
(clt
) | PC.TBang
(clt
) | PC.TOPar
(clt
)
361 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOCro
(clt
) | PC.TCCro
(clt
)
366 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
368 if List.mem
(line_type clt
) [D.PLUS
;D.PLUSPLUS
]
370 else if only_plus
then NOTPLUS
371 else if line_type clt
= D.CONTEXT
then PLUS
else NOTPLUS
373 | PC.TOPar0
(clt
) | PC.TMid0
(clt
) | PC.TCPar0
(clt
) -> NOTPLUS
374 | PC.TMetaPos
(nm
,_
,_
,_
) -> NOTPLUS
375 | PC.TSub
(clt
) -> NOTPLUS
379 let get_clt (tok
,_
) =
381 PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
382 | PC.Tfloat
(clt
) | PC.Tlong
(clt
) | PC.Tvoid
(clt
)
383 | PC.Tsize_t
(clt
) | PC.Tssize_t
(clt
) | PC.Tptrdiff_t
(clt
)
385 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
387 | PC.Tinline
(clt
) | PC.Tattr
(_
,clt
) | PC.Tauto
(clt
) | PC.Tregister
(clt
)
388 | PC.Textern
(clt
) | PC.Tconst
(clt
) | PC.Tvolatile
(clt
)
390 | PC.TIncludeL
(_
,clt
) | PC.TIncludeNL
(_
,clt
) | PC.TUndef
(clt
,_
)
392 | PC.TDefineParam
(clt
,_
,_
,_
) | PC.TMinusFile
(_
,clt
) | PC.TPlusFile
(_
,clt
)
394 | PC.TInc
(clt
) | PC.TDec
(clt
)
396 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
397 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
) | PC.TReturn
(clt
)
398 | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
) | PC.TIdent
(_
,clt
)
399 | PC.TTypeId
(_
,clt
) | PC.TSymId
(_
,clt
)
400 | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
404 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
)
406 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
407 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TTildeEq
(clt
)
408 | PC.TSub
(clt
) | PC.TLogOp
(_
,clt
)
409 | PC.TShLOp
(_
,clt
) | PC.TShROp
(_
,clt
)
410 | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
411 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
)
413 | PC.TMeta
(_
,_
,clt
) | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
414 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaErr
(_
,_
,_
,clt
)
415 | PC.TMetaExp
(_
,_
,_
,_
,clt
) | PC.TMetaIdExp
(_
,_
,_
,_
,clt
)
416 | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
417 | PC.TMetaExpList
(_
,_
,_
,clt
)
418 | PC.TMetaId
(_
,_
,_
,_
,clt
)
419 | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
) | PC.TMetaInitList
(_
,_
,_
,clt
)
420 | PC.TMetaStm
(_
,_
,clt
)
421 | PC.TMetaStmList
(_
,_
,clt
)
422 | PC.TMetaDecl
(_
,_
,clt
) | PC.TMetaField
(_
,_
,clt
)
423 | PC.TMetaFieldList
(_
,_
,_
,clt
)
424 | PC.TMetaFunc
(_
,_
,_
,clt
) | PC.TMetaLocalFunc
(_
,_
,_
,clt
)
425 | PC.TMetaPos
(_
,_
,_
,clt
)
426 | PC.TMetaDeclarer
(_
,_
,_
,clt
) | PC.TMetaIterator
(_
,_
,_
,clt
)
428 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
) |
429 PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TEllipsis
(clt
)
430 (* | PC.TCircles(clt) | PC.TStars(clt) *)
432 | PC.TWhy
(clt
) | PC.TDotDot
(clt
) | PC.TBang
(clt
) | PC.TOPar
(clt
)
435 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOCro
(clt
) | PC.TCCro
(clt
)
440 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
441 | PC.TPArob
(clt
) | PC.TPtVirg
(clt
)
443 | PC.TOPar0
(clt
) | PC.TMid0
(clt
) | PC.TCPar0
(clt
)
444 | PC.TOEllipsis
(clt
) | PC.TCEllipsis
(clt
)
445 | PC.TPOEllipsis
(clt
) | PC.TPCEllipsis
(clt
) (* | PC.TOCircles(clt)
446 | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *) -> clt
448 | _
-> failwith
"no clt"
450 let update_clt (tok
,x
) clt
=
452 PC.Tchar
(_
) -> (PC.Tchar
(clt
),x
)
453 | PC.Tshort
(_
) -> (PC.Tshort
(clt
),x
)
454 | PC.Tint
(_
) -> (PC.Tint
(clt
),x
)
455 | PC.Tdouble
(_
) -> (PC.Tdouble
(clt
),x
)
456 | PC.Tfloat
(_
) -> (PC.Tfloat
(clt
),x
)
457 | PC.Tlong
(_
) -> (PC.Tlong
(clt
),x
)
458 | PC.Tvoid
(_
) -> (PC.Tvoid
(clt
),x
)
459 | PC.Tsize_t
(_
) -> (PC.Tsize_t
(clt
),x
)
460 | PC.Tssize_t
(_
) -> (PC.Tssize_t
(clt
),x
)
461 | PC.Tptrdiff_t
(_
) -> (PC.Tptrdiff_t
(clt
),x
)
462 | PC.Tstruct
(_
) -> (PC.Tstruct
(clt
),x
)
463 | PC.Tunion
(_
) -> (PC.Tunion
(clt
),x
)
464 | PC.Tenum
(_
) -> (PC.Tenum
(clt
),x
)
465 | PC.Tunsigned
(_
) -> (PC.Tunsigned
(clt
),x
)
466 | PC.Tsigned
(_
) -> (PC.Tsigned
(clt
),x
)
467 | PC.Tstatic
(_
) -> (PC.Tstatic
(clt
),x
)
468 | PC.Tinline
(_
) -> (PC.Tinline
(clt
),x
)
469 | PC.Ttypedef
(_
) -> (PC.Ttypedef
(clt
),x
)
470 | PC.Tattr
(s
,_
) -> (PC.Tattr
(s
,clt
),x
)
471 | PC.Tauto
(_
) -> (PC.Tauto
(clt
),x
)
472 | PC.Tregister
(_
) -> (PC.Tregister
(clt
),x
)
473 | PC.Textern
(_
) -> (PC.Textern
(clt
),x
)
474 | PC.Tconst
(_
) -> (PC.Tconst
(clt
),x
)
475 | PC.Tvolatile
(_
) -> (PC.Tvolatile
(clt
),x
)
477 | PC.TIncludeL
(s
,_
) -> (PC.TIncludeL
(s
,clt
),x
)
478 | PC.TIncludeNL
(s
,_
) -> (PC.TIncludeNL
(s
,clt
),x
)
479 | PC.TUndef
(_
,a
) -> (PC.TUndef
(clt
,a
),x
)
480 | PC.TDefine
(_
,a
) -> (PC.TDefine
(clt
,a
),x
)
481 | PC.TDefineParam
(_
,a
,b
,c
) -> (PC.TDefineParam
(clt
,a
,b
,c
),x
)
482 | PC.TMinusFile
(s
,_
) -> (PC.TMinusFile
(s
,clt
),x
)
483 | PC.TPlusFile
(s
,_
) -> (PC.TPlusFile
(s
,clt
),x
)
485 | PC.TInc
(_
) -> (PC.TInc
(clt
),x
)
486 | PC.TDec
(_
) -> (PC.TDec
(clt
),x
)
488 | PC.TIf
(_
) -> (PC.TIf
(clt
),x
)
489 | PC.TElse
(_
) -> (PC.TElse
(clt
),x
)
490 | PC.TWhile
(_
) -> (PC.TWhile
(clt
),x
)
491 | PC.TFor
(_
) -> (PC.TFor
(clt
),x
)
492 | PC.TDo
(_
) -> (PC.TDo
(clt
),x
)
493 | PC.TSwitch
(_
) -> (PC.TSwitch
(clt
),x
)
494 | PC.TCase
(_
) -> (PC.TCase
(clt
),x
)
495 | PC.TDefault
(_
) -> (PC.TDefault
(clt
),x
)
496 | PC.TReturn
(_
) -> (PC.TReturn
(clt
),x
)
497 | PC.TBreak
(_
) -> (PC.TBreak
(clt
),x
)
498 | PC.TContinue
(_
) -> (PC.TContinue
(clt
),x
)
499 | PC.TGoto
(_
) -> (PC.TGoto
(clt
),x
)
500 | PC.TIdent
(s
,_
) -> (PC.TIdent
(s
,clt
),x
)
501 | PC.TTypeId
(s
,_
) -> (PC.TTypeId
(s
,clt
),x
)
502 | PC.TDeclarerId
(s
,_
) -> (PC.TDeclarerId
(s
,clt
),x
)
503 | PC.TIteratorId
(s
,_
) -> (PC.TIteratorId
(s
,clt
),x
)
504 | PC.TSymId
(a
,_
) -> (PC.TSymId
(a
,clt
),x
)
506 | PC.TSizeof
(_
) -> (PC.TSizeof
(clt
),x
)
508 | PC.TString
(s
,_
) -> (PC.TString
(s
,clt
),x
)
509 | PC.TChar
(s
,_
) -> (PC.TChar
(s
,clt
),x
)
510 | PC.TFloat
(s
,_
) -> (PC.TFloat
(s
,clt
),x
)
511 | PC.TInt
(s
,_
) -> (PC.TInt
(s
,clt
),x
)
513 | PC.TOrLog
(_
) -> (PC.TOrLog
(clt
),x
)
514 | PC.TAndLog
(_
) -> (PC.TAndLog
(clt
),x
)
515 | PC.TOr
(_
) -> (PC.TOr
(clt
),x
)
516 | PC.TXor
(_
) -> (PC.TXor
(clt
),x
)
517 | PC.TAnd
(_
) -> (PC.TAnd
(clt
),x
)
518 | PC.TEqEq
(_
) -> (PC.TEqEq
(clt
),x
)
519 | PC.TNotEq
(_
) -> (PC.TNotEq
(clt
),x
)
520 | PC.TTildeEq
(_
) -> (PC.TTildeEq
(clt
),x
)
521 | PC.TSub
(_
) -> (PC.TSub
(clt
),x
)
522 | PC.TLogOp
(op
,_
) -> (PC.TLogOp
(op
,clt
),x
)
523 | PC.TShLOp
(op
,_
) -> (PC.TShLOp
(op
,clt
),x
)
524 | PC.TShROp
(op
,_
) -> (PC.TShROp
(op
,clt
),x
)
525 | PC.TPlus
(_
) -> (PC.TPlus
(clt
),x
)
526 | PC.TMinus
(_
) -> (PC.TMinus
(clt
),x
)
527 | PC.TMul
(_
) -> (PC.TMul
(clt
),x
)
528 | PC.TDmOp
(op
,_
) -> (PC.TDmOp
(op
,clt
),x
)
529 | PC.TTilde
(_
) -> (PC.TTilde
(clt
),x
)
531 | PC.TMeta
(a
,b
,_
) -> (PC.TMeta
(a
,b
,clt
),x
)
532 | PC.TMetaParam
(a
,b
,_
) -> (PC.TMetaParam
(a
,b
,clt
),x
)
533 | PC.TMetaParamList
(a
,b
,c
,_
) -> (PC.TMetaParamList
(a
,b
,c
,clt
),x
)
534 | PC.TMetaConst
(a
,b
,c
,d
,_
) -> (PC.TMetaConst
(a
,b
,c
,d
,clt
),x
)
535 | PC.TMetaErr
(a
,b
,c
,_
) -> (PC.TMetaErr
(a
,b
,c
,clt
),x
)
536 | PC.TMetaExp
(a
,b
,c
,d
,_
) -> (PC.TMetaExp
(a
,b
,c
,d
,clt
),x
)
537 | PC.TMetaIdExp
(a
,b
,c
,d
,_
) -> (PC.TMetaIdExp
(a
,b
,c
,d
,clt
),x
)
538 | PC.TMetaLocalIdExp
(a
,b
,c
,d
,_
) -> (PC.TMetaLocalIdExp
(a
,b
,c
,d
,clt
),x
)
539 | PC.TMetaExpList
(a
,b
,c
,_
) -> (PC.TMetaExpList
(a
,b
,c
,clt
),x
)
540 | PC.TMetaId
(a
,b
,c
,d
,_
) -> (PC.TMetaId
(a
,b
,c
,d
,clt
),x
)
541 | PC.TMetaType
(a
,b
,_
) -> (PC.TMetaType
(a
,b
,clt
),x
)
542 | PC.TMetaInit
(a
,b
,_
) -> (PC.TMetaInit
(a
,b
,clt
),x
)
543 | PC.TMetaInitList
(a
,b
,c
,_
) -> (PC.TMetaInitList
(a
,b
,c
,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.TMetaFieldList
(a
,b
,c
,_
) -> (PC.TMetaFieldList
(a
,b
,c
,clt
),x
)
547 | PC.TMetaStm
(a
,b
,_
) -> (PC.TMetaStm
(a
,b
,clt
),x
)
548 | PC.TMetaStmList
(a
,b
,_
) -> (PC.TMetaStmList
(a
,b
,clt
),x
)
549 | PC.TMetaFunc
(a
,b
,c
,_
) -> (PC.TMetaFunc
(a
,b
,c
,clt
),x
)
550 | PC.TMetaLocalFunc
(a
,b
,c
,_
) -> (PC.TMetaLocalFunc
(a
,b
,c
,clt
),x
)
552 | PC.TMetaDeclarer
(a
,b
,c
,_
) -> (PC.TMetaDeclarer
(a
,b
,c
,clt
),x
)
553 | PC.TMetaIterator
(a
,b
,c
,_
) -> (PC.TMetaIterator
(a
,b
,c
,clt
),x
)
555 | PC.TWhen
(_
) -> (PC.TWhen
(clt
),x
)
556 | PC.TWhenTrue
(_
) -> (PC.TWhenTrue
(clt
),x
)
557 | PC.TWhenFalse
(_
) -> (PC.TWhenFalse
(clt
),x
)
558 | PC.TAny
(_
) -> (PC.TAny
(clt
),x
)
559 | PC.TStrict
(_
) -> (PC.TStrict
(clt
),x
)
560 | PC.TEllipsis
(_
) -> (PC.TEllipsis
(clt
),x
)
562 | PC.TCircles(_) -> (PC.TCircles(clt),x)
563 | PC.TStars(_) -> (PC.TStars(clt),x)
566 | PC.TOEllipsis
(_
) -> (PC.TOEllipsis
(clt
),x
)
567 | PC.TCEllipsis
(_
) -> (PC.TCEllipsis
(clt
),x
)
568 | PC.TPOEllipsis
(_
) -> (PC.TPOEllipsis
(clt
),x
)
569 | PC.TPCEllipsis
(_
) -> (PC.TPCEllipsis
(clt
),x
)
571 | PC.TOCircles(_) -> (PC.TOCircles(clt),x)
572 | PC.TCCircles(_) -> (PC.TCCircles(clt),x)
573 | PC.TOStars(_) -> (PC.TOStars(clt),x)
574 | PC.TCStars(_) -> (PC.TCStars(clt),x)
577 | PC.TWhy
(_
) -> (PC.TWhy
(clt
),x
)
578 | PC.TDotDot
(_
) -> (PC.TDotDot
(clt
),x
)
579 | PC.TBang
(_
) -> (PC.TBang
(clt
),x
)
580 | PC.TOPar
(_
) -> (PC.TOPar
(clt
),x
)
581 | PC.TOPar0
(_
) -> (PC.TOPar0
(clt
),x
)
582 | PC.TMid0
(_
) -> (PC.TMid0
(clt
),x
)
583 | PC.TCPar
(_
) -> (PC.TCPar
(clt
),x
)
584 | PC.TCPar0
(_
) -> (PC.TCPar0
(clt
),x
)
586 | PC.TOBrace
(_
) -> (PC.TOBrace
(clt
),x
)
587 | PC.TCBrace
(_
) -> (PC.TCBrace
(clt
),x
)
588 | PC.TOCro
(_
) -> (PC.TOCro
(clt
),x
)
589 | PC.TCCro
(_
) -> (PC.TCCro
(clt
),x
)
590 | PC.TOInit
(_
) -> (PC.TOInit
(clt
),x
)
592 | PC.TPtrOp
(_
) -> (PC.TPtrOp
(clt
),x
)
594 | PC.TEq
(_
) -> (PC.TEq
(clt
),x
)
595 | PC.TAssign
(s
,_
) -> (PC.TAssign
(s
,clt
),x
)
596 | PC.TDot
(_
) -> (PC.TDot
(clt
),x
)
597 | PC.TComma
(_
) -> (PC.TComma
(clt
),x
)
598 | PC.TPArob
(_
) -> (PC.TPArob
(clt
),x
)
599 | PC.TPtVirg
(_
) -> (PC.TPtVirg
(clt
),x
)
601 | PC.TLineEnd
(_
) -> (PC.TLineEnd
(clt
),x
)
602 | PC.TFunDecl
(_
) -> (PC.TFunDecl
(clt
),x
)
604 | _
-> failwith
"no clt"
607 (* ----------------------------------------------------------------------- *)
609 let make_name prefix ln
= Printf.sprintf
"%s starting on line %d" prefix ln
611 (* ----------------------------------------------------------------------- *)
614 let wrap_lexbuf_info lexbuf
=
615 (Lexing.lexeme lexbuf
, Lexing.lexeme_start lexbuf
)
617 let tokens_all_full token table file get_ats lexbuf end_markers
:
618 (bool * ((PC.token
* (string * (int * int) * (int * int))) list
)) =
621 let result = token lexbuf
in
622 let info = (Lexing.lexeme lexbuf
,
623 (table
.(Lexing.lexeme_start lexbuf
)),
624 (Lexing.lexeme_start lexbuf
, Lexing.lexeme_end lexbuf
)) in
628 then failwith
"unexpected end of file in a metavariable declaration"
629 else (false,[(result,info)])
630 else if List.mem
result end_markers
631 then (true,[(result,info)])
633 let (more
,rest
) = aux() in
634 (more
,(result, info)::rest
)
637 e
-> pr2 (Common.error_message file
(wrap_lexbuf_info lexbuf
) ); raise e
639 let tokens_all table file get_ats lexbuf end_markers
:
640 (bool * ((PC.token
* (string * (int * int) * (int * int))) list
)) =
641 tokens_all_full Lexer_cocci.token table file get_ats lexbuf end_markers
643 let tokens_script_all table file get_ats lexbuf end_markers
:
644 (bool * ((PC.token
* (string * (int * int) * (int * int))) list
)) =
645 tokens_all_full Lexer_script.token table file get_ats lexbuf end_markers
647 (* ----------------------------------------------------------------------- *)
648 (* Split tokens into minus and plus fragments *)
651 let (d
,_
,_
,_
,_
,_
,_
,_
) = clt
in
653 D.MINUS
| D.OPTMINUS
| D.UNIQUEMINUS
-> ([t
],[])
654 | D.PLUS
| D.PLUSPLUS
-> ([],[t
])
655 | D.CONTEXT
| D.UNIQUE
| D.OPT
-> ([t
],[t
])
657 let split_token ((tok
,_
) as t
) =
659 PC.TMetavariable
| PC.TIdentifier
660 | PC.TConstant
| PC.TExpression
| PC.TIdExpression
661 | PC.TDeclaration
| PC.TField
662 | PC.TStatement
| PC.TPosition
| PC.TPosAny
| PC.TInitialiser
| PC.TSymbol
663 | PC.TFunction
| PC.TTypedef
| PC.TDeclarer
| PC.TIterator
| PC.TName
664 | PC.TType
| PC.TParameter
| PC.TLocal
| PC.Tlist
| PC.TFresh
665 | PC.TCppConcatOp
| PC.TPure
666 | PC.TContext
| PC.TRuleName
(_
) | PC.TUsing
| PC.TVirtual
| PC.TDisable
667 | PC.TExtends
| PC.TPathIsoFile
(_
)
668 | PC.TDepends
| PC.TOn
| PC.TEver
| PC.TNever
| PC.TExists
| PC.TForall
669 | PC.TError
| PC.TWords
| PC.TGenerated
| PC.TNothing
-> ([t
],[t
])
671 | PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
672 | PC.Tfloat
(clt
) | PC.Tlong
(clt
) | PC.Tvoid
(clt
)
673 | PC.Tsize_t
(clt
) | PC.Tssize_t
(clt
) | PC.Tptrdiff_t
(clt
)
675 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
676 | PC.Tstatic
(clt
) | PC.Tauto
(clt
) | PC.Tregister
(clt
) | PC.Textern
(clt
)
677 | PC.Tinline
(clt
) | PC.Ttypedef
(clt
) | PC.Tattr
(_
,clt
)
678 | PC.Tconst
(clt
) | PC.Tvolatile
(clt
) -> split t clt
680 | PC.TPragma
(s
,_
) -> ([],[t
]) (* only allowed in + *)
681 | PC.TPlusFile
(s
,clt
) | PC.TMinusFile
(s
,clt
)
682 | PC.TIncludeL
(s
,clt
) | PC.TIncludeNL
(s
,clt
) ->
684 | PC.TUndef
(clt
,_
) | PC.TDefine
(clt
,_
) | PC.TDefineParam
(clt
,_
,_
,_
) ->
687 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
688 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
)
690 | PC.TReturn
(clt
) | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
)
692 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
694 | PC.TMeta
(_
,_
,clt
) | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaExp
(_
,_
,_
,_
,clt
)
695 | PC.TMetaIdExp
(_
,_
,_
,_
,clt
) | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
696 | PC.TMetaExpList
(_
,_
,_
,clt
)
697 | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
698 | PC.TMetaId
(_
,_
,_
,_
,clt
) | PC.TMetaType
(_
,_
,clt
)
699 | PC.TMetaInit
(_
,_
,clt
) | PC.TMetaInitList
(_
,_
,_
,clt
)
700 | PC.TMetaDecl
(_
,_
,clt
) | PC.TMetaField
(_
,_
,clt
)
701 | PC.TMetaFieldList
(_
,_
,_
,clt
)
702 | PC.TMetaStm
(_
,_
,clt
) | PC.TMetaStmList
(_
,_
,clt
) | PC.TMetaErr
(_
,_
,_
,clt
)
703 | PC.TMetaFunc
(_
,_
,_
,clt
) | PC.TMetaLocalFunc
(_
,_
,_
,clt
)
704 | PC.TMetaDeclarer
(_
,_
,_
,clt
) | PC.TMetaIterator
(_
,_
,_
,clt
) -> split t clt
705 | PC.TMPtVirg
| PC.TArob
| PC.TArobArob
| PC.TScript
706 | PC.TInitialize
| PC.TFinalize
-> ([t
],[t
])
707 | PC.TPArob clt
| PC.TMetaPos
(_
,_
,_
,clt
) -> split t clt
710 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
)
711 | PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TLineEnd
(clt
)
712 | PC.TEllipsis
(clt
) (* | PC.TCircles(clt) | PC.TStars(clt) *)
713 | PC.TOEllipsis
(clt
) | PC.TCEllipsis
(clt
)
714 | PC.TPOEllipsis
(clt
) | PC.TPCEllipsis
(clt
) -> split t clt
717 | PC.TOCircles(_) | PC.TCCircles(_) (* clt must be context *)
718 | PC.TOStars
(_
) | PC.TCStars
(_
) (* clt must be context *)
721 | PC.TBang0
| PC.TPlus0
| PC.TWhy0
->
724 | PC.TWhy
(clt
) | PC.TDotDot
(clt
)
725 | PC.TBang
(clt
) | PC.TOPar
(clt
) | PC.TOPar0
(clt
)
726 | PC.TMid0
(clt
) | PC.TCPar
(clt
) | PC.TCPar0
(clt
) -> split t clt
728 | PC.TInc
(clt
) | PC.TDec
(clt
) -> split t clt
730 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
) ->
733 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
734 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TTildeEq
(clt
)
735 | PC.TTildeExclEq
(clt
) | PC.TSub
(clt
) | PC.TLogOp
(_
,clt
)
736 | PC.TShLOp
(_
,clt
) | PC.TShROp
(_
,clt
)
737 | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
738 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
) -> split t clt
740 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOInit
(clt
) -> split t clt
741 | PC.TOCro
(clt
) | PC.TCCro
(clt
) -> split t clt
743 | PC.TPtrOp
(clt
) -> split t clt
745 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
746 | PC.TPtVirg
(clt
) -> split t clt
748 | PC.EOF
| PC.TInvalid
| PC.TUnderscore
-> ([t
],[t
])
750 | PC.TIso
| PC.TRightIso
751 | PC.TIsoExpression
| PC.TIsoStatement
| PC.TIsoDeclaration
| PC.TIsoType
752 | PC.TIsoTopLevel
| PC.TIsoArgExpression
| PC.TIsoTestExpression
753 | PC.TIsoToTestExpression
->
754 failwith
"unexpected tokens"
755 | PC.TScriptData s
-> ([t
],[t
])
757 let split_token_stream tokens
=
758 let rec loop = function
761 let (minus
,plus
) = split_token token
in
762 let (minus_stream
,plus_stream
) = loop tokens
in
763 (minus
@minus_stream
,plus
@plus_stream
) in
766 (* ----------------------------------------------------------------------- *)
767 (* Find function names *)
768 (* This addresses a shift-reduce problem in the parser, allowing us to
769 distinguish a function declaration from a function call even if the latter
770 has no return type. Undoubtedly, this is not very nice, but it doesn't
771 seem very convenient to refactor the grammar to get around the problem. *)
775 let rec find_function_names l
=
776 let is_ident = function
777 (PC.TIdent
(_
,clt
),info)
778 | (PC.TMeta
(_
,_
,clt
),info)
779 | (PC.TMetaId
(_
,_
,_
,_
,clt
),info)
780 | (PC.TMetaFunc
(_
,_
,_
,clt
),info)
781 | (PC.TMetaLocalFunc
(_
,_
,_
,clt
),info) -> true
783 let is_mid = function
784 (PC.TMid0
(_
),info) -> true
786 let is_par = function
787 (PC.TOPar0
(_
),info) -> true
789 let rec split acc
= function
790 [] | [_
] -> raise Irrelevant
791 | ((PC.TCPar
(_
),_
) as t1
) :: ((PC.TOBrace
(_
),_
) as t2
) :: rest
->
792 (List.rev
(t1
::acc
),(t2
::rest
))
793 | x
::xs
-> split (x
::acc
) xs
in
794 let rec balanced_name level
= function
795 [] -> raise Irrelevant
796 | (PC.TCPar0
(_
),_
)::rest
->
797 let level = level - 1 in
800 else balanced_name level rest
801 | (PC.TOPar0
(_
),_
)::rest
->
802 let level = level + 1 in
803 balanced_name level rest
804 | (PC.TArobArob
,_
)::_
| (PC.TArob
,_
)::_
| (PC.EOF
,_
)::_
->
806 | t
::rest
when is_ident t
&& level = 0 -> rest
807 | t
::rest
when is_ident t
or is_mid t
-> balanced_name level rest
808 | _
-> raise Irrelevant
in
809 let rec balanced_args level = function
810 [] -> raise Irrelevant
811 | (PC.TCPar
(_
),_
)::rest
->
812 let level = level - 1 in
815 else balanced_args level rest
816 | (PC.TOPar
(_
),_
)::rest
->
817 let level = level + 1 in
818 balanced_args level rest
819 | (PC.TArobArob
,_
)::_
| (PC.TArob
,_
)::_
| (PC.EOF
,_
)::_
->
821 | t
::rest
-> balanced_args level rest
in
822 let rec loop = function
825 if is_par t
or is_mid t
or is_ident t
829 let (bef
,aft
) = split [] (t
::rest
) in
830 let rest = balanced_name 0 bef
in
832 (PC.TOPar
(_
),_
)::_
->
833 (match balanced_args 0 rest with
835 let (_
,info) as h
= List.hd bef
in
836 let clt = get_clt h
in
837 (((PC.TFunDecl
(clt),info) :: bef
), aft
)
838 | _
-> raise Irrelevant
)
839 | _
-> raise Irrelevant
)
840 with Irrelevant
-> ([t
],rest) in
842 else t
:: (loop rest) in
845 (* ----------------------------------------------------------------------- *)
846 (* an attribute is an identifier that preceeds another identifier and
849 let rec detect_attr l
=
851 (PC.TIdent
(_
,_
),_
) | (PC.TMetaId
(_
,_
,_
,_
,_
),_
) | (PC.TMetaFunc
(_
,_
,_
,_
),_
)
852 | (PC.TMetaLocalFunc
(_
,_
,_
,_
),_
) -> true
854 let rec loop = function
857 | ((PC.TIdent
(nm
,clt),info) as t1
)::id
::rest when is_id id
->
858 if String.length nm
> 2 && String.sub nm
0 2 = "__"
859 then (PC.Tattr
(nm
,clt),info)::(loop (id
::rest))
860 else t1
::(loop (id
::rest))
861 | x
::xs
-> x
::(loop xs
) in
864 (* ----------------------------------------------------------------------- *)
865 (* Look for variable declarations where the name is a typedef name.
866 We assume that C code does not contain a multiplication as a top-level
869 (* bug: once a type, always a type, even if the same name is later intended
870 to be used as a real identifier *)
871 let detect_types in_meta_decls l
=
872 let is_delim infn
= function
873 (PC.TOEllipsis
(_
),_
) (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *)
874 | (PC.TPOEllipsis
(_
),_
) (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *)
875 | (PC.TEllipsis
(_
),_
) (* | (PC.TCircles(_),_) | (PC.TStars(_),_) *)
876 | (PC.TPtVirg
(_
),_
) | (PC.TOBrace
(_
),_
) | (PC.TOInit
(_
),_
)
878 | (PC.TPure
,_
) | (PC.TContext
,_
)
879 | (PC.Tstatic
(_
),_
) | (PC.Textern
(_
),_
)
880 | (PC.Tinline
(_
),_
) | (PC.Ttypedef
(_
),_
) | (PC.Tattr
(_
),_
) -> true
881 | (PC.TComma
(_
),_
) when infn
> 0 or in_meta_decls
-> true
882 | (PC.TDotDot
(_
),_
) when in_meta_decls
-> true
884 let is_choices_delim = function
885 (PC.TOBrace
(_
),_
) | (PC.TComma
(_
),_
) -> true | _
-> false in
887 (PC.TIdent
(_
,_
),_
) | (PC.TMetaId
(_
,_
,_
,_
,_
),_
) | (PC.TMetaFunc
(_
,_
,_
,_
),_
)
888 | (PC.TMetaLocalFunc
(_
,_
,_
,_
),_
) -> true
889 | (PC.TMetaParam
(_
,_
,_
),_
)
890 | (PC.TMetaParamList
(_
,_
,_
,_
),_
)
891 | (PC.TMetaConst
(_
,_
,_
,_
,_
),_
)
892 | (PC.TMetaErr
(_
,_
,_
,_
),_
)
893 | (PC.TMetaExp
(_
,_
,_
,_
,_
),_
)
894 | (PC.TMetaIdExp
(_
,_
,_
,_
,_
),_
)
895 | (PC.TMetaLocalIdExp
(_
,_
,_
,_
,_
),_
)
896 | (PC.TMetaExpList
(_
,_
,_
,_
),_
)
897 | (PC.TMetaType
(_
,_
,_
),_
)
898 | (PC.TMetaInit
(_
,_
,_
),_
)
899 | (PC.TMetaInitList
(_
,_
,_
,_
),_
)
900 | (PC.TMetaDecl
(_
,_
,_
),_
)
901 | (PC.TMetaField
(_
,_
,_
),_
)
902 | (PC.TMetaFieldList
(_
,_
,_
,_
),_
)
903 | (PC.TMetaStm
(_
,_
,_
),_
)
904 | (PC.TMetaStmList
(_
,_
,_
),_
)
905 | (PC.TMetaPos
(_
,_
,_
,_
),_
) -> in_meta_decls
907 let redo_id ident
clt v
=
908 !Data.add_type_name ident
;
909 (PC.TTypeId
(ident
,clt),v
) in
910 let rec loop start infn type_names
= function
911 (* infn: 0 means not in a function header
912 > 0 means in a function header, after infn - 1 unmatched open parens*)
914 | ((PC.TOBrace
(clt),v
)::_
) as all
when in_meta_decls
->
915 collect_choices type_names all
(* never a function header *)
916 | delim
::(PC.TIdent
(ident
,clt),v
)::((PC.TMul
(_
),_
) as x
)::rest
917 when is_delim infn delim
->
918 let newid = redo_id ident
clt v
in
919 delim
::newid::x
::(loop false infn
(ident
::type_names
) rest)
920 | delim
::(PC.TIdent
(ident
,clt),v
)::id
::rest
921 when is_delim infn delim
&& is_id id
->
922 let newid = redo_id ident
clt v
in
923 delim
::newid::id
::(loop false infn
(ident
::type_names
) rest)
924 | ((PC.TFunDecl
(_
),_
) as fn
)::rest ->
925 fn
::(loop false 1 type_names
rest)
926 | ((PC.TOPar
(_
),_
) as lp
)::rest when infn
> 0 ->
927 lp
::(loop false (infn
+ 1) type_names
rest)
928 | ((PC.TCPar
(_
),_
) as rp
)::rest when infn
> 0 ->
930 then rp
::(loop false 0 type_names
rest) (* 0 means not in fn header *)
931 else rp
::(loop false (infn
- 1) type_names
rest)
932 | (PC.TIdent
(ident
,clt),v
)::((PC.TMul
(_
),_
) as x
)::rest when start
->
933 let newid = redo_id ident
clt v
in
934 newid::x
::(loop false infn
(ident
::type_names
) rest)
935 | (PC.TIdent
(ident
,clt),v
)::id
::rest when start
&& is_id id
->
936 let newid = redo_id ident
clt v
in
937 newid::id
::(loop false infn
(ident
::type_names
) rest)
938 | (PC.TIdent
(ident
,clt),v
)::rest when List.mem ident type_names
->
939 (PC.TTypeId
(ident
,clt),v
)::(loop false infn type_names
rest)
940 | ((PC.TIdent
(ident
,clt),v
) as x
)::rest ->
941 x
::(loop false infn type_names
rest)
942 | x
::rest -> x
::(loop false infn type_names
rest)
943 and collect_choices type_names
= function
944 [] -> [] (* should happen, but let the parser detect that *)
945 | (PC.TCBrace
(clt),v
)::rest ->
946 (PC.TCBrace
(clt),v
)::(loop false 0 type_names
rest)
947 | delim
::(PC.TIdent
(ident
,clt),v
)::rest
948 when is_choices_delim delim
->
949 let newid = redo_id ident
clt v
in
950 delim
::newid::(collect_choices
(ident
::type_names
) rest)
951 | x
::rest -> x
::(collect_choices type_names
rest) in
955 (* ----------------------------------------------------------------------- *)
956 (* Insert TLineEnd tokens at the end of a line that contains a WHEN.
957 WHEN is restricted to a single line, to avoid ambiguity in eg:
961 let token2line (tok
,_
) =
963 PC.Tchar
(clt) | PC.Tshort
(clt) | PC.Tint
(clt) | PC.Tdouble
(clt)
964 | PC.Tfloat
(clt) | PC.Tlong
(clt) | PC.Tvoid
(clt)
965 | PC.Tsize_t
(clt) | PC.Tssize_t
(clt) | PC.Tptrdiff_t
(clt)
967 | PC.Tunion
(clt) | PC.Tenum
(clt) | PC.Tunsigned
(clt) | PC.Tsigned
(clt)
968 | PC.Tstatic
(clt) | PC.Tauto
(clt) | PC.Tregister
(clt) | PC.Textern
(clt)
969 | PC.Tinline
(clt) | PC.Ttypedef
(clt) | PC.Tattr
(_
,clt) | PC.Tconst
(clt)
972 | PC.TInc
(clt) | PC.TDec
(clt)
974 | PC.TIf
(clt) | PC.TElse
(clt) | PC.TWhile
(clt) | PC.TFor
(clt) | PC.TDo
(clt)
975 | PC.TSwitch
(clt) | PC.TCase
(clt) | PC.TDefault
(clt) | PC.TSizeof
(clt)
976 | PC.TReturn
(clt) | PC.TBreak
(clt) | PC.TContinue
(clt) | PC.TGoto
(clt)
978 | PC.TTypeId
(_
,clt) | PC.TDeclarerId
(_
,clt) | PC.TIteratorId
(_
,clt)
979 | PC.TMetaDeclarer
(_
,_
,_
,clt) | PC.TMetaIterator
(_
,_
,_
,clt)
983 | PC.TString
(_
,clt) | PC.TChar
(_
,clt) | PC.TFloat
(_
,clt) | PC.TInt
(_
,clt)
985 | PC.TOrLog
(clt) | PC.TAndLog
(clt) | PC.TOr
(clt) | PC.TXor
(clt)
986 | PC.TAnd
(clt) | PC.TEqEq
(clt) | PC.TNotEq
(clt) | PC.TLogOp
(_
,clt)
987 | PC.TShLOp
(_
,clt) | PC.TShROp
(_
,clt)
988 | PC.TPlus
(clt) | PC.TMinus
(clt) | PC.TMul
(clt)
989 | PC.TDmOp
(_
,clt) | PC.TTilde
(clt)
991 | PC.TMeta
(_
,_
,clt) | PC.TMetaParam
(_
,_
,clt) | PC.TMetaParamList
(_
,_
,_
,clt)
992 | PC.TMetaConst
(_
,_
,_
,_
,clt) | PC.TMetaExp
(_
,_
,_
,_
,clt)
993 | PC.TMetaIdExp
(_
,_
,_
,_
,clt) | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt)
994 | PC.TMetaExpList
(_
,_
,_
,clt)
995 | PC.TMetaId
(_
,_
,_
,_
,clt) | PC.TMetaType
(_
,_
,clt)
996 | PC.TMetaInit
(_
,_
,clt) | PC.TMetaInitList
(_
,_
,_
,clt)
997 | PC.TMetaDecl
(_
,_
,clt) | PC.TMetaField
(_
,_
,clt)
998 | PC.TMetaFieldList
(_
,_
,_
,clt)
999 | PC.TMetaStm
(_
,_
,clt) | PC.TMetaStmList
(_
,_
,clt) | PC.TMetaFunc
(_
,_
,_
,clt)
1000 | PC.TMetaLocalFunc
(_
,_
,_
,clt) | PC.TMetaPos
(_
,_
,_
,clt)
1003 | PC.TWhen
(clt) | PC.TWhenTrue
(clt) | PC.TWhenFalse
(clt)
1004 | PC.TAny
(clt) | PC.TStrict
(clt) | PC.TEllipsis
(clt)
1005 (* | PC.TCircles(clt) | PC.TStars(clt) *)
1007 | PC.TOEllipsis
(clt) | PC.TCEllipsis
(clt)
1008 | PC.TPOEllipsis
(clt) | PC.TPCEllipsis
(clt) (*| PC.TOCircles(clt)
1009 | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *)
1011 | PC.TWhy
(clt) | PC.TDotDot
(clt) | PC.TBang
(clt) | PC.TOPar
(clt)
1012 | PC.TOPar0
(clt) | PC.TMid0
(clt) | PC.TCPar
(clt)
1015 | PC.TOBrace
(clt) | PC.TCBrace
(clt) | PC.TOCro
(clt) | PC.TCCro
(clt)
1020 | PC.TUndef
(clt,_
) | PC.TDefine
(clt,_
) | PC.TDefineParam
(clt,_
,_
,_
)
1021 | PC.TIncludeL
(_
,clt) | PC.TIncludeNL
(_
,clt)
1023 | PC.TEq
(clt) | PC.TAssign
(_
,clt) | PC.TDot
(clt) | PC.TComma
(clt)
1024 | PC.TPArob
(clt) | PC.TPtVirg
(clt) ->
1025 let (_
,line
,_
,_
,_
,_
,_
,_
) = clt in Some line
1029 let rec insert_line_end = function
1031 | (((PC.TWhen
(clt),q
) as x
)::xs
) ->
1032 x
::(find_line_end
true (token2line x
) clt q xs
)
1033 | (((PC.TUndef
(clt,_
),q
) as x
)::xs
)
1034 | (((PC.TDefine
(clt,_
),q
) as x
)::xs
)
1035 | (((PC.TDefineParam
(clt,_
,_
,_
),q
) as x
)::xs
) ->
1036 x
::(find_line_end
false (token2line x
) clt q xs
)
1037 | x
::xs
-> x
::(insert_line_end xs
)
1039 and find_line_end inwhen line
clt q
= function
1040 (* don't know what 2nd component should be so just use the info of
1041 the When. Also inherit - of when, if any *)
1042 [] -> [(PC.TLineEnd
(clt),q
)]
1043 | ((PC.TIdent
("strict",clt),a
) as x
)::xs
when token2line x
= line
->
1044 (PC.TStrict
(clt),a
) :: (find_line_end inwhen line
clt q xs
)
1045 | ((PC.TIdent
("STRICT",clt),a
) as x
)::xs
when token2line x
= line
->
1046 (PC.TStrict
(clt),a
) :: (find_line_end inwhen line
clt q xs
)
1047 | ((PC.TIdent
("any",clt),a
) as x
)::xs
when token2line x
= line
->
1048 (PC.TAny
(clt),a
) :: (find_line_end inwhen line
clt q xs
)
1049 | ((PC.TIdent
("ANY",clt),a
) as x
)::xs
when token2line x
= line
->
1050 (PC.TAny
(clt),a
) :: (find_line_end inwhen line
clt q xs
)
1051 | ((PC.TIdent
("forall",clt),a
) as x
)::xs
when token2line x
= line
->
1052 (PC.TForall
,a
) :: (find_line_end inwhen line
clt q xs
)
1053 | ((PC.TIdent
("exists",clt),a
) as x
)::xs
when token2line x
= line
->
1054 (PC.TExists
,a
) :: (find_line_end inwhen line
clt q xs
)
1055 | ((PC.TComma
(clt),a
) as x
)::xs
when token2line x
= line
->
1056 (PC.TComma
(clt),a
) :: (find_line_end inwhen line
clt q xs
)
1057 | ((PC.TPArob
(clt),a
) as x
)::xs
when token2line x
= line
->
1058 (PC.TPArob
(clt),a
) :: (find_line_end inwhen line
clt q xs
)
1059 | x
::xs
when token2line x
= line
-> x
:: (find_line_end inwhen line
clt q xs
)
1060 | xs
-> (PC.TLineEnd
(clt),q
)::(insert_line_end xs
)
1062 let rec translate_when_true_false = function
1064 | (PC.TWhen
(clt),q
)::((PC.TNotEq
(_
),_
) as x
)::(PC.TIdent
("true",_
),_
)::xs
->
1065 (PC.TWhenTrue
(clt),q
)::x
::(translate_when_true_false xs
)
1066 | (PC.TWhen
(clt),q
)::((PC.TNotEq
(_
),_
) as x
)::(PC.TIdent
("false",_
),_
)::xs
->
1067 (PC.TWhenFalse
(clt),q
)::x
::(translate_when_true_false xs
)
1068 | x
::xs
-> x
:: (translate_when_true_false xs
)
1070 (* ----------------------------------------------------------------------- *)
1072 (* In a nest, if the nest is -, all of the nested code must also be -.
1073 All are converted to context, because the next takes care of the -. *)
1074 let check_nests tokens
=
1076 let (line_type,a
,b
,c
,d
,e
,f
,g
) = get_clt t
in
1077 List.mem
line_type [D.MINUS
;D.OPTMINUS
;D.UNIQUEMINUS
] in
1079 let clt = try Some
(get_clt t
) with Failure _
-> None
in
1081 Some
(line_type,a
,b
,c
,d
,e
,f
,g
) ->
1082 (match line_type with
1083 D.MINUS
-> update_clt t
(D.CONTEXT
,a
,b
,c
,d
,e
,f
,g
)
1084 | D.OPTMINUS
-> update_clt t
(D.OPT
,a
,b
,c
,d
,e
,f
,g
)
1085 | D.UNIQUEMINUS
-> update_clt t
(D.UNIQUE
,a
,b
,c
,d
,e
,f
,g
)
1086 | _
-> failwith
"minus token expected")
1088 let rec outside = function
1090 | ((PC.TPOEllipsis
(clt),q
) as t
)::r
when is_minus t
-> t
:: inside
0 r
1091 | t
::r
-> t
:: outside r
1092 and inside stack
= function
1093 [] -> failwith
"missing nest end"
1094 | ((PC.TPCEllipsis
(clt),q
) as t
)::r
->
1096 :: (if stack
= 0 then outside r
else inside
(stack
- 1) r
)
1097 | ((PC.TPOEllipsis
(clt),q
) as t
)::r
->
1098 (drop_minus t
) :: (inside
(stack
+ 1) r
)
1099 | t
:: r
-> (drop_minus t
) :: (inside stack r
) in
1102 let check_parentheses tokens
=
1103 let clt2line (_
,line
,_
,_
,_
,_
,_
,_
) = line
in
1104 let rec loop seen_open
= function
1106 | (PC.TOPar
(clt),q
) :: rest
1107 | (PC.TDefineParam
(clt,_
,_
,_
),q
) :: rest ->
1108 loop (Common.Left
(clt2line clt) :: seen_open
) rest
1109 | (PC.TOPar0
(clt),q
) :: rest ->
1110 loop (Common.Right
(clt2line clt) :: seen_open
) rest
1111 | (PC.TCPar
(clt),q
) :: rest ->
1112 (match seen_open
with
1116 "unexpected close parenthesis in line %d\n" (clt2line clt))
1117 | Common.Left _
:: seen_open
-> loop seen_open
rest
1118 | Common.Right open_line
:: _
->
1121 "disjunction parenthesis in line %d column 0 matched to normal parenthesis on line %d\n" open_line
(clt2line clt)))
1122 | (PC.TCPar0
(clt),q
) :: rest ->
1123 (match seen_open
with
1127 "unexpected close parenthesis in line %d\n" (clt2line clt))
1128 | Common.Right _
:: seen_open
-> loop seen_open
rest
1129 | Common.Left open_line
:: _
->
1132 "normal parenthesis in line %d matched to disjunction parenthesis on line %d column 0\n" open_line
(clt2line clt)))
1133 | x
::rest -> loop seen_open
rest in
1136 (* ----------------------------------------------------------------------- *)
1137 (* top level initializers: a sequence of braces followed by a dot *)
1139 let find_top_init tokens
=
1141 (PC.TOBrace
(clt),q
) :: rest ->
1142 let rec dot_start acc
= function
1143 ((PC.TOBrace
(_
),_
) as x
) :: rest ->
1144 dot_start (x
::acc
) rest
1145 | ((PC.TDot
(_
),_
) :: rest) as x
->
1146 Some
((PC.TOInit
(clt),q
) :: (List.rev acc
) @ x
)
1148 let rec comma_end acc
= function
1149 ((PC.TCBrace
(_
),_
) as x
) :: rest ->
1150 comma_end (x
::acc
) rest
1151 | ((PC.TComma
(_
),_
) :: rest) as x
->
1152 Some
((PC.TOInit
(clt),q
) :: (List.rev x
) @ acc
)
1154 (match dot_start [] rest with
1157 (match List.rev
rest with
1158 (* not super sure what this does, but EOF, @, and @@ should be
1159 the same, markind the end of a rule *)
1160 ((PC.EOF
,_
) as x
)::rest | ((PC.TArob
,_
) as x
)::rest
1161 | ((PC.TArobArob
,_
) as x
)::rest ->
1162 (match comma_end [x
] rest with
1166 failwith
"unexpected empty token list"))
1169 (* ----------------------------------------------------------------------- *)
1170 (* Integrate pragmas into some adjacent token. + tokens are preferred. Dots
1173 let rec collect_all_pragmas collected
= function
1174 (PC.TPragma
(s
,(_
,line
,logical_line
,offset
,col
,_
,_
,pos
)),_
)::rest ->
1176 { Ast0.line_start
= line
; Ast0.line_end
= line
;
1177 Ast0.logical_start
= logical_line
; Ast0.logical_end
= logical_line
;
1178 Ast0.column
= col
; Ast0.offset
= offset
; } in
1179 collect_all_pragmas ((s
,i)::collected
) rest
1180 | l
-> (List.rev collected
,l
)
1182 let rec collect_pass = function
1185 match plus_attachable false x
with
1187 let (pass
,rest) = collect_pass xs
in
1191 let plus_attach strict
= function
1193 | Some x
-> plus_attachable strict x
1195 let add_bef = function Some x
-> [x
] | None
-> []
1197 (*skips should be things like line end
1198 skips is things before pragmas that can't be attached to, pass is things
1199 after. pass is used immediately. skips accumulates.
1200 When stuff is added before some + code, the logical line of the + code
1201 becomes that of the pragma. context_neg relies on things that are adjacent
1202 having sequential logical lines. Not sure that this is good enough,
1203 as it might result in later gaps in the logical lines... *)
1204 let rec process_pragmas bef skips
= function
1205 [] -> add_bef bef
@ List.rev skips
1206 | ((PC.TPragma
(s
,i),_
)::_
) as l
->
1207 let (pragmas
,rest) = collect_all_pragmas [] l
in
1208 let (pass
,rest0
) = collect_pass rest in
1209 let (_
,_
,prag_lline
,_
,_
,_
,_
,_
) = i in
1211 match rest0
with [] -> (None
,[]) | next
::rest -> (Some next
,rest) in
1212 (match (bef
,plus_attach true bef
,next
,plus_attach true next
) with
1213 (Some bef
,PLUS
,_
,_
) ->
1214 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt bef
in
1215 (update_clt bef
(a
,b
,c
,d
,e
,strbef
,pragmas
,pos
))::List.rev skips
@
1216 pass
@process_pragmas None
[] rest0
1217 | (_
,_
,Some next
,PLUS
) ->
1218 let (a
,b
,lline
,d
,e
,strbef
,straft
,pos
) = get_clt next
in
1219 (add_bef bef
) @ List.rev skips
@ pass
@
1221 (Some
(update_clt next
(a
,b
,prag_lline
,d
,e
,pragmas
,straft
,pos
)))
1224 (match (bef
,plus_attach false bef
,next
,plus_attach false next
) with
1225 (Some bef
,PLUS
,_
,_
) ->
1226 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt bef
in
1227 (update_clt bef
(a
,b
,c
,d
,e
,strbef
,pragmas
,pos
))::List.rev skips
@
1228 pass
@process_pragmas None
[] rest0
1229 | (_
,_
,Some next
,PLUS
) ->
1230 let (a
,b
,lline
,d
,e
,strbef
,straft
,pos
) = get_clt next
in
1231 (add_bef bef
) @ List.rev skips
@ pass
@
1234 (update_clt next
(a
,b
,prag_lline
,d
,e
,pragmas
,straft
,pos
)))
1236 | _
-> failwith
"nothing to attach pragma to"))
1238 (match plus_attachable false x
with
1239 SKIP
-> process_pragmas bef
(x
::skips
) xs
1240 | _
-> (add_bef bef
) @ List.rev skips
@ (process_pragmas (Some x
) [] xs
))
1242 (* ----------------------------------------------------------------------- *)
1243 (* Drop ... ... . This is only allowed in + code, and arises when there is
1244 some - code between the ... *)
1245 (* drop whens as well - they serve no purpose in + code and they cause
1246 problems for drop_double_dots *)
1248 let rec drop_when = function
1250 | (PC.TWhen
(clt),info)::xs
->
1251 let rec loop = function
1253 | (PC.TLineEnd
(_
),info)::xs
-> drop_when xs
1254 | x
::xs
-> loop xs
in
1256 | x
::xs
-> x
::drop_when xs
1258 (* instead of dropping the double dots, we put TNothing in between them.
1259 these vanish after the parser, but keeping all the ...s in the + code makes
1260 it easier to align the + and - code in context_neg and in preparation for the
1261 isomorphisms. This shouldn't matter because the context code of the +
1262 slice is mostly ignored anyway *)
1263 let minus_to_nothing l
=
1264 (* for cases like | <..., which may or may not arise from removing minus
1265 code, depending on whether <... is a statement or expression *)
1268 let (d
,_
,_
,_
,_
,_
,_
,_
) = get_clt tok
in
1270 D.MINUS
| D.OPTMINUS
| D.UNIQUEMINUS
-> true
1271 | D.PLUS
| D.PLUSPLUS
-> false
1272 | D.CONTEXT
| D.UNIQUE
| D.OPT
-> false)
1274 let rec minus_loop = function
1276 | (d
::ds
) as l
-> if is_minus d
then minus_loop ds
else l
in
1277 let rec loop = function
1279 | ((PC.TMid0
(clt),i) as x
)::t1
::ts
when is_minus t1
->
1280 (match minus_loop ts
with
1281 ((PC.TOEllipsis
(_
),_
)::_
) | ((PC.TPOEllipsis
(_
),_
)::_
)
1282 | ((PC.TEllipsis
(_
),_
)::_
) as l
-> x
::(PC.TNothing
,i)::(loop l
)
1284 | t
::ts
-> t
::(loop ts
) in
1287 let rec drop_double_dots l
=
1288 let start = function
1289 (PC.TOEllipsis
(_
),_
) | (PC.TPOEllipsis
(_
),_
)
1290 (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *) ->
1293 let middle = function
1294 (PC.TEllipsis
(_
),_
) (* | (PC.TCircles(_),_) | (PC.TStars(_),_) *) -> true
1296 let whenline = function
1297 (PC.TLineEnd
(_
),_
) -> true
1298 (*| (PC.TMid0(_),_) -> true*)
1300 let final = function
1301 (PC.TCEllipsis
(_
),_
) | (PC.TPCEllipsis
(_
),_
)
1302 (* | (PC.TCCircles(_),_) | (PC.TCStars(_),_) *) ->
1305 let any_before x
= start x
or middle x
or final x
or whenline x
in
1306 let any_after x
= start x
or middle x
or final x
in
1307 let rec loop ((_
,i) as prev
) = function
1309 | x
::rest when any_before prev
&& any_after x
->
1310 (PC.TNothing
,i)::x
::(loop x
rest)
1311 | ((PC.TComma
(_
),_
) as c
)::x
::rest when any_before prev
&& any_after x
->
1312 c
::(PC.TNothing
,i)::x
::(loop x
rest)
1313 | x
::rest -> x
:: (loop x
rest) in
1316 | (x
::xs
) -> x
:: loop x xs
1318 (* ignore uncomparable pcre regular expressions *)
1319 let strip_for_fix l
=
1322 (PC.TMetaId
(nm
,_
,seed
,pure
,clt),info) ->
1323 (PC.TMetaId
(nm
,Ast.IdNoConstraint
,seed
,pure
,clt),info)
1324 | (PC.TMetaFunc
(nm
,_
,pure
,clt),info) ->
1325 (PC.TMetaFunc
(nm
,Ast.IdNoConstraint
,pure
,clt),info)
1326 | (PC.TMetaLocalFunc
(nm
,_
,pure
,clt),info) ->
1327 (PC.TMetaLocalFunc
(nm
,Ast.IdNoConstraint
,pure
,clt),info)
1328 | (PC.TMetaErr
(nm
,_
,pure
,clt),info) ->
1329 (PC.TMetaErr
(nm
,Ast0.NoConstraint
,pure
,clt),info)
1330 | (PC.TMetaExp
(nm
,_
,pure
,ty
,clt),info) ->
1331 (PC.TMetaExp
(nm
,Ast0.NoConstraint
,pure
,ty
,clt),info)
1332 | (PC.TMetaIdExp
(nm
,_
,pure
,ty
,clt),info) ->
1333 (PC.TMetaIdExp
(nm
,Ast0.NoConstraint
,pure
,ty
,clt),info)
1334 | (PC.TMetaLocalIdExp
(nm
,_
,pure
,ty
,clt),info) ->
1335 (PC.TMetaLocalIdExp
(nm
,Ast0.NoConstraint
,pure
,ty
,clt),info)
1336 | (PC.TMetaConst
(nm
,_
,pure
,ty
,clt),info) ->
1337 (PC.TMetaConst
(nm
,Ast0.NoConstraint
,pure
,ty
,clt),info)
1342 let rec loop f l stripped_l
=
1344 let stripped_cur = strip_for_fix cur in
1345 if stripped_l
= stripped_cur then l
else loop f
cur stripped_cur in
1346 loop f l
(strip_for_fix l
)
1348 (* ( | ... | ) also causes parsing problems *)
1352 let rec drop_empty_thing starter
middle ender
= function
1354 | hd
::rest when starter hd
->
1355 let rec loop = function
1356 x
::rest when middle x
-> loop rest
1357 | x
::rest when ender x
-> rest
1358 | _
-> raise Not_empty
in
1359 (match try Some
(loop rest) with Not_empty
-> None
with
1360 Some x
-> drop_empty_thing starter
middle ender x
1361 | None
-> hd
:: drop_empty_thing starter
middle ender
rest)
1362 | x
::rest -> x
:: drop_empty_thing starter
middle ender
rest
1366 (function (PC.TOPar0
(_
),_
) -> true | _
-> false)
1367 (function (PC.TMid0
(_
),_
) -> true | _
-> false)
1368 (function (PC.TCPar0
(_
),_
) -> true | _
-> false)
1370 let drop_empty_nest = drop_empty_thing
1372 (* ----------------------------------------------------------------------- *)
1375 let get_s_starts (_
, (s
,_
,(starts
, ends
))) =
1376 Printf.printf
"%d %d\n" starts ends
; (s
, starts
)
1379 let v = List.hd
!l
in
1384 PC.reinit (function _
-> PC.TArobArob
(* a handy token *))
1385 (Lexing.from_function
1386 (function buf
-> function n
-> raise
Common.Impossible
))
1388 let parse_one str parsefn file toks
=
1389 let all_tokens = ref toks
in
1390 let cur_tok = ref (List.hd
!all_tokens) in
1392 let lexer_function _
=
1393 let (v, info) = pop2 all_tokens in
1394 cur_tok := (v, info);
1398 Lexing.from_function
1399 (function buf
-> function n
-> raise
Common.Impossible
)
1404 try parsefn
lexer_function lexbuf_fake
1406 Lexer_cocci.Lexical s
->
1408 (Printf.sprintf
"%s: lexical error: %s\n =%s\n" str s
1409 (Common.error_message file
(get_s_starts !cur_tok) ))
1410 | Parser_cocci_menhir.Error
->
1412 (Printf.sprintf
"%s: parse error: \n = %s\n" str
1413 (Common.error_message file
(get_s_starts !cur_tok) ))
1414 | Semantic_cocci.Semantic s
->
1416 (Printf.sprintf
"%s: semantic error: %s\n =%s\n" str s
1417 (Common.error_message file
(get_s_starts !cur_tok) ))
1421 let prepare_tokens tokens
=
1423 (translate_when_true_false (* after insert_line_end *)
1426 (find_function_names
1429 (check_parentheses tokens
)))))))
1431 let prepare_mv_tokens tokens
=
1432 detect_types false (detect_attr tokens
)
1434 let unminus (d
,x1
,x2
,x3
,x4
,x5
,x6
,x7
) = (* for hidden variables *)
1436 D.MINUS
| D.OPTMINUS
| D.UNIQUEMINUS
-> (D.CONTEXT
,x1
,x2
,x3
,x4
,x5
,x6
,x7
)
1437 | D.PLUS
-> failwith
"unexpected plus code"
1438 | D.PLUSPLUS
-> failwith
"unexpected plus code"
1439 | D.CONTEXT
| D.UNIQUE
| D.OPT
-> (D.CONTEXT
,x1
,x2
,x3
,x4
,x5
,x6
,x7
)
1441 let process_minus_positions x name
clt meta
=
1442 let (arity
,ln
,lln
,offset
,col
,strbef
,straft
,pos
) = get_clt x
in
1443 let name = Parse_aux.clt2mcode
name (unminus clt) in
1444 update_clt x
(arity
,ln
,lln
,offset
,col
,strbef
,straft
,meta
name::pos
)
1446 (* first attach positions, then the others, so that positions can refer to
1447 the larger term represented by the preceding metavariable *)
1448 let rec consume_minus_positions toks
=
1449 let rec loop_pos = function
1451 | ((PC.TOPar0
(_
),_
) as x
)::xs
| ((PC.TCPar0
(_
),_
) as x
)::xs
1452 | ((PC.TMid0
(_
),_
) as x
)::xs
-> x
::loop_pos xs
1453 | x
::(PC.TPArob _
,_
)::(PC.TMetaPos
(name,constraints
,per
,clt),_
)::xs
->
1455 process_minus_positions x name clt
1457 Ast0.MetaPosTag
(Ast0.MetaPos
(name,constraints
,per
))) in
1459 | x::xs
-> x::loop_pos xs
in
1460 let rec loop_other = function
1462 | ((PC.TOPar0
(_
),_
) as x)::xs
| ((PC.TCPar0
(_
),_
) as x)::xs
1463 | ((PC.TMid0
(_
),_
) as x)::xs
-> x::loop_other xs
1464 | x::(PC.TPArob _
,_
)::(PC.TMetaExp
(name,constraints
,pure
,ty
,clt),_
)::xs
->
1466 process_minus_positions x name clt
1470 (Ast0.MetaExpr
(name,constraints
,ty
,Ast.ANY
,pure
)))) in
1471 (loop_other (x::xs
))
1472 | x::(PC.TPArob _
,_
)::(PC.TMetaInit
(name,pure
,clt),_
)::xs
->
1474 process_minus_positions x name clt
1476 Ast0.InitTag
(Ast0.wrap
(Ast0.MetaInit
(name,pure
)))) in
1477 (loop_other (x::xs
))
1478 | x::(PC.TPArob _
,_
)::(PC.TMetaType
(name,pure
,clt),_
)::xs
->
1480 process_minus_positions x name clt
1482 Ast0.TypeCTag
(Ast0.wrap
(Ast0.MetaType
(name,pure
)))) in
1483 (loop_other (x::xs
))
1484 | x::(PC.TPArob _
,_
)::(PC.TMetaDecl
(name,pure
,clt),_
)::xs
->
1486 process_minus_positions x name clt
1488 Ast0.DeclTag
(Ast0.wrap
(Ast0.MetaDecl
(name,pure
)))) in
1489 (loop_other (x::xs
))
1490 | x::(PC.TPArob _
,_
)::(PC.TMetaStm
(name,pure
,clt),_
)::xs
->
1492 process_minus_positions x name clt
1494 Ast0.StmtTag
(Ast0.wrap
(Ast0.MetaStmt
(name,pure
)))) in
1495 (loop_other (x::xs
))
1496 | x::xs
-> x::loop_other xs
in
1497 loop_other(loop_pos toks
)
1499 let rec consume_plus_positions = function
1501 | (PC.TPArob _
,_
)::x::xs
-> consume_plus_positions xs
1502 | x::xs
-> x::consume_plus_positions xs
1504 let any_modif rule
=
1506 match Ast0.get_mcode_mcodekind
x with
1507 Ast0.MINUS _
| Ast0.PLUS _
-> true
1509 let donothing r k e
= k e
in
1510 let bind x y
= x or y
in
1511 let option_default = false in
1513 V0.flat_combiner
bind option_default
1514 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1515 donothing donothing donothing donothing donothing donothing
1516 donothing donothing donothing donothing donothing donothing donothing
1517 donothing donothing in
1518 List.exists
fn.VT0.combiner_rec_top_level rule
1520 let eval_virt virt
=
1523 if not
(List.mem
x virt
)
1524 then raise
(Bad_virt
x))
1525 !Flag.defined_virtual_rules
1527 let drop_last extra l
= List.rev
(extra
@(List.tl
(List.rev l
)))
1529 let partition_either l
=
1530 let rec part_either left right
= function
1531 | [] -> (List.rev left
, List.rev right
)
1534 | Common.Left e
-> part_either (e
:: left
) right l
1535 | Common.Right e
-> part_either left
(e
:: right
) l
) in
1538 let get_metavars parse_fn table file lexbuf
=
1539 let rec meta_loop acc
(* read one decl at a time *) =
1543 tokens_all table file
true lexbuf
[PC.TArobArob
;PC.TMPtVirg
]) in
1544 let tokens = prepare_mv_tokens tokens in
1546 [(PC.TArobArob
,_
)] -> List.rev acc
1548 let metavars = parse_one "meta" parse_fn file
tokens in
1549 meta_loop (metavars@acc
) in
1550 partition_either (meta_loop [])
1552 let get_script_metavars parse_fn table file lexbuf
=
1553 let rec meta_loop acc
=
1555 tokens_all table file
true lexbuf
[PC.TArobArob
; PC.TMPtVirg
] in
1556 let tokens = prepare_tokens tokens in
1558 [(PC.TArobArob
, _
)] -> List.rev acc
1560 let metavar = parse_one "scriptmeta" parse_fn file
tokens in
1561 meta_loop (metavar :: acc
)
1565 let get_rule_name parse_fn starts_with_name get_tokens file prefix
=
1566 Data.in_rule_name
:= true;
1567 let mknm _
= make_name prefix
(!Lexer_cocci.line
) in
1571 let (_
,tokens) = get_tokens
[PC.TArob
] in
1572 let check_name = function
1573 None
-> Some
(mknm())
1575 (if List.mem nm
reserved_names
1576 then failwith
(Printf.sprintf
"invalid name %s\n" nm
));
1578 match parse_one "rule name" parse_fn file
tokens with
1579 Ast.CocciRulename
(nm
,a
,b
,c
,d
,e
) ->
1580 Ast.CocciRulename
(check_name nm
,a
,b
,c
,d
,e
)
1581 | Ast.GeneratedRulename
(nm
,a
,b
,c
,d
,e
) ->
1582 Ast.GeneratedRulename
(check_name nm
,a
,b
,c
,d
,e
)
1583 | Ast.ScriptRulename
(nm
,s
,deps
) ->
1584 Ast.ScriptRulename
(check_name nm
,s
,deps
)
1585 | Ast.InitialScriptRulename
(_
,s
,deps
) ->
1586 Ast.InitialScriptRulename
(check_name None
,s
,deps
)
1587 | Ast.FinalScriptRulename
(_
,s
,deps
) ->
1588 Ast.FinalScriptRulename
(check_name None
,s
,deps
)
1590 Ast.CocciRulename
(Some
(mknm()),Ast.NoDep
,[],[],Ast.Undetermined
,false) in
1591 Data.in_rule_name
:= false;
1594 let parse_iso file
=
1595 let table = Common.full_charpos_to_pos file
in
1596 Common.with_open_infile file
(fun channel
->
1597 let lexbuf = Lexing.from_channel channel
in
1598 let get_tokens = tokens_all table file
false lexbuf in
1600 match get_tokens [PC.TArobArob
;PC.TArob
] with
1602 let parse_start start =
1603 let rev = List.rev start in
1604 let (arob
,_
) = List.hd
rev in
1605 (arob
= PC.TArob
,List.rev(List.tl
rev)) in
1606 let (starts_with_name
,start) = parse_start start in
1607 let rec loop starts_with_name
start =
1608 (!Data.init_rule
)();
1609 (* get metavariable declarations - have to be read before the
1611 let (rule_name
,_
,_
,_
,_
,_
) =
1612 match get_rule_name PC.iso_rule_name starts_with_name
get_tokens
1613 file
("iso file "^file
) with
1614 Ast.CocciRulename
(Some n
,a
,b
,c
,d
,e
) -> (n
,a
,b
,c
,d
,e
)
1615 | _
-> failwith
"Script rules cannot appear in isomorphism rules"
1617 Ast0.rule_name
:= rule_name
;
1619 match get_metavars PC.iso_meta_main
table file
lexbuf with
1620 (iso_metavars,[]) -> iso_metavars
1621 | _
-> failwith
"unexpected inheritance in iso" in
1625 [PC.TIsoStatement
;PC.TIsoExpression
;PC.TIsoArgExpression
;
1626 PC.TIsoTestExpression
; PC.TIsoToTestExpression
;
1627 PC.TIsoDeclaration
;PC.TIsoType
;PC.TIsoTopLevel
] in
1628 let next_start = List.hd
(List.rev tokens) in
1629 let dummy_info = ("",(-1,-1),(-1,-1)) in
1630 let tokens = drop_last [(PC.EOF
,dummy_info)] tokens in
1631 let tokens = prepare_tokens (start@tokens) in
1633 print_tokens "iso tokens" tokens;
1635 let entry = parse_one "iso main" PC.iso_main file
tokens in
1636 let entry = List.map
(List.map
Test_exps.process_anything
) entry in
1638 then (* The code below allows a header like Statement list,
1639 which is more than one word. We don't have that any more,
1640 but the code is left here in case it is put back. *)
1641 match get_tokens [PC.TArobArob
;PC.TArob
] with
1643 let (starts_with_name
,start) = parse_start start in
1644 (iso_metavars,entry,rule_name
) ::
1645 (loop starts_with_name
(next_start::start))
1646 | _
-> failwith
"isomorphism ends early"
1647 else [(iso_metavars,entry,rule_name
)] in
1648 loop starts_with_name
start
1649 | (false,_
) -> [] in
1650 List.iter
Iso_compile.process
res;
1653 let parse_iso_files existing_isos iso_files extra_path
=
1654 let get_names = List.map
(function (_
,_
,nm
) -> nm
) in
1655 let old_names = get_names existing_isos
in
1656 Data.in_iso
:= true;
1659 (function (prev
,names
) ->
1661 Lexer_cocci.init
();
1664 Common.Left
(fl
) -> Filename.concat extra_path fl
1665 | Common.Right
(fl
) -> Filename.concat
Config.path fl
in
1666 let current = parse_iso file in
1667 let new_names = get_names current in
1668 if List.exists
(function x -> List.mem
x names
) new_names
1669 then failwith
(Printf.sprintf
"repeated iso name found in %s" file);
1670 (current::prev
,new_names @ names
))
1671 ([],old_names) iso_files
in
1672 Data.in_iso
:= false;
1673 existing_isos
@(List.concat
(List.rev res))
1675 (* None = dependency not satisfied
1676 Some dep = dependency satisfied or unknown and dep has virts optimized
1678 let eval_depend dep virt
=
1681 Ast.Dep req
| Ast.EverDep req
->
1682 if List.mem req virt
1684 if List.mem req
!Flag.defined_virtual_rules
1688 | Ast.AntiDep antireq
| Ast.NeverDep antireq
->
1689 if List.mem antireq virt
1691 if not
(List.mem antireq
!Flag.defined_virtual_rules
)
1695 | Ast.AndDep
(d1
,d2
) ->
1696 (match (loop d1
, loop d2
) with
1697 (Ast.NoDep
,x) | (x,Ast.NoDep
) -> x
1698 | (Ast.FailDep
,x) | (x,Ast.FailDep
) -> Ast.FailDep
1699 | (x,y
) -> Ast.AndDep
(x,y
))
1700 | Ast.OrDep
(d1
,d2
) ->
1701 (match (loop d1
, loop d2
) with
1702 (Ast.NoDep
,x) | (x,Ast.NoDep
) -> Ast.NoDep
1703 | (Ast.FailDep
,x) | (x,Ast.FailDep
) -> x
1704 | (x,y
) -> Ast.OrDep
(x,y
))
1705 | Ast.NoDep
| Ast.FailDep
-> dep
1711 let rec parse_loop file =
1712 Lexer_cocci.include_init
();
1713 let table = Common.full_charpos_to_pos
file in
1714 Common.with_open_infile
file (fun channel
->
1715 let lexbuf = Lexing.from_channel channel
in
1716 let get_tokens = tokens_all table file false lexbuf in
1717 Data.in_prolog
:= true;
1718 let initial_tokens = get_tokens [PC.TArobArob
;PC.TArob
] in
1719 Data.in_prolog
:= false;
1721 match initial_tokens with
1723 (match List.rev data
with
1724 ((PC.TArobArob
as x),_
)::_
| ((PC.TArob
as x),_
)::_
->
1725 let include_and_iso_files =
1726 parse_one "include and iso file names" PC.include_main
file data
in
1728 let (include_files
,iso_files
,virt
) =
1730 (function (include_files
,iso_files
,virt
) ->
1732 Data.Include s
-> (s
::include_files
,iso_files
,virt
)
1733 | Data.Iso s
-> (include_files
,s
::iso_files
,virt
)
1734 | Data.Virt l
-> (include_files
,iso_files
,l
@virt
))
1735 ([],[],[]) include_and_iso_files in
1737 List.iter
(function x -> Hashtbl.add
Lexer_cocci.rule_names
x ())
1740 let (extra_iso_files
, extra_rules
, extra_virt
, extra_metas
) =
1741 let rec loop = function
1743 | (a
,b
,c
,d
)::rest ->
1744 let (x,y
,z
,zz
) = loop rest in
1745 (a
::x,b
::y
,c
::z
,d
@zz
) in
1746 loop (List.map
parse_loop include_files
) in
1748 let parse_cocci_rule ruletype old_metas
1749 (rule_name
, dependencies
, iso
, dropiso
, exists
, is_expression
) =
1750 let dropiso = !Flag_parsing_cocci.disabled_isos
@ dropiso in
1751 Ast0.rule_name
:= rule_name
;
1752 Data.inheritable_positions
:=
1753 rule_name
:: !Data.inheritable_positions
;
1755 (* get metavariable declarations *)
1756 let (metavars, inherited_metavars
) =
1757 get_metavars PC.meta_main
table file lexbuf in
1758 Hashtbl.add
Data.all_metadecls rule_name
metavars;
1759 Hashtbl.add
Lexer_cocci.rule_names rule_name
();
1760 Hashtbl.add
Lexer_cocci.all_metavariables rule_name
1762 (fun key
v rest -> (key
,v)::rest)
1763 Lexer_cocci.metavariables
[]);
1765 (* get transformation rules *)
1766 let (more
, tokens) = get_tokens [PC.TArobArob
; PC.TArob
] in
1767 let (minus_tokens
, _
) = split_token_stream tokens in
1768 let (_
, plus_tokens
) =
1769 split_token_stream (minus_to_nothing tokens) in
1772 print_tokens "minus tokens" minus_tokens;
1773 print_tokens "plus tokens" plus_tokens;
1776 let minus_tokens = consume_minus_positions minus_tokens in
1777 let plus_tokens = consume_plus_positions plus_tokens in
1778 let minus_tokens = prepare_tokens minus_tokens in
1779 let plus_tokens = prepare_tokens plus_tokens in
1782 print_tokens "minus tokens" minus_tokens;
1783 print_tokens "plus tokens" plus_tokens;
1787 process_pragmas None
[]
1788 (fix (function x -> drop_double_dots (drop_empty_or x))
1789 (drop_when plus_tokens)) in
1791 print_tokens "plus tokens" plus_tokens;
1792 Printf.printf "before minus parse\n";
1796 then parse_one "minus" PC.minus_exp_main
file minus_tokens
1797 else parse_one "minus" PC.minus_main
file minus_tokens in
1799 Unparse_ast0.unparse minus_res;
1800 Printf.printf "before plus parse\n";
1803 (* put ignore_patch_or_match with * case, which is less
1805 if !Flag.sgrep_mode2
or !D.ignore_patch_or_match
1806 then (* not actually used for anything, except context_neg *)
1808 (Iso_pattern.rebuild_mcode None
).VT0.rebuilder_rec_top_level
1809 (Top_level.top_level
false minus_res)
1812 then parse_one "plus" PC.plus_exp_main
file plus_tokens
1813 else parse_one "plus" PC.plus_main
file plus_tokens in
1814 let plus_res = Top_level.top_level
false plus_res in
1815 (* minus code has to be CODE if the + code is CODE, otherwise
1816 doesn't matter if + code is CODE or DECL or TOPCODE *)
1821 match Ast0.unwrap
x with Ast0.CODE _
-> true | _
-> false)
1824 then Top_level.top_level
true minus_res
1825 else Top_level.top_level
false minus_res in
1826 let minus_res = Top_level.clean
minus_res in
1827 let plus_res = Top_level.clean
plus_res in
1829 Unparse_ast0.unparse plus_res;
1830 Printf.printf "after plus parse\n";
1833 (if not
!Flag.sgrep_mode2
&&
1834 (any_modif minus_res or any_modif plus_res) &&
1835 not
(dependencies
= Ast.FailDep
)
1836 then Data.inheritable_positions
:= []);
1838 Check_meta.check_meta rule_name old_metas inherited_metavars
1839 metavars minus_res plus_res;
1841 (more
, Ast0.CocciRule
((minus_res, metavars,
1842 (iso
, dropiso, dependencies
, rule_name
, exists
)),
1843 (plus_res, metavars), ruletype
), metavars, tokens) in
1845 let rec collect_script_tokens = function
1846 [(PC.EOF
,_
)] | [(PC.TArobArob
,_
)] | [(PC.TArob
,_
)] -> ""
1847 | (PC.TScriptData
(s
),_
)::xs
-> s^
(collect_script_tokens xs
)
1851 Printf.printf
"%s\n" (token2c x))
1853 failwith
"Malformed script rule" in
1855 let parse_script_rule name language old_metas deps
=
1856 let get_tokens = tokens_script_all table file false lexbuf in
1858 (* meta-variables *)
1862 get_script_metavars PC.script_meta_main
table file lexbuf) in
1863 let (metavars,script_metavars
) =
1865 (function (metavars,script_metavars
) ->
1867 (script_var
,Some
(parent
,var
)) ->
1868 ((script_var
,parent
,var
) :: metavars, script_metavars
)
1869 | ((Some script_var
,None
),None
) ->
1870 (metavars, (name,script_var
) :: script_metavars
)
1871 | _
-> failwith
"not possible")
1873 let metavars = List.rev metavars in
1874 let script_metavars = List.rev script_metavars in
1876 Hashtbl.add
Data.all_metadecls
name
1877 (List.map
(function x -> Ast.MetaIdDecl
(Ast.NONE
,x))
1879 Hashtbl.add
Lexer_cocci.rule_names
name ();
1880 (*TODOHashtbl.add Lexer_cocci.all_metavariables name script_metavars;*)
1883 let exists_in old_metas (py,(r,m)) =
1885 let test (rr,mr) x =
1886 let (ro,vo) = Ast.get_meta_name x in
1887 ro = rr && vo = mr in
1888 List.exists (test (r,m)) old_metas in
1892 let meta2c (r,n) = Printf.sprintf "%s.%s" r n in
1893 if not (exists_in old_metas x) then
1896 "Script references unknown meta-variable: %s"
1901 let (more
, tokens) = get_tokens [PC.TArobArob
; PC.TArob
] in
1902 let data = collect_script_tokens tokens in
1904 Ast0.ScriptRule
(name, language
, deps
, metavars,
1905 script_metavars, data),
1908 let parse_if_script_rule k
name language _ deps
=
1909 let get_tokens = tokens_script_all table file false lexbuf in
1912 let (more
, tokens) = get_tokens [PC.TArobArob
; PC.TArob
] in
1913 let data = collect_script_tokens tokens in
1914 (more
,k
(name, language
, deps
, data),[],tokens) in
1916 let parse_iscript_rule =
1917 parse_if_script_rule
1918 (function (name,language
,deps
,data) ->
1919 Ast0.InitialScriptRule
(name,language
,deps
,data)) in
1921 let parse_fscript_rule =
1922 parse_if_script_rule
1923 (function (name,language
,deps
,data) ->
1924 Ast0.FinalScriptRule
(name,language
,deps
,data)) in
1926 let do_parse_script_rule fn name l old_metas deps
=
1927 fn name l old_metas
(eval_depend deps virt
) in
1929 let parse_rule old_metas starts_with_name
=
1931 get_rule_name PC.rule_name starts_with_name
get_tokens file
1934 Ast.CocciRulename
(Some s
, dep
, b
, c
, d
, e
) ->
1935 (match eval_depend dep virt
with
1937 D.ignore_patch_or_match
:= true;
1939 parse_cocci_rule Ast.Normal old_metas
1940 (s
, Ast.FailDep
, b
, c
, d
, e
) in
1941 D.ignore_patch_or_match
:= false;
1943 | dep
-> parse_cocci_rule Ast.Normal old_metas
(s
,dep
,b
,c
,d
,e
))
1944 | Ast.GeneratedRulename
(Some s
, dep
, b
, c
, d
, e
) ->
1945 (match eval_depend dep virt
with
1947 D.ignore_patch_or_match
:= true;
1948 Data.in_generating
:= true;
1950 parse_cocci_rule Ast.Generated old_metas
1951 (s
, Ast.FailDep
, b
, c
, d
, e
) in
1952 D.ignore_patch_or_match
:= false;
1953 Data.in_generating
:= false;
1956 Data.in_generating
:= true;
1958 parse_cocci_rule Ast.Generated old_metas
1960 Data.in_generating
:= false;
1962 | Ast.ScriptRulename
(Some s
,l
,deps
) ->
1963 do_parse_script_rule parse_script_rule s l old_metas deps
1964 | Ast.InitialScriptRulename
(Some s
,l
,deps
) ->
1965 do_parse_script_rule parse_iscript_rule s l old_metas deps
1966 | Ast.FinalScriptRulename
(Some s
,l
,deps
) ->
1967 do_parse_script_rule parse_fscript_rule s l old_metas deps
1968 | _
-> failwith
"Malformed rule name" in
1970 let rec loop old_metas starts_with_name
=
1971 (!Data.init_rule
)();
1973 let gen_starts_with_name more
tokens =
1975 (match List.hd
(List.rev tokens) with
1976 (PC.TArobArob
,_
) -> false
1977 | (PC.TArob
,_
) -> true
1978 | _
-> failwith
"unexpected token")
1981 let (more
, rule
, metavars, tokens) =
1982 parse_rule old_metas starts_with_name
in
1983 let all_metas = metavars @ old_metas
in
1986 let (all_rules
,all_metas) =
1987 loop all_metas (gen_starts_with_name more
tokens) in
1988 (rule
::all_rules
,all_metas)
1989 else ([rule
],all_metas) in
1991 let (all_rules
,all_metas) =
1992 loop extra_metas
(x = PC.TArob
) in
1995 (function prev
-> function cur -> Common.union_set
cur prev
)
1996 iso_files extra_iso_files
,
1997 (* included rules first *)
1998 List.fold_left
(function prev
-> function cur -> cur@prev
)
1999 all_rules
(List.rev extra_rules
),
2000 List.fold_left
(@) virt extra_virt
(*no dups allowed*),
2001 (all_metas : 'a list
))
2002 | _
-> failwith
"unexpected code before the first rule\n")
2003 | (false,[(PC.TArobArob
,_
)]) | (false,[(PC.TArob
,_
)]) ->
2004 ([],([] : Ast0.parsed_rule list
),[] (*virtual rules*), [] (*all metas*))
2005 | _
-> failwith
"unexpected code before the first rule\n" in
2009 (* parse to ast0 and then convert to ast *)
2010 let process file isofile verbose
=
2011 let extra_path = Filename.dirname
file in
2012 let (iso_files
, rules
, virt
, _metas
) = parse file in
2017 | Some iso_file
-> parse_iso_files [] [Common.Left iso_file
] "" in
2018 let global_isos = parse_iso_files std_isos iso_files
extra_path in
2019 let rules = Unitary_ast0.do_unitary
rules in
2023 Ast0.ScriptRule
(a
,b
,c
,d
,fv
,e
) ->
2024 [([],Ast.ScriptRule
(a
,b
,c
,d
,fv
,e
))]
2025 | Ast0.InitialScriptRule
(a
,b
,c
,d
) ->
2026 [([],Ast.InitialScriptRule
(a
,b
,c
,d
))]
2027 | Ast0.FinalScriptRule
(a
,b
,c
,d
) ->
2028 [([],Ast.FinalScriptRule
(a
,b
,c
,d
))]
2031 (iso
, dropiso, dependencies
, rule_name
, exists
)),
2032 (plus
, metavars),ruletype
) ->
2034 parse_iso_files global_isos
2035 (List.map
(function x -> Common.Left
x) iso
)
2038 (* check that dropped isos are actually available *)
2041 List.map
(function (_
,_
,nm
) -> nm
) chosen_isos in
2042 let local_iso_names = reserved_names @ iso_names in
2045 (function dropped
->
2046 not
(List.mem dropped
local_iso_names))
2049 ("invalid iso name " ^
bad_dropped ^
" in " ^ rule_name
)
2050 with Not_found
-> ());
2051 if List.mem
"all" dropiso
2053 if List.length
dropiso = 1
2055 else failwith
"disable all should only be by itself"
2056 else (* drop those isos *)
2058 (function (_
,_
,nm
) -> not
(List.mem nm
dropiso))
2061 match reserved_names with
2066 List.filter
(function x -> List.mem
x dropiso) others
)
2069 "bad list of reserved names - all must be at start" in
2070 let minus = Test_exps.process minus in
2071 let minus = Compute_lines.compute_lines
false minus in
2072 let plus = Compute_lines.compute_lines
false plus in
2074 (* only relevant to Flag.make_hrule *)
2075 (* doesn't handle multiple minirules properly, but since
2076 we don't really handle them in lots of other ways, it
2077 doesn't seem very important *)
2081 [match Ast0.unwrap p
with
2083 (match List.map
Ast0.unwrap
(Ast0.undots c
) with
2084 [Ast0.Exp e
] -> true | _
-> false)
2086 let minus = Arity.minus_arity
minus in
2087 let ((metavars,minus),function_prototypes
) =
2088 Function_prototypes.process
2089 rule_name
metavars dropped_isos minus plus ruletype
in
2090 let plus = Adjust_pragmas.process plus in
2091 (* warning! context_neg side-effects its arguments *)
2092 let (m
,p
) = List.split (Context_neg.context_neg
minus plus) in
2093 Type_infer.type_infer p
;
2094 (if not
(!Flag.sgrep_mode2
or dependencies
= Ast.FailDep
)
2095 then Insert_plus.insert_plus m p
(chosen_isos = []));
2096 Type_infer.type_infer
minus;
2097 let (extra_meta
, minus) =
2098 match (chosen_isos,ruletype
) with
2099 (* separate case for [] because applying isos puts
2100 some restrictions on the -+ code *)
2101 ([],_
) | (_
,Ast.Generated
) -> ([],minus)
2102 | _
-> Iso_pattern.apply_isos
chosen_isos minus rule_name
in
2103 (* after iso, because iso can intro ... *)
2104 let minus = Adjacency.compute_adjacency
minus in
2105 let minus = Comm_assoc.comm_assoc
minus rule_name
dropiso in
2107 if !Flag.sgrep_mode2
then minus
2108 else Single_statement.single_statement
minus in
2109 let minus = Simple_assignments.simple_assignments
minus in
2110 (* has to be last, introduced AsExpr, etc *)
2111 let minus = Get_metas.process minus in
2113 Ast0toast.ast0toast rule_name dependencies
dropped_isos
2114 exists
minus is_exp ruletype
in
2116 match function_prototypes
with
2117 None
-> [(extra_meta
@ metavars, minus_ast)]
2118 | Some mv_fp
-> [(extra_meta
@ metavars, minus_ast); mv_fp
])
2119 (* Ast0.CocciRule ((minus, metavarsm, (iso, dropiso, dependencies, rule_name, exists)), (plus, metavars))*)
2122 let parsed = List.concat
parsed in
2123 let parsed = Safe_for_multi_decls.safe_for_multi_decls
parsed in
2124 let disjd = Disjdistr.disj
parsed in
2126 let (metavars,code
,fvs
,neg_pos
,ua
,pos
) = Free_vars.free_vars
disjd in
2127 if !Flag_parsing_cocci.show_SP
2128 then List.iter
Pretty_print_cocci.unparse code
;
2131 Common.profile_code
"get_glimpse_constants" (* for glimpse *)
2132 (fun () -> Get_constants2.get_constants code neg_pos
) in
2134 (metavars,code
,fvs
,neg_pos
,ua
,pos
,search_tokens)