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 #
0 "./parse_cocci.ml"
28 (* splits the entire file into minus and plus fragments, and parses each
29 separately (thus duplicating work for the parsing of the context elements) *)
32 module PC
= Parser_cocci_menhir
33 module V0
= Visitor_ast0
34 module VT0
= Visitor_ast0_types
35 module Ast
= Ast_cocci
36 module Ast0
= Ast0_cocci
38 exception Bad_virt
of string
40 let pr = Printf.sprintf
41 (*let pr2 s = prerr_string s; prerr_string "\n"; flush stderr*)
42 let pr2 s
= Printf.printf
"%s\n" s
44 (* for isomorphisms. all should be at the front!!! *)
46 ["all";"optional_storage";"optional_qualifier";"value_format";"comm_assoc"]
48 (* ----------------------------------------------------------------------- *)
51 let line_type (d
,_
,_
,_
,_
,_
,_
,_
) = d
54 match line_type tok
with
55 D.MINUS
| D.OPTMINUS
| D.UNIQUEMINUS
-> ":-"
58 | D.CONTEXT
| D.UNIQUE
| D.OPT
-> ""
62 PC.TMetavariable
-> "metavariable"
63 | PC.TIdentifier
-> "identifier"
65 | PC.TParameter
-> "parameter"
66 | PC.TConstant
-> "constant"
67 | PC.TExpression
-> "expression"
68 | PC.TIdExpression
-> "idexpression"
69 | PC.TInitialiser
-> "initialiser"
70 | PC.TSymbol
-> "symbol"
71 | PC.TDeclaration
-> "declaration"
72 | PC.TField
-> "field"
73 | PC.TStatement
-> "statement"
74 | PC.TPosition
-> "position"
76 | PC.TFunction
-> "function"
77 | PC.TLocal
-> "local"
79 | PC.TFresh
-> "fresh"
80 | PC.TCppConcatOp
-> "##"
82 | PC.TContext
-> "context"
83 | PC.TTypedef
-> "typedef"
84 | PC.TDeclarer
-> "declarer"
85 | PC.TIterator
-> "iterator"
87 | PC.TRuleName str
-> "rule_name-"^str
88 | PC.TUsing
-> "using"
89 | PC.TVirtual
-> "virtual"
90 | PC.TPathIsoFile str
-> "path_iso_file-"^str
91 | PC.TDisable
-> "disable"
92 | PC.TExtends
-> "extends"
93 | PC.TDepends
-> "depends"
96 | PC.TNever
-> "never"
97 | PC.TExists
-> "exists"
98 | PC.TForall
-> "forall"
99 | PC.TError
-> "error"
100 | PC.TWords
-> "words"
101 | PC.TGenerated
-> "generated"
103 | PC.TNothing
-> "nothing"
105 | PC.Tchar
(clt
) -> "char"^
(line_type2c clt
)
106 | PC.Tshort
(clt
) -> "short"^
(line_type2c clt
)
107 | PC.Tint
(clt
) -> "int"^
(line_type2c clt
)
108 | PC.Tdouble
(clt
) -> "double"^
(line_type2c clt
)
109 | PC.Tfloat
(clt
) -> "float"^
(line_type2c clt
)
110 | PC.Tlong
(clt
) -> "long"^
(line_type2c clt
)
111 | PC.Tvoid
(clt
) -> "void"^
(line_type2c clt
)
112 | PC.Tsize_t
(clt
) -> "size_t"^
(line_type2c clt
)
113 | PC.Tssize_t
(clt
) -> "ssize_t"^
(line_type2c clt
)
114 | PC.Tptrdiff_t
(clt
) -> "ptrdiff_t"^
(line_type2c clt
)
115 | PC.Tstruct
(clt
) -> "struct"^
(line_type2c clt
)
116 | PC.Tunion
(clt
) -> "union"^
(line_type2c clt
)
117 | PC.Tenum
(clt
) -> "enum"^
(line_type2c clt
)
118 | PC.Tunsigned
(clt
) -> "unsigned"^
(line_type2c clt
)
119 | PC.Tsigned
(clt
) -> "signed"^
(line_type2c clt
)
120 | PC.Tstatic
(clt
) -> "static"^
(line_type2c clt
)
121 | PC.Tinline
(clt
) -> "inline"^
(line_type2c clt
)
122 | PC.Ttypedef
(clt
) -> "typedef"^
(line_type2c clt
)
123 | PC.Tattr
(s
,clt
) -> s^
(line_type2c clt
)
124 | PC.Tauto
(clt
) -> "auto"^
(line_type2c clt
)
125 | PC.Tregister
(clt
) -> "register"^
(line_type2c clt
)
126 | PC.Textern
(clt
) -> "extern"^
(line_type2c clt
)
127 | PC.Tconst
(clt
) -> "const"^
(line_type2c clt
)
128 | PC.Tvolatile
(clt
) -> "volatile"^
(line_type2c clt
)
130 | PC.TPragma
(Ast.Noindent s
,_
) -> s
131 | PC.TPragma
(Ast.Indent s
,_
) -> s
132 | PC.TPragma
(Ast.Space s
,_
) -> s
133 | PC.TIncludeL
(s
,clt
) -> (pr "#include \"%s\"" s
)^
(line_type2c clt
)
134 | PC.TIncludeNL
(s
,clt
) -> (pr "#include <%s>" s
)^
(line_type2c clt
)
135 | PC.TUndef
(clt
,_
) -> "#undef"^
(line_type2c clt
)
136 | PC.TDefine
(clt
,_
) -> "#define"^
(line_type2c clt
)
137 | PC.TDefineParam
(clt
,_
,_
,_
) -> "#define_param"^
(line_type2c clt
)
138 | PC.TMinusFile
(s
,clt
) -> (pr "--- %s" s
)^
(line_type2c clt
)
139 | PC.TPlusFile
(s
,clt
) -> (pr "+++ %s" s
)^
(line_type2c clt
)
141 | PC.TInc
(clt
) -> "++"^
(line_type2c clt
)
142 | PC.TDec
(clt
) -> "--"^
(line_type2c clt
)
144 | PC.TIf
(clt
) -> "if"^
(line_type2c clt
)
145 | PC.TElse
(clt
) -> "else"^
(line_type2c clt
)
146 | PC.TWhile
(clt
) -> "while"^
(line_type2c clt
)
147 | PC.TFor
(clt
) -> "for"^
(line_type2c clt
)
148 | PC.TDo
(clt
) -> "do"^
(line_type2c clt
)
149 | PC.TSwitch
(clt
) -> "switch"^
(line_type2c clt
)
150 | PC.TCase
(clt
) -> "case"^
(line_type2c clt
)
151 | PC.TDefault
(clt
) -> "default"^
(line_type2c clt
)
152 | PC.TReturn
(clt
) -> "return"^
(line_type2c clt
)
153 | PC.TBreak
(clt
) -> "break"^
(line_type2c clt
)
154 | PC.TContinue
(clt
) -> "continue"^
(line_type2c clt
)
155 | PC.TGoto
(clt
) -> "goto"^
(line_type2c clt
)
156 | PC.TIdent
(s
,clt
) -> (pr "ident-%s" s
)^
(line_type2c clt
)
157 | PC.TTypeId
(s
,clt
) -> (pr "typename-%s" s
)^
(line_type2c clt
)
158 | PC.TDeclarerId
(s
,clt
) -> (pr "declarername-%s" s
)^
(line_type2c clt
)
159 | PC.TIteratorId
(s
,clt
) -> (pr "iteratorname-%s" s
)^
(line_type2c clt
)
160 | PC.TSymId
(s
,clt
) -> (pr "symbol-%s" s
)^
(line_type2c clt
)
161 | PC.TMetaDeclarer
(_
,_
,_
,clt
) -> "declmeta"^
(line_type2c clt
)
162 | PC.TMetaIterator
(_
,_
,_
,clt
) -> "itermeta"^
(line_type2c clt
)
164 | PC.TSizeof
(clt
) -> "sizeof"^
(line_type2c clt
)
166 | PC.TString
(x
,clt
) -> x^
(line_type2c clt
)
167 | PC.TChar
(x
,clt
) -> x^
(line_type2c clt
)
168 | PC.TFloat
(x
,clt
) -> x^
(line_type2c clt
)
169 | PC.TInt
(x
,clt
) -> x^
(line_type2c clt
)
171 | PC.TOrLog
(clt
) -> "||"^
(line_type2c clt
)
172 | PC.TAndLog
(clt
) -> "&&"^
(line_type2c clt
)
173 | PC.TOr
(clt
) -> "|"^
(line_type2c clt
)
174 | PC.TXor
(clt
) -> "^"^
(line_type2c clt
)
175 | PC.TAnd
(clt
) -> "&"^
(line_type2c clt
)
176 | PC.TEqEq
(clt
) -> "=="^
(line_type2c clt
)
177 | PC.TNotEq
(clt
) -> "!="^
(line_type2c clt
)
178 | PC.TSub
(clt
) -> "<="^
(line_type2c clt
)
179 | PC.TTildeEq
(clt
) -> "~="^
(line_type2c clt
)
180 | PC.TTildeExclEq
(clt
) -> "~!="^
(line_type2c clt
)
181 | PC.TLogOp
(op
,clt
) ->
187 | _
-> failwith
"not possible")
189 | PC.TShLOp
(op
,clt
) -> "<<"^
(line_type2c clt
)
190 | PC.TShROp
(op
,clt
) -> ">>"^
(line_type2c clt
)
191 | PC.TPlus
(clt
) -> "+"^
(line_type2c clt
)
192 | PC.TMinus
(clt
) -> "-"^
(line_type2c clt
)
193 | PC.TMul
(clt
) -> "*"^
(line_type2c clt
)
194 | PC.TDmOp
(op
,clt
) ->
198 | _
-> failwith
"not possible")
200 | PC.TTilde
(clt
) -> "~"^
(line_type2c clt
)
202 | PC.TMeta
(_
,_
,clt
) -> "meta"^
(line_type2c clt
)
203 | PC.TMetaParam
(_
,_
,clt
) -> "parammeta"^
(line_type2c clt
)
204 | PC.TMetaParamList
(_
,_
,_
,clt
) -> "paramlistmeta"^
(line_type2c clt
)
205 | PC.TMetaConst
(_
,_
,_
,_
,clt
) -> "constmeta"^
(line_type2c clt
)
206 | PC.TMetaErr
(_
,_
,_
,clt
) -> "errmeta"^
(line_type2c clt
)
207 | PC.TMetaExp
(_
,_
,_
,_
,clt
) -> "expmeta"^
(line_type2c clt
)
208 | PC.TMetaIdExp
(_
,_
,_
,_
,clt
) -> "idexpmeta"^
(line_type2c clt
)
209 | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
) -> "localidexpmeta"^
(line_type2c clt
)
210 | PC.TMetaExpList
(_
,_
,_
,clt
) -> "explistmeta"^
(line_type2c clt
)
211 | PC.TMetaId
(nm
,_
,_
,_
,clt
) -> "idmeta-"^
(Dumper.dump nm
)^
(line_type2c clt
)
212 | PC.TMetaType
(_
,_
,clt
) -> "typemeta"^
(line_type2c clt
)
213 | PC.TMetaInit
(_
,_
,clt
) -> "initmeta"^
(line_type2c clt
)
214 | PC.TMetaInitList
(_
,_
,_
,clt
) -> "initlistmeta"^
(line_type2c clt
)
215 | PC.TMetaDecl
(_
,_
,clt
) -> "declmeta"^
(line_type2c clt
)
216 | PC.TMetaField
(_
,_
,clt
) -> "fieldmeta"^
(line_type2c clt
)
217 | PC.TMetaFieldList
(_
,_
,_
,clt
) -> "fieldlistmeta"^
(line_type2c clt
)
218 | PC.TMetaStm
(_
,_
,clt
) -> "stmmeta"^
(line_type2c clt
)
219 | PC.TMetaStmList
(_
,_
,clt
) -> "stmlistmeta"^
(line_type2c clt
)
220 | PC.TMetaFunc
(_
,_
,_
,clt
) -> "funcmeta"^
(line_type2c clt
)
221 | PC.TMetaLocalFunc
(_
,_
,_
,clt
) -> "funcmeta"^
(line_type2c clt
)
222 | PC.TMetaPos
(_
,_
,_
,clt
) -> "posmeta"
224 | PC.TArobArob
-> "@@"
226 | PC.TPArob clt
-> "P@"
227 | PC.TScript
-> "script"
228 | PC.TInitialize
-> "initialize"
229 | PC.TFinalize
-> "finalize"
231 | PC.TWhen
(clt
) -> "WHEN"^
(line_type2c clt
)
232 | PC.TWhenTrue
(clt
) -> "WHEN TRUE"^
(line_type2c clt
)
233 | PC.TWhenFalse
(clt
) -> "WHEN FALSE"^
(line_type2c clt
)
234 | PC.TAny
(clt
) -> "ANY"^
(line_type2c clt
)
235 | PC.TStrict
(clt
) -> "STRICT"^
(line_type2c clt
)
236 | PC.TEllipsis
(clt
) -> "..."^
(line_type2c clt
)
238 | PC.TCircles(clt) -> "ooo"^(line_type2c clt)
239 | PC.TStars(clt) -> "***"^(line_type2c clt)
242 | PC.TOEllipsis
(clt
) -> "<..."^
(line_type2c clt
)
243 | PC.TCEllipsis
(clt
) -> "...>"^
(line_type2c clt
)
244 | PC.TPOEllipsis
(clt
) -> "<+..."^
(line_type2c clt
)
245 | PC.TPCEllipsis
(clt
) -> "...+>"^
(line_type2c clt
)
247 | PC.TOCircles(clt) -> "<ooo"^(line_type2c clt)
248 | PC.TCCircles(clt) -> "ooo>"^(line_type2c clt)
249 | PC.TOStars(clt) -> "<***"^(line_type2c clt)
250 | PC.TCStars(clt) -> "***>"^(line_type2c clt)
256 | PC.TWhy
(clt
) -> "?"^
(line_type2c clt
)
257 | PC.TDotDot
(clt
) -> ":"^
(line_type2c clt
)
258 | PC.TBang
(clt
) -> "!"^
(line_type2c clt
)
259 | PC.TOPar
(clt
) -> "("^
(line_type2c clt
)
260 | PC.TOPar0
(clt
) -> "("^
(line_type2c clt
)
261 | PC.TMid0
(clt
) -> "|"^
(line_type2c clt
)
262 | PC.TCPar
(clt
) -> ")"^
(line_type2c clt
)
263 | PC.TCPar0
(clt
) -> ")"^
(line_type2c clt
)
265 | PC.TOBrace
(clt
) -> "{"^
(line_type2c clt
)
266 | PC.TCBrace
(clt
) -> "}"^
(line_type2c clt
)
267 | PC.TOCro
(clt
) -> "["^
(line_type2c clt
)
268 | PC.TCCro
(clt
) -> "]"^
(line_type2c clt
)
269 | PC.TOInit
(clt
) -> "{"^
(line_type2c clt
)
271 | PC.TPtrOp
(clt
) -> "->"^
(line_type2c clt
)
273 | PC.TEq
(clt
) -> "="^
(line_type2c clt
)
274 | PC.TAssign
(_
,clt
) -> "=op"^
(line_type2c clt
)
275 | PC.TDot
(clt
) -> "."^
(line_type2c clt
)
276 | PC.TComma
(clt
) -> ","^
(line_type2c clt
)
277 | PC.TPtVirg
(clt
) -> ";"^
(line_type2c clt
)
280 | PC.TLineEnd
(clt
) -> "line end"
281 | PC.TInvalid
-> "invalid"
282 | PC.TFunDecl
(clt
) -> "fundecl"
285 | PC.TRightIso
-> "=>"
286 | PC.TIsoTopLevel
-> "TopLevel"
287 | PC.TIsoExpression
-> "Expression"
288 | PC.TIsoArgExpression
-> "ArgExpression"
289 | PC.TIsoTestExpression
-> "TestExpression"
290 | PC.TIsoToTestExpression
-> "ToTestExpression"
291 | PC.TIsoStatement
-> "Statement"
292 | PC.TIsoDeclaration
-> "Declaration"
293 | PC.TIsoType
-> "Type"
294 | PC.TUnderscore
-> "_"
295 | PC.TScriptData s
-> s
297 let print_tokens s tokens
=
298 Printf.printf
"%s\n" s
;
299 List.iter
(function x
-> Printf.printf
"|%s| " (token2c x
)) tokens
;
300 Printf.printf
"\n\n";
303 type plus
= PLUS
| NOTPLUS
| SKIP
305 let plus_attachable only_plus
(tok
,_
) =
307 PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
308 | PC.Tfloat
(clt
) | PC.Tlong
(clt
)
309 | PC.Tsize_t
(clt
) | PC.Tssize_t
(clt
) | PC.Tptrdiff_t
(clt
)
311 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
313 | PC.Tinline
(clt
) | PC.Ttypedef
(clt
) | PC.Tattr
(_
,clt
)
314 | PC.Tauto
(clt
) | PC.Tregister
(clt
)
315 | PC.Textern
(clt
) | PC.Tconst
(clt
) | PC.Tvolatile
(clt
)
317 | PC.TIncludeL
(_
,clt
) | PC.TIncludeNL
(_
,clt
) | PC.TUndef
(clt
,_
)
319 | PC.TDefineParam
(clt
,_
,_
,_
) | PC.TMinusFile
(_
,clt
) | PC.TPlusFile
(_
,clt
)
321 | PC.TInc
(clt
) | PC.TDec
(clt
)
323 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
324 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
) | PC.TReturn
(clt
)
325 | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
) | PC.TIdent
(_
,clt
)
326 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
330 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
)
332 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
333 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TTildeEq
(clt
)
335 | PC.TShLOp
(_
,clt
) | PC.TShROp
(_
,clt
)
336 | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
337 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
)
339 | PC.TMeta
(_
,_
,clt
) | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
340 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaErr
(_
,_
,_
,clt
)
341 | PC.TMetaExp
(_
,_
,_
,_
,clt
) | PC.TMetaIdExp
(_
,_
,_
,_
,clt
)
342 | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
343 | PC.TMetaExpList
(_
,_
,_
,clt
)
344 | PC.TMetaId
(_
,_
,_
,_
,clt
)
345 | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
) | PC.TMetaInitList
(_
,_
,_
,clt
)
346 | PC.TMetaStm
(_
,_
,clt
)
347 | PC.TMetaStmList
(_
,_
,clt
)
348 | PC.TMetaDecl
(_
,_
,clt
) | PC.TMetaField
(_
,_
,clt
)
349 | PC.TMetaFieldList
(_
,_
,_
,clt
)
350 | PC.TMetaFunc
(_
,_
,_
,clt
) | PC.TMetaLocalFunc
(_
,_
,_
,clt
)
352 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
)
353 | PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TEllipsis
(clt
)
354 (* | PC.TCircles(clt) | PC.TStars(clt) *)
355 | PC.TOEllipsis
(clt
) | PC.TCEllipsis
(clt
)
356 | PC.TPOEllipsis
(clt
) | PC.TPCEllipsis
(clt
) (* | PC.TOCircles(clt)
357 | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *)
359 | PC.TWhy
(clt
) | PC.TDotDot
(clt
) | PC.TBang
(clt
) | PC.TOPar
(clt
)
362 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOCro
(clt
) | PC.TCCro
(clt
)
367 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
369 if List.mem
(line_type clt
) [D.PLUS
;D.PLUSPLUS
]
371 else if only_plus
then NOTPLUS
372 else if line_type clt
= D.CONTEXT
then PLUS
else NOTPLUS
374 | PC.TOPar0
(clt
) | PC.TMid0
(clt
) | PC.TCPar0
(clt
) -> NOTPLUS
375 | PC.TMetaPos
(nm
,_
,_
,_
) -> NOTPLUS
376 | PC.TSub
(clt
) -> NOTPLUS
380 let get_clt (tok
,_
) =
382 PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
383 | PC.Tfloat
(clt
) | PC.Tlong
(clt
) | PC.Tvoid
(clt
)
384 | PC.Tsize_t
(clt
) | PC.Tssize_t
(clt
) | PC.Tptrdiff_t
(clt
)
386 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
388 | PC.Tinline
(clt
) | PC.Tattr
(_
,clt
) | PC.Tauto
(clt
) | PC.Tregister
(clt
)
389 | PC.Textern
(clt
) | PC.Tconst
(clt
) | PC.Tvolatile
(clt
)
391 | PC.TIncludeL
(_
,clt
) | PC.TIncludeNL
(_
,clt
) | PC.TUndef
(clt
,_
)
393 | PC.TDefineParam
(clt
,_
,_
,_
) | PC.TMinusFile
(_
,clt
) | PC.TPlusFile
(_
,clt
)
395 | PC.TInc
(clt
) | PC.TDec
(clt
)
397 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
398 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
) | PC.TReturn
(clt
)
399 | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
) | PC.TIdent
(_
,clt
)
400 | PC.TTypeId
(_
,clt
) | PC.TSymId
(_
,clt
)
401 | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
405 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
)
407 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
408 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TTildeEq
(clt
)
409 | PC.TSub
(clt
) | PC.TLogOp
(_
,clt
)
410 | PC.TShLOp
(_
,clt
) | PC.TShROp
(_
,clt
)
411 | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
412 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
)
414 | PC.TMeta
(_
,_
,clt
) | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
415 | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaErr
(_
,_
,_
,clt
)
416 | PC.TMetaExp
(_
,_
,_
,_
,clt
) | PC.TMetaIdExp
(_
,_
,_
,_
,clt
)
417 | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
418 | PC.TMetaExpList
(_
,_
,_
,clt
)
419 | PC.TMetaId
(_
,_
,_
,_
,clt
)
420 | PC.TMetaType
(_
,_
,clt
) | PC.TMetaInit
(_
,_
,clt
) | PC.TMetaInitList
(_
,_
,_
,clt
)
421 | PC.TMetaStm
(_
,_
,clt
)
422 | PC.TMetaStmList
(_
,_
,clt
)
423 | PC.TMetaDecl
(_
,_
,clt
) | PC.TMetaField
(_
,_
,clt
)
424 | PC.TMetaFieldList
(_
,_
,_
,clt
)
425 | PC.TMetaFunc
(_
,_
,_
,clt
) | PC.TMetaLocalFunc
(_
,_
,_
,clt
)
426 | PC.TMetaPos
(_
,_
,_
,clt
)
427 | PC.TMetaDeclarer
(_
,_
,_
,clt
) | PC.TMetaIterator
(_
,_
,_
,clt
)
429 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
) |
430 PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TEllipsis
(clt
)
431 (* | PC.TCircles(clt) | PC.TStars(clt) *)
433 | PC.TWhy
(clt
) | PC.TDotDot
(clt
) | PC.TBang
(clt
) | PC.TOPar
(clt
)
436 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOCro
(clt
) | PC.TCCro
(clt
)
441 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
442 | PC.TPArob
(clt
) | PC.TPtVirg
(clt
)
444 | PC.TOPar0
(clt
) | PC.TMid0
(clt
) | PC.TCPar0
(clt
)
445 | PC.TOEllipsis
(clt
) | PC.TCEllipsis
(clt
)
446 | PC.TPOEllipsis
(clt
) | PC.TPCEllipsis
(clt
) (* | PC.TOCircles(clt)
447 | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *) -> clt
449 | _
-> failwith
"no clt"
451 let update_clt (tok
,x
) clt
=
453 PC.Tchar
(_
) -> (PC.Tchar
(clt
),x
)
454 | PC.Tshort
(_
) -> (PC.Tshort
(clt
),x
)
455 | PC.Tint
(_
) -> (PC.Tint
(clt
),x
)
456 | PC.Tdouble
(_
) -> (PC.Tdouble
(clt
),x
)
457 | PC.Tfloat
(_
) -> (PC.Tfloat
(clt
),x
)
458 | PC.Tlong
(_
) -> (PC.Tlong
(clt
),x
)
459 | PC.Tvoid
(_
) -> (PC.Tvoid
(clt
),x
)
460 | PC.Tsize_t
(_
) -> (PC.Tsize_t
(clt
),x
)
461 | PC.Tssize_t
(_
) -> (PC.Tssize_t
(clt
),x
)
462 | PC.Tptrdiff_t
(_
) -> (PC.Tptrdiff_t
(clt
),x
)
463 | PC.Tstruct
(_
) -> (PC.Tstruct
(clt
),x
)
464 | PC.Tunion
(_
) -> (PC.Tunion
(clt
),x
)
465 | PC.Tenum
(_
) -> (PC.Tenum
(clt
),x
)
466 | PC.Tunsigned
(_
) -> (PC.Tunsigned
(clt
),x
)
467 | PC.Tsigned
(_
) -> (PC.Tsigned
(clt
),x
)
468 | PC.Tstatic
(_
) -> (PC.Tstatic
(clt
),x
)
469 | PC.Tinline
(_
) -> (PC.Tinline
(clt
),x
)
470 | PC.Ttypedef
(_
) -> (PC.Ttypedef
(clt
),x
)
471 | PC.Tattr
(s
,_
) -> (PC.Tattr
(s
,clt
),x
)
472 | PC.Tauto
(_
) -> (PC.Tauto
(clt
),x
)
473 | PC.Tregister
(_
) -> (PC.Tregister
(clt
),x
)
474 | PC.Textern
(_
) -> (PC.Textern
(clt
),x
)
475 | PC.Tconst
(_
) -> (PC.Tconst
(clt
),x
)
476 | PC.Tvolatile
(_
) -> (PC.Tvolatile
(clt
),x
)
478 | PC.TIncludeL
(s
,_
) -> (PC.TIncludeL
(s
,clt
),x
)
479 | PC.TIncludeNL
(s
,_
) -> (PC.TIncludeNL
(s
,clt
),x
)
480 | PC.TUndef
(_
,a
) -> (PC.TUndef
(clt
,a
),x
)
481 | PC.TDefine
(_
,a
) -> (PC.TDefine
(clt
,a
),x
)
482 | PC.TDefineParam
(_
,a
,b
,c
) -> (PC.TDefineParam
(clt
,a
,b
,c
),x
)
483 | PC.TMinusFile
(s
,_
) -> (PC.TMinusFile
(s
,clt
),x
)
484 | PC.TPlusFile
(s
,_
) -> (PC.TPlusFile
(s
,clt
),x
)
486 | PC.TInc
(_
) -> (PC.TInc
(clt
),x
)
487 | PC.TDec
(_
) -> (PC.TDec
(clt
),x
)
489 | PC.TIf
(_
) -> (PC.TIf
(clt
),x
)
490 | PC.TElse
(_
) -> (PC.TElse
(clt
),x
)
491 | PC.TWhile
(_
) -> (PC.TWhile
(clt
),x
)
492 | PC.TFor
(_
) -> (PC.TFor
(clt
),x
)
493 | PC.TDo
(_
) -> (PC.TDo
(clt
),x
)
494 | PC.TSwitch
(_
) -> (PC.TSwitch
(clt
),x
)
495 | PC.TCase
(_
) -> (PC.TCase
(clt
),x
)
496 | PC.TDefault
(_
) -> (PC.TDefault
(clt
),x
)
497 | PC.TReturn
(_
) -> (PC.TReturn
(clt
),x
)
498 | PC.TBreak
(_
) -> (PC.TBreak
(clt
),x
)
499 | PC.TContinue
(_
) -> (PC.TContinue
(clt
),x
)
500 | PC.TGoto
(_
) -> (PC.TGoto
(clt
),x
)
501 | PC.TIdent
(s
,_
) -> (PC.TIdent
(s
,clt
),x
)
502 | PC.TTypeId
(s
,_
) -> (PC.TTypeId
(s
,clt
),x
)
503 | PC.TDeclarerId
(s
,_
) -> (PC.TDeclarerId
(s
,clt
),x
)
504 | PC.TIteratorId
(s
,_
) -> (PC.TIteratorId
(s
,clt
),x
)
505 | PC.TSymId
(a
,_
) -> (PC.TSymId
(a
,clt
),x
)
507 | PC.TSizeof
(_
) -> (PC.TSizeof
(clt
),x
)
509 | PC.TString
(s
,_
) -> (PC.TString
(s
,clt
),x
)
510 | PC.TChar
(s
,_
) -> (PC.TChar
(s
,clt
),x
)
511 | PC.TFloat
(s
,_
) -> (PC.TFloat
(s
,clt
),x
)
512 | PC.TInt
(s
,_
) -> (PC.TInt
(s
,clt
),x
)
514 | PC.TOrLog
(_
) -> (PC.TOrLog
(clt
),x
)
515 | PC.TAndLog
(_
) -> (PC.TAndLog
(clt
),x
)
516 | PC.TOr
(_
) -> (PC.TOr
(clt
),x
)
517 | PC.TXor
(_
) -> (PC.TXor
(clt
),x
)
518 | PC.TAnd
(_
) -> (PC.TAnd
(clt
),x
)
519 | PC.TEqEq
(_
) -> (PC.TEqEq
(clt
),x
)
520 | PC.TNotEq
(_
) -> (PC.TNotEq
(clt
),x
)
521 | PC.TTildeEq
(_
) -> (PC.TTildeEq
(clt
),x
)
522 | PC.TSub
(_
) -> (PC.TSub
(clt
),x
)
523 | PC.TLogOp
(op
,_
) -> (PC.TLogOp
(op
,clt
),x
)
524 | PC.TShLOp
(op
,_
) -> (PC.TShLOp
(op
,clt
),x
)
525 | PC.TShROp
(op
,_
) -> (PC.TShROp
(op
,clt
),x
)
526 | PC.TPlus
(_
) -> (PC.TPlus
(clt
),x
)
527 | PC.TMinus
(_
) -> (PC.TMinus
(clt
),x
)
528 | PC.TMul
(_
) -> (PC.TMul
(clt
),x
)
529 | PC.TDmOp
(op
,_
) -> (PC.TDmOp
(op
,clt
),x
)
530 | PC.TTilde
(_
) -> (PC.TTilde
(clt
),x
)
532 | PC.TMeta
(a
,b
,_
) -> (PC.TMeta
(a
,b
,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
,d
,_
) -> (PC.TMetaId
(a
,b
,c
,d
,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.TMetaInitList
(a
,b
,c
,_
) -> (PC.TMetaInitList
(a
,b
,c
,clt
),x
)
545 | PC.TMetaDecl
(a
,b
,_
) -> (PC.TMetaDecl
(a
,b
,clt
),x
)
546 | PC.TMetaField
(a
,b
,_
) -> (PC.TMetaField
(a
,b
,clt
),x
)
547 | PC.TMetaFieldList
(a
,b
,c
,_
) -> (PC.TMetaFieldList
(a
,b
,c
,clt
),x
)
548 | PC.TMetaStm
(a
,b
,_
) -> (PC.TMetaStm
(a
,b
,clt
),x
)
549 | PC.TMetaStmList
(a
,b
,_
) -> (PC.TMetaStmList
(a
,b
,clt
),x
)
550 | PC.TMetaFunc
(a
,b
,c
,_
) -> (PC.TMetaFunc
(a
,b
,c
,clt
),x
)
551 | PC.TMetaLocalFunc
(a
,b
,c
,_
) -> (PC.TMetaLocalFunc
(a
,b
,c
,clt
),x
)
553 | PC.TMetaDeclarer
(a
,b
,c
,_
) -> (PC.TMetaDeclarer
(a
,b
,c
,clt
),x
)
554 | PC.TMetaIterator
(a
,b
,c
,_
) -> (PC.TMetaIterator
(a
,b
,c
,clt
),x
)
556 | PC.TWhen
(_
) -> (PC.TWhen
(clt
),x
)
557 | PC.TWhenTrue
(_
) -> (PC.TWhenTrue
(clt
),x
)
558 | PC.TWhenFalse
(_
) -> (PC.TWhenFalse
(clt
),x
)
559 | PC.TAny
(_
) -> (PC.TAny
(clt
),x
)
560 | PC.TStrict
(_
) -> (PC.TStrict
(clt
),x
)
561 | PC.TEllipsis
(_
) -> (PC.TEllipsis
(clt
),x
)
563 | PC.TCircles(_) -> (PC.TCircles(clt),x)
564 | PC.TStars(_) -> (PC.TStars(clt),x)
567 | PC.TOEllipsis
(_
) -> (PC.TOEllipsis
(clt
),x
)
568 | PC.TCEllipsis
(_
) -> (PC.TCEllipsis
(clt
),x
)
569 | PC.TPOEllipsis
(_
) -> (PC.TPOEllipsis
(clt
),x
)
570 | PC.TPCEllipsis
(_
) -> (PC.TPCEllipsis
(clt
),x
)
572 | PC.TOCircles(_) -> (PC.TOCircles(clt),x)
573 | PC.TCCircles(_) -> (PC.TCCircles(clt),x)
574 | PC.TOStars(_) -> (PC.TOStars(clt),x)
575 | PC.TCStars(_) -> (PC.TCStars(clt),x)
578 | PC.TWhy
(_
) -> (PC.TWhy
(clt
),x
)
579 | PC.TDotDot
(_
) -> (PC.TDotDot
(clt
),x
)
580 | PC.TBang
(_
) -> (PC.TBang
(clt
),x
)
581 | PC.TOPar
(_
) -> (PC.TOPar
(clt
),x
)
582 | PC.TOPar0
(_
) -> (PC.TOPar0
(clt
),x
)
583 | PC.TMid0
(_
) -> (PC.TMid0
(clt
),x
)
584 | PC.TCPar
(_
) -> (PC.TCPar
(clt
),x
)
585 | PC.TCPar0
(_
) -> (PC.TCPar0
(clt
),x
)
587 | PC.TOBrace
(_
) -> (PC.TOBrace
(clt
),x
)
588 | PC.TCBrace
(_
) -> (PC.TCBrace
(clt
),x
)
589 | PC.TOCro
(_
) -> (PC.TOCro
(clt
),x
)
590 | PC.TCCro
(_
) -> (PC.TCCro
(clt
),x
)
591 | PC.TOInit
(_
) -> (PC.TOInit
(clt
),x
)
593 | PC.TPtrOp
(_
) -> (PC.TPtrOp
(clt
),x
)
595 | PC.TEq
(_
) -> (PC.TEq
(clt
),x
)
596 | PC.TAssign
(s
,_
) -> (PC.TAssign
(s
,clt
),x
)
597 | PC.TDot
(_
) -> (PC.TDot
(clt
),x
)
598 | PC.TComma
(_
) -> (PC.TComma
(clt
),x
)
599 | PC.TPArob
(_
) -> (PC.TPArob
(clt
),x
)
600 | PC.TPtVirg
(_
) -> (PC.TPtVirg
(clt
),x
)
602 | PC.TLineEnd
(_
) -> (PC.TLineEnd
(clt
),x
)
603 | PC.TFunDecl
(_
) -> (PC.TFunDecl
(clt
),x
)
605 | _
-> failwith
"no clt"
608 (* ----------------------------------------------------------------------- *)
610 let make_name prefix ln
= Printf.sprintf
"%s starting on line %d" prefix ln
612 (* ----------------------------------------------------------------------- *)
615 let wrap_lexbuf_info lexbuf
=
616 (Lexing.lexeme lexbuf
, Lexing.lexeme_start lexbuf
)
618 let tokens_all_full token table file get_ats lexbuf end_markers
:
619 (bool * ((PC.token
* (string * (int * int) * (int * int))) list
)) =
622 let result = token lexbuf
in
623 let info = (Lexing.lexeme lexbuf
,
624 (table
.(Lexing.lexeme_start lexbuf
)),
625 (Lexing.lexeme_start lexbuf
, Lexing.lexeme_end lexbuf
)) in
629 then failwith
"unexpected end of file in a metavariable declaration"
630 else (false,[(result,info)])
631 else if List.mem
result end_markers
632 then (true,[(result,info)])
634 let (more
,rest
) = aux() in
635 (more
,(result, info)::rest
)
638 e
-> pr2 (Common.error_message file
(wrap_lexbuf_info lexbuf
) ); raise e
640 let tokens_all table file get_ats lexbuf end_markers
:
641 (bool * ((PC.token
* (string * (int * int) * (int * int))) list
)) =
642 tokens_all_full Lexer_cocci.token table file get_ats lexbuf end_markers
644 let tokens_script_all table file get_ats lexbuf end_markers
:
645 (bool * ((PC.token
* (string * (int * int) * (int * int))) list
)) =
646 tokens_all_full Lexer_script.token table file get_ats lexbuf end_markers
648 (* ----------------------------------------------------------------------- *)
649 (* Split tokens into minus and plus fragments *)
652 let (d
,_
,_
,_
,_
,_
,_
,_
) = clt
in
654 D.MINUS
| D.OPTMINUS
| D.UNIQUEMINUS
-> ([t
],[])
655 | D.PLUS
| D.PLUSPLUS
-> ([],[t
])
656 | D.CONTEXT
| D.UNIQUE
| D.OPT
-> ([t
],[t
])
658 let split_token ((tok
,_
) as t
) =
660 PC.TMetavariable
| PC.TIdentifier
661 | PC.TConstant
| PC.TExpression
| PC.TIdExpression
662 | PC.TDeclaration
| PC.TField
663 | PC.TStatement
| PC.TPosition
| PC.TPosAny
| PC.TInitialiser
| PC.TSymbol
664 | PC.TFunction
| PC.TTypedef
| PC.TDeclarer
| PC.TIterator
| PC.TName
665 | PC.TType
| PC.TParameter
| PC.TLocal
| PC.Tlist
| PC.TFresh
666 | PC.TCppConcatOp
| PC.TPure
667 | PC.TContext
| PC.TRuleName
(_
) | PC.TUsing
| PC.TVirtual
| PC.TDisable
668 | PC.TExtends
| PC.TPathIsoFile
(_
)
669 | PC.TDepends
| PC.TOn
| PC.TEver
| PC.TNever
| PC.TExists
| PC.TForall
670 | PC.TError
| PC.TWords
| PC.TGenerated
| PC.TNothing
-> ([t
],[t
])
672 | PC.Tchar
(clt
) | PC.Tshort
(clt
) | PC.Tint
(clt
) | PC.Tdouble
(clt
)
673 | PC.Tfloat
(clt
) | PC.Tlong
(clt
) | PC.Tvoid
(clt
)
674 | PC.Tsize_t
(clt
) | PC.Tssize_t
(clt
) | PC.Tptrdiff_t
(clt
)
676 | PC.Tunion
(clt
) | PC.Tenum
(clt
) | PC.Tunsigned
(clt
) | PC.Tsigned
(clt
)
677 | PC.Tstatic
(clt
) | PC.Tauto
(clt
) | PC.Tregister
(clt
) | PC.Textern
(clt
)
678 | PC.Tinline
(clt
) | PC.Ttypedef
(clt
) | PC.Tattr
(_
,clt
)
679 | PC.Tconst
(clt
) | PC.Tvolatile
(clt
) -> split t clt
681 | PC.TPragma
(s
,_
) -> ([],[t
]) (* only allowed in + *)
682 | PC.TPlusFile
(s
,clt
) | PC.TMinusFile
(s
,clt
)
683 | PC.TIncludeL
(s
,clt
) | PC.TIncludeNL
(s
,clt
) ->
685 | PC.TUndef
(clt
,_
) | PC.TDefine
(clt
,_
) | PC.TDefineParam
(clt
,_
,_
,_
) ->
688 | PC.TIf
(clt
) | PC.TElse
(clt
) | PC.TWhile
(clt
) | PC.TFor
(clt
) | PC.TDo
(clt
)
689 | PC.TSwitch
(clt
) | PC.TCase
(clt
) | PC.TDefault
(clt
)
691 | PC.TReturn
(clt
) | PC.TBreak
(clt
) | PC.TContinue
(clt
) | PC.TGoto
(clt
)
693 | PC.TTypeId
(_
,clt
) | PC.TDeclarerId
(_
,clt
) | PC.TIteratorId
(_
,clt
)
695 | PC.TMeta
(_
,_
,clt
) | PC.TMetaConst
(_
,_
,_
,_
,clt
) | PC.TMetaExp
(_
,_
,_
,_
,clt
)
696 | PC.TMetaIdExp
(_
,_
,_
,_
,clt
) | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt
)
697 | PC.TMetaExpList
(_
,_
,_
,clt
)
698 | PC.TMetaParam
(_
,_
,clt
) | PC.TMetaParamList
(_
,_
,_
,clt
)
699 | PC.TMetaId
(_
,_
,_
,_
,clt
) | PC.TMetaType
(_
,_
,clt
)
700 | PC.TMetaInit
(_
,_
,clt
) | PC.TMetaInitList
(_
,_
,_
,clt
)
701 | PC.TMetaDecl
(_
,_
,clt
) | PC.TMetaField
(_
,_
,clt
)
702 | PC.TMetaFieldList
(_
,_
,_
,clt
)
703 | PC.TMetaStm
(_
,_
,clt
) | PC.TMetaStmList
(_
,_
,clt
) | PC.TMetaErr
(_
,_
,_
,clt
)
704 | PC.TMetaFunc
(_
,_
,_
,clt
) | PC.TMetaLocalFunc
(_
,_
,_
,clt
)
705 | PC.TMetaDeclarer
(_
,_
,_
,clt
) | PC.TMetaIterator
(_
,_
,_
,clt
) -> split t clt
706 | PC.TMPtVirg
| PC.TArob
| PC.TArobArob
| PC.TScript
707 | PC.TInitialize
| PC.TFinalize
-> ([t
],[t
])
708 | PC.TPArob clt
| PC.TMetaPos
(_
,_
,_
,clt
) -> split t clt
711 | PC.TWhen
(clt
) | PC.TWhenTrue
(clt
) | PC.TWhenFalse
(clt
)
712 | PC.TAny
(clt
) | PC.TStrict
(clt
) | PC.TLineEnd
(clt
)
713 | PC.TEllipsis
(clt
) (* | PC.TCircles(clt) | PC.TStars(clt) *)
714 | PC.TOEllipsis
(clt
) | PC.TCEllipsis
(clt
)
715 | PC.TPOEllipsis
(clt
) | PC.TPCEllipsis
(clt
) -> split t clt
718 | PC.TOCircles(_) | PC.TCCircles(_) (* clt must be context *)
719 | PC.TOStars
(_
) | PC.TCStars
(_
) (* clt must be context *)
722 | PC.TBang0
| PC.TPlus0
| PC.TWhy0
->
725 | PC.TWhy
(clt
) | PC.TDotDot
(clt
)
726 | PC.TBang
(clt
) | PC.TOPar
(clt
) | PC.TOPar0
(clt
)
727 | PC.TMid0
(clt
) | PC.TCPar
(clt
) | PC.TCPar0
(clt
) -> split t clt
729 | PC.TInc
(clt
) | PC.TDec
(clt
) -> split t clt
731 | PC.TString
(_
,clt
) | PC.TChar
(_
,clt
) | PC.TFloat
(_
,clt
) | PC.TInt
(_
,clt
) ->
734 | PC.TOrLog
(clt
) | PC.TAndLog
(clt
) | PC.TOr
(clt
) | PC.TXor
(clt
)
735 | PC.TAnd
(clt
) | PC.TEqEq
(clt
) | PC.TNotEq
(clt
) | PC.TTildeEq
(clt
)
736 | PC.TTildeExclEq
(clt
) | PC.TSub
(clt
) | PC.TLogOp
(_
,clt
)
737 | PC.TShLOp
(_
,clt
) | PC.TShROp
(_
,clt
)
738 | PC.TPlus
(clt
) | PC.TMinus
(clt
) | PC.TMul
(clt
)
739 | PC.TDmOp
(_
,clt
) | PC.TTilde
(clt
) -> split t clt
741 | PC.TOBrace
(clt
) | PC.TCBrace
(clt
) | PC.TOInit
(clt
) -> split t clt
742 | PC.TOCro
(clt
) | PC.TCCro
(clt
) -> split t clt
744 | PC.TPtrOp
(clt
) -> split t clt
746 | PC.TEq
(clt
) | PC.TAssign
(_
,clt
) | PC.TDot
(clt
) | PC.TComma
(clt
)
747 | PC.TPtVirg
(clt
) -> split t clt
749 | PC.EOF
| PC.TInvalid
| PC.TUnderscore
-> ([t
],[t
])
751 | PC.TIso
| PC.TRightIso
752 | PC.TIsoExpression
| PC.TIsoStatement
| PC.TIsoDeclaration
| PC.TIsoType
753 | PC.TIsoTopLevel
| PC.TIsoArgExpression
| PC.TIsoTestExpression
754 | PC.TIsoToTestExpression
->
755 failwith
"unexpected tokens"
756 | PC.TScriptData s
-> ([t
],[t
])
758 let split_token_stream tokens
=
759 let rec loop = function
762 let (minus
,plus
) = split_token token
in
763 let (minus_stream
,plus_stream
) = loop tokens
in
764 (minus
@minus_stream
,plus
@plus_stream
) in
767 (* ----------------------------------------------------------------------- *)
768 (* Find function names *)
769 (* This addresses a shift-reduce problem in the parser, allowing us to
770 distinguish a function declaration from a function call even if the latter
771 has no return type. Undoubtedly, this is not very nice, but it doesn't
772 seem very convenient to refactor the grammar to get around the problem. *)
776 let rec find_function_names l
=
777 let is_ident = function
778 (PC.TIdent
(_
,clt
),info)
779 | (PC.TMeta
(_
,_
,clt
),info)
780 | (PC.TMetaId
(_
,_
,_
,_
,clt
),info)
781 | (PC.TMetaFunc
(_
,_
,_
,clt
),info)
782 | (PC.TMetaLocalFunc
(_
,_
,_
,clt
),info) -> true
784 let is_mid = function
785 (PC.TMid0
(_
),info) -> true
787 let is_par = function
788 (PC.TOPar0
(_
),info) -> true
790 let rec split acc
= function
791 [] | [_
] -> raise Irrelevant
792 | ((PC.TCPar
(_
),_
) as t1
) :: ((PC.TOBrace
(_
),_
) as t2
) :: rest
->
793 (List.rev
(t1
::acc
),(t2
::rest
))
794 | x
::xs
-> split (x
::acc
) xs
in
795 let rec balanced_name level
= function
796 [] -> raise Irrelevant
797 | (PC.TCPar0
(_
),_
)::rest
->
798 let level = level - 1 in
801 else balanced_name level rest
802 | (PC.TOPar0
(_
),_
)::rest
->
803 let level = level + 1 in
804 balanced_name level rest
805 | (PC.TArobArob
,_
)::_
| (PC.TArob
,_
)::_
| (PC.EOF
,_
)::_
->
807 | t
::rest
when is_ident t
&& level = 0 -> rest
808 | t
::rest
when is_ident t
or is_mid t
-> balanced_name level rest
809 | _
-> raise Irrelevant
in
810 let rec balanced_args level = function
811 [] -> raise Irrelevant
812 | (PC.TCPar
(_
),_
)::rest
->
813 let level = level - 1 in
816 else balanced_args level rest
817 | (PC.TOPar
(_
),_
)::rest
->
818 let level = level + 1 in
819 balanced_args level rest
820 | (PC.TArobArob
,_
)::_
| (PC.TArob
,_
)::_
| (PC.EOF
,_
)::_
->
822 | t
::rest
-> balanced_args level rest
in
823 let rec loop = function
826 if is_par t
or is_mid t
or is_ident t
830 let (bef
,aft
) = split [] (t
::rest
) in
831 let rest = balanced_name 0 bef
in
833 (PC.TOPar
(_
),_
)::_
->
834 (match balanced_args 0 rest with
836 let (_
,info) as h
= List.hd bef
in
837 let clt = get_clt h
in
838 (((PC.TFunDecl
(clt),info) :: bef
), aft
)
839 | _
-> raise Irrelevant
)
840 | _
-> raise Irrelevant
)
841 with Irrelevant
-> ([t
],rest) in
843 else t
:: (loop rest) in
846 (* ----------------------------------------------------------------------- *)
847 (* an attribute is an identifier that preceeds another identifier and
850 let rec detect_attr l
=
852 (PC.TIdent
(_
,_
),_
) | (PC.TMetaId
(_
,_
,_
,_
,_
),_
) | (PC.TMetaFunc
(_
,_
,_
,_
),_
)
853 | (PC.TMetaLocalFunc
(_
,_
,_
,_
),_
) -> true
855 let rec loop = function
858 | ((PC.TIdent
(nm
,clt),info) as t1
)::id
::rest when is_id id
->
859 if String.length nm
> 2 && String.sub nm
0 2 = "__"
860 then (PC.Tattr
(nm
,clt),info)::(loop (id
::rest))
861 else t1
::(loop (id
::rest))
862 | x
::xs
-> x
::(loop xs
) in
865 (* ----------------------------------------------------------------------- *)
866 (* Look for variable declarations where the name is a typedef name.
867 We assume that C code does not contain a multiplication as a top-level
870 (* bug: once a type, always a type, even if the same name is later intended
871 to be used as a real identifier *)
872 let detect_types in_meta_decls l
=
873 let is_delim infn
= function
874 (PC.TOEllipsis
(_
),_
) (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *)
875 | (PC.TPOEllipsis
(_
),_
) (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *)
876 | (PC.TEllipsis
(_
),_
) (* | (PC.TCircles(_),_) | (PC.TStars(_),_) *)
877 | (PC.TPtVirg
(_
),_
) | (PC.TOBrace
(_
),_
) | (PC.TOInit
(_
),_
)
879 | (PC.TPure
,_
) | (PC.TContext
,_
)
880 | (PC.Tstatic
(_
),_
) | (PC.Textern
(_
),_
)
881 | (PC.Tinline
(_
),_
) | (PC.Ttypedef
(_
),_
) | (PC.Tattr
(_
),_
) -> true
882 | (PC.TComma
(_
),_
) when infn
> 0 or in_meta_decls
-> true
883 | (PC.TDotDot
(_
),_
) when in_meta_decls
-> true
885 let is_choices_delim = function
886 (PC.TOBrace
(_
),_
) | (PC.TComma
(_
),_
) -> true | _
-> false in
888 (PC.TIdent
(_
,_
),_
) | (PC.TMetaId
(_
,_
,_
,_
,_
),_
) | (PC.TMetaFunc
(_
,_
,_
,_
),_
)
889 | (PC.TMetaLocalFunc
(_
,_
,_
,_
),_
) -> true
890 | (PC.TMetaParam
(_
,_
,_
),_
)
891 | (PC.TMetaParamList
(_
,_
,_
,_
),_
)
892 | (PC.TMetaConst
(_
,_
,_
,_
,_
),_
)
893 | (PC.TMetaErr
(_
,_
,_
,_
),_
)
894 | (PC.TMetaExp
(_
,_
,_
,_
,_
),_
)
895 | (PC.TMetaIdExp
(_
,_
,_
,_
,_
),_
)
896 | (PC.TMetaLocalIdExp
(_
,_
,_
,_
,_
),_
)
897 | (PC.TMetaExpList
(_
,_
,_
,_
),_
)
898 | (PC.TMetaType
(_
,_
,_
),_
)
899 | (PC.TMetaInit
(_
,_
,_
),_
)
900 | (PC.TMetaInitList
(_
,_
,_
,_
),_
)
901 | (PC.TMetaDecl
(_
,_
,_
),_
)
902 | (PC.TMetaField
(_
,_
,_
),_
)
903 | (PC.TMetaFieldList
(_
,_
,_
,_
),_
)
904 | (PC.TMetaStm
(_
,_
,_
),_
)
905 | (PC.TMetaStmList
(_
,_
,_
),_
)
906 | (PC.TMetaPos
(_
,_
,_
,_
),_
) -> in_meta_decls
908 let redo_id ident
clt v
=
909 !Data.add_type_name ident
;
910 (PC.TTypeId
(ident
,clt),v
) in
911 let rec loop start infn type_names
= function
912 (* infn: 0 means not in a function header
913 > 0 means in a function header, after infn - 1 unmatched open parens*)
915 | ((PC.TOBrace
(clt),v
)::_
) as all
when in_meta_decls
->
916 collect_choices type_names all
(* never a function header *)
917 | delim
::(PC.TIdent
(ident
,clt),v
)::((PC.TMul
(_
),_
) as x
)::rest
918 when is_delim infn delim
->
919 let newid = redo_id ident
clt v
in
920 delim
::newid::x
::(loop false infn
(ident
::type_names
) rest)
921 | delim
::(PC.TIdent
(ident
,clt),v
)::id
::rest
922 when is_delim infn delim
&& is_id id
->
923 let newid = redo_id ident
clt v
in
924 delim
::newid::id
::(loop false infn
(ident
::type_names
) rest)
925 | ((PC.TFunDecl
(_
),_
) as fn
)::rest ->
926 fn
::(loop false 1 type_names
rest)
927 | ((PC.TOPar
(_
),_
) as lp
)::rest when infn
> 0 ->
928 lp
::(loop false (infn
+ 1) type_names
rest)
929 | ((PC.TCPar
(_
),_
) as rp
)::rest when infn
> 0 ->
931 then rp
::(loop false 0 type_names
rest) (* 0 means not in fn header *)
932 else rp
::(loop false (infn
- 1) type_names
rest)
933 | (PC.TIdent
(ident
,clt),v
)::((PC.TMul
(_
),_
) as x
)::rest when start
->
934 let newid = redo_id ident
clt v
in
935 newid::x
::(loop false infn
(ident
::type_names
) rest)
936 | (PC.TIdent
(ident
,clt),v
)::id
::rest when start
&& is_id id
->
937 let newid = redo_id ident
clt v
in
938 newid::id
::(loop false infn
(ident
::type_names
) rest)
939 | (PC.TIdent
(ident
,clt),v
)::rest when List.mem ident type_names
->
940 (PC.TTypeId
(ident
,clt),v
)::(loop false infn type_names
rest)
941 | ((PC.TIdent
(ident
,clt),v
) as x
)::rest ->
942 x
::(loop false infn type_names
rest)
943 | x
::rest -> x
::(loop false infn type_names
rest)
944 and collect_choices type_names
= function
945 [] -> [] (* should happen, but let the parser detect that *)
946 | (PC.TCBrace
(clt),v
)::rest ->
947 (PC.TCBrace
(clt),v
)::(loop false 0 type_names
rest)
948 | delim
::(PC.TIdent
(ident
,clt),v
)::rest
949 when is_choices_delim delim
->
950 let newid = redo_id ident
clt v
in
951 delim
::newid::(collect_choices
(ident
::type_names
) rest)
952 | x
::rest -> x
::(collect_choices type_names
rest) in
956 (* ----------------------------------------------------------------------- *)
957 (* Insert TLineEnd tokens at the end of a line that contains a WHEN.
958 WHEN is restricted to a single line, to avoid ambiguity in eg:
962 let token2line (tok
,_
) =
964 PC.Tchar
(clt) | PC.Tshort
(clt) | PC.Tint
(clt) | PC.Tdouble
(clt)
965 | PC.Tfloat
(clt) | PC.Tlong
(clt) | PC.Tvoid
(clt)
966 | PC.Tsize_t
(clt) | PC.Tssize_t
(clt) | PC.Tptrdiff_t
(clt)
968 | PC.Tunion
(clt) | PC.Tenum
(clt) | PC.Tunsigned
(clt) | PC.Tsigned
(clt)
969 | PC.Tstatic
(clt) | PC.Tauto
(clt) | PC.Tregister
(clt) | PC.Textern
(clt)
970 | PC.Tinline
(clt) | PC.Ttypedef
(clt) | PC.Tattr
(_
,clt) | PC.Tconst
(clt)
973 | PC.TInc
(clt) | PC.TDec
(clt)
975 | PC.TIf
(clt) | PC.TElse
(clt) | PC.TWhile
(clt) | PC.TFor
(clt) | PC.TDo
(clt)
976 | PC.TSwitch
(clt) | PC.TCase
(clt) | PC.TDefault
(clt) | PC.TSizeof
(clt)
977 | PC.TReturn
(clt) | PC.TBreak
(clt) | PC.TContinue
(clt) | PC.TGoto
(clt)
979 | PC.TTypeId
(_
,clt) | PC.TDeclarerId
(_
,clt) | PC.TIteratorId
(_
,clt)
980 | PC.TMetaDeclarer
(_
,_
,_
,clt) | PC.TMetaIterator
(_
,_
,_
,clt)
984 | PC.TString
(_
,clt) | PC.TChar
(_
,clt) | PC.TFloat
(_
,clt) | PC.TInt
(_
,clt)
986 | PC.TOrLog
(clt) | PC.TAndLog
(clt) | PC.TOr
(clt) | PC.TXor
(clt)
987 | PC.TAnd
(clt) | PC.TEqEq
(clt) | PC.TNotEq
(clt) | PC.TLogOp
(_
,clt)
988 | PC.TShLOp
(_
,clt) | PC.TShROp
(_
,clt)
989 | PC.TPlus
(clt) | PC.TMinus
(clt) | PC.TMul
(clt)
990 | PC.TDmOp
(_
,clt) | PC.TTilde
(clt)
992 | PC.TMeta
(_
,_
,clt) | PC.TMetaParam
(_
,_
,clt) | PC.TMetaParamList
(_
,_
,_
,clt)
993 | PC.TMetaConst
(_
,_
,_
,_
,clt) | PC.TMetaExp
(_
,_
,_
,_
,clt)
994 | PC.TMetaIdExp
(_
,_
,_
,_
,clt) | PC.TMetaLocalIdExp
(_
,_
,_
,_
,clt)
995 | PC.TMetaExpList
(_
,_
,_
,clt)
996 | PC.TMetaId
(_
,_
,_
,_
,clt) | PC.TMetaType
(_
,_
,clt)
997 | PC.TMetaInit
(_
,_
,clt) | PC.TMetaInitList
(_
,_
,_
,clt)
998 | PC.TMetaDecl
(_
,_
,clt) | PC.TMetaField
(_
,_
,clt)
999 | PC.TMetaFieldList
(_
,_
,_
,clt)
1000 | PC.TMetaStm
(_
,_
,clt) | PC.TMetaStmList
(_
,_
,clt) | PC.TMetaFunc
(_
,_
,_
,clt)
1001 | PC.TMetaLocalFunc
(_
,_
,_
,clt) | PC.TMetaPos
(_
,_
,_
,clt)
1004 | PC.TWhen
(clt) | PC.TWhenTrue
(clt) | PC.TWhenFalse
(clt)
1005 | PC.TAny
(clt) | PC.TStrict
(clt) | PC.TEllipsis
(clt)
1006 (* | PC.TCircles(clt) | PC.TStars(clt) *)
1008 | PC.TOEllipsis
(clt) | PC.TCEllipsis
(clt)
1009 | PC.TPOEllipsis
(clt) | PC.TPCEllipsis
(clt) (*| PC.TOCircles(clt)
1010 | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *)
1012 | PC.TWhy
(clt) | PC.TDotDot
(clt) | PC.TBang
(clt) | PC.TOPar
(clt)
1013 | PC.TOPar0
(clt) | PC.TMid0
(clt) | PC.TCPar
(clt)
1016 | PC.TOBrace
(clt) | PC.TCBrace
(clt) | PC.TOCro
(clt) | PC.TCCro
(clt)
1021 | PC.TUndef
(clt,_
) | PC.TDefine
(clt,_
) | PC.TDefineParam
(clt,_
,_
,_
)
1022 | PC.TIncludeL
(_
,clt) | PC.TIncludeNL
(_
,clt)
1024 | PC.TEq
(clt) | PC.TAssign
(_
,clt) | PC.TDot
(clt) | PC.TComma
(clt)
1025 | PC.TPArob
(clt) | PC.TPtVirg
(clt) ->
1026 let (_
,line
,_
,_
,_
,_
,_
,_
) = clt in Some line
1030 let rec insert_line_end = function
1032 | (((PC.TWhen
(clt),q
) as x
)::xs
) ->
1033 x
::(find_line_end
true (token2line x
) clt q xs
)
1034 | (((PC.TUndef
(clt,_
),q
) as x
)::xs
)
1035 | (((PC.TDefine
(clt,_
),q
) as x
)::xs
)
1036 | (((PC.TDefineParam
(clt,_
,_
,_
),q
) as x
)::xs
) ->
1037 x
::(find_line_end
false (token2line x
) clt q xs
)
1038 | x
::xs
-> x
::(insert_line_end xs
)
1040 and find_line_end inwhen line
clt q
= function
1041 (* don't know what 2nd component should be so just use the info of
1042 the When. Also inherit - of when, if any *)
1043 [] -> [(PC.TLineEnd
(clt),q
)]
1044 | ((PC.TIdent
("strict",clt),a
) as x
)::xs
when token2line x
= line
->
1045 (PC.TStrict
(clt),a
) :: (find_line_end inwhen line
clt q xs
)
1046 | ((PC.TIdent
("STRICT",clt),a
) as x
)::xs
when token2line x
= line
->
1047 (PC.TStrict
(clt),a
) :: (find_line_end inwhen line
clt q xs
)
1048 | ((PC.TIdent
("any",clt),a
) as x
)::xs
when token2line x
= line
->
1049 (PC.TAny
(clt),a
) :: (find_line_end inwhen line
clt q xs
)
1050 | ((PC.TIdent
("ANY",clt),a
) as x
)::xs
when token2line x
= line
->
1051 (PC.TAny
(clt),a
) :: (find_line_end inwhen line
clt q xs
)
1052 | ((PC.TIdent
("forall",clt),a
) as x
)::xs
when token2line x
= line
->
1053 (PC.TForall
,a
) :: (find_line_end inwhen line
clt q xs
)
1054 | ((PC.TIdent
("exists",clt),a
) as x
)::xs
when token2line x
= line
->
1055 (PC.TExists
,a
) :: (find_line_end inwhen line
clt q xs
)
1056 | ((PC.TComma
(clt),a
) as x
)::xs
when token2line x
= line
->
1057 (PC.TComma
(clt),a
) :: (find_line_end inwhen line
clt q xs
)
1058 | ((PC.TPArob
(clt),a
) as x
)::xs
when token2line x
= line
->
1059 (PC.TPArob
(clt),a
) :: (find_line_end inwhen line
clt q xs
)
1060 | x
::xs
when token2line x
= line
-> x
:: (find_line_end inwhen line
clt q xs
)
1061 | xs
-> (PC.TLineEnd
(clt),q
)::(insert_line_end xs
)
1063 let rec translate_when_true_false = function
1065 | (PC.TWhen
(clt),q
)::((PC.TNotEq
(_
),_
) as x
)::(PC.TIdent
("true",_
),_
)::xs
->
1066 (PC.TWhenTrue
(clt),q
)::x
::(translate_when_true_false xs
)
1067 | (PC.TWhen
(clt),q
)::((PC.TNotEq
(_
),_
) as x
)::(PC.TIdent
("false",_
),_
)::xs
->
1068 (PC.TWhenFalse
(clt),q
)::x
::(translate_when_true_false xs
)
1069 | x
::xs
-> x
:: (translate_when_true_false xs
)
1071 (* ----------------------------------------------------------------------- *)
1073 (* In a nest, if the nest is -, all of the nested code must also be -.
1074 All are converted to context, because the next takes care of the -. *)
1075 let check_nests tokens
=
1077 let (line_type,a
,b
,c
,d
,e
,f
,g
) = get_clt t
in
1078 List.mem
line_type [D.MINUS
;D.OPTMINUS
;D.UNIQUEMINUS
] in
1080 let clt = try Some
(get_clt t
) with Failure _
-> None
in
1082 Some
(line_type,a
,b
,c
,d
,e
,f
,g
) ->
1083 (match line_type with
1084 D.MINUS
-> update_clt t
(D.CONTEXT
,a
,b
,c
,d
,e
,f
,g
)
1085 | D.OPTMINUS
-> update_clt t
(D.OPT
,a
,b
,c
,d
,e
,f
,g
)
1086 | D.UNIQUEMINUS
-> update_clt t
(D.UNIQUE
,a
,b
,c
,d
,e
,f
,g
)
1087 | _
-> failwith
"minus token expected")
1089 let rec outside = function
1091 | ((PC.TPOEllipsis
(clt),q
) as t
)::r
when is_minus t
-> t
:: inside
0 r
1092 | t
::r
-> t
:: outside r
1093 and inside stack
= function
1094 [] -> failwith
"missing nest end"
1095 | ((PC.TPCEllipsis
(clt),q
) as t
)::r
->
1097 :: (if stack
= 0 then outside r
else inside
(stack
- 1) r
)
1098 | ((PC.TPOEllipsis
(clt),q
) as t
)::r
->
1099 (drop_minus t
) :: (inside
(stack
+ 1) r
)
1100 | t
:: r
-> (drop_minus t
) :: (inside stack r
) in
1103 let check_parentheses tokens
=
1104 let clt2line (_
,line
,_
,_
,_
,_
,_
,_
) = line
in
1105 let rec loop seen_open
= function
1107 | (PC.TOPar
(clt),q
) :: rest
1108 | (PC.TDefineParam
(clt,_
,_
,_
),q
) :: rest ->
1109 loop (Common.Left
(clt2line clt) :: seen_open
) rest
1110 | (PC.TOPar0
(clt),q
) :: rest ->
1111 loop (Common.Right
(clt2line clt) :: seen_open
) rest
1112 | (PC.TCPar
(clt),q
) :: rest ->
1113 (match seen_open
with
1117 "unexpected close parenthesis in line %d\n" (clt2line clt))
1118 | Common.Left _
:: seen_open
-> loop seen_open
rest
1119 | Common.Right open_line
:: _
->
1122 "disjunction parenthesis in line %d column 0 matched to normal parenthesis on line %d\n" open_line
(clt2line clt)))
1123 | (PC.TCPar0
(clt),q
) :: rest ->
1124 (match seen_open
with
1128 "unexpected close parenthesis in line %d\n" (clt2line clt))
1129 | Common.Right _
:: seen_open
-> loop seen_open
rest
1130 | Common.Left open_line
:: _
->
1133 "normal parenthesis in line %d matched to disjunction parenthesis on line %d column 0\n" open_line
(clt2line clt)))
1134 | x
::rest -> loop seen_open
rest in
1137 (* ----------------------------------------------------------------------- *)
1138 (* top level initializers: a sequence of braces followed by a dot *)
1140 let find_top_init tokens
=
1142 (PC.TOBrace
(clt),q
) :: rest ->
1143 let rec dot_start acc
= function
1144 ((PC.TOBrace
(_
),_
) as x
) :: rest ->
1145 dot_start (x
::acc
) rest
1146 | ((PC.TDot
(_
),_
) :: rest) as x
->
1147 Some
((PC.TOInit
(clt),q
) :: (List.rev acc
) @ x
)
1149 let rec comma_end acc
= function
1150 ((PC.TCBrace
(_
),_
) as x
) :: rest ->
1151 comma_end (x
::acc
) rest
1152 | ((PC.TComma
(_
),_
) :: rest) as x
->
1153 Some
((PC.TOInit
(clt),q
) :: (List.rev x
) @ acc
)
1155 (match dot_start [] rest with
1158 (match List.rev
rest with
1159 (* not super sure what this does, but EOF, @, and @@ should be
1160 the same, markind the end of a rule *)
1161 ((PC.EOF
,_
) as x
)::rest | ((PC.TArob
,_
) as x
)::rest
1162 | ((PC.TArobArob
,_
) as x
)::rest ->
1163 (match comma_end [x
] rest with
1167 failwith
"unexpected empty token list"))
1170 (* ----------------------------------------------------------------------- *)
1171 (* Integrate pragmas into some adjacent token. + tokens are preferred. Dots
1174 let rec collect_all_pragmas collected
= function
1175 (PC.TPragma
(s
,(_
,line
,logical_line
,offset
,col
,_
,_
,pos
)),_
)::rest ->
1177 { Ast0.line_start
= line
; Ast0.line_end
= line
;
1178 Ast0.logical_start
= logical_line
; Ast0.logical_end
= logical_line
;
1179 Ast0.column
= col
; Ast0.offset
= offset
; } in
1180 collect_all_pragmas ((s
,i)::collected
) rest
1181 | l
-> (List.rev collected
,l
)
1183 let rec collect_pass = function
1186 match plus_attachable false x
with
1188 let (pass
,rest) = collect_pass xs
in
1192 let plus_attach strict
= function
1194 | Some x
-> plus_attachable strict x
1196 let add_bef = function Some x
-> [x
] | None
-> []
1198 (*skips should be things like line end
1199 skips is things before pragmas that can't be attached to, pass is things
1200 after. pass is used immediately. skips accumulates.
1201 When stuff is added before some + code, the logical line of the + code
1202 becomes that of the pragma. context_neg relies on things that are adjacent
1203 having sequential logical lines. Not sure that this is good enough,
1204 as it might result in later gaps in the logical lines... *)
1205 let rec process_pragmas bef skips
= function
1206 [] -> add_bef bef
@ List.rev skips
1207 | ((PC.TPragma
(s
,i),_
)::_
) as l
->
1208 let (pragmas
,rest) = collect_all_pragmas [] l
in
1209 let (pass
,rest0
) = collect_pass rest in
1210 let (_
,_
,prag_lline
,_
,_
,_
,_
,_
) = i in
1212 match rest0
with [] -> (None
,[]) | next
::rest -> (Some next
,rest) in
1213 (match (bef
,plus_attach true bef
,next
,plus_attach true next
) with
1214 (Some bef
,PLUS
,_
,_
) ->
1215 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt bef
in
1216 (update_clt bef
(a
,b
,c
,d
,e
,strbef
,pragmas
,pos
))::List.rev skips
@
1217 pass
@process_pragmas None
[] rest0
1218 | (_
,_
,Some next
,PLUS
) ->
1219 let (a
,b
,lline
,d
,e
,strbef
,straft
,pos
) = get_clt next
in
1220 (add_bef bef
) @ List.rev skips
@ pass
@
1222 (Some
(update_clt next
(a
,b
,prag_lline
,d
,e
,pragmas
,straft
,pos
)))
1225 (match (bef
,plus_attach false bef
,next
,plus_attach false next
) with
1226 (Some bef
,PLUS
,_
,_
) ->
1227 let (a
,b
,c
,d
,e
,strbef
,straft
,pos
) = get_clt bef
in
1228 (update_clt bef
(a
,b
,c
,d
,e
,strbef
,pragmas
,pos
))::List.rev skips
@
1229 pass
@process_pragmas None
[] rest0
1230 | (_
,_
,Some next
,PLUS
) ->
1231 let (a
,b
,lline
,d
,e
,strbef
,straft
,pos
) = get_clt next
in
1232 (add_bef bef
) @ List.rev skips
@ pass
@
1235 (update_clt next
(a
,b
,prag_lline
,d
,e
,pragmas
,straft
,pos
)))
1237 | _
-> failwith
"nothing to attach pragma to"))
1239 (match plus_attachable false x
with
1240 SKIP
-> process_pragmas bef
(x
::skips
) xs
1241 | _
-> (add_bef bef
) @ List.rev skips
@ (process_pragmas (Some x
) [] xs
))
1243 (* ----------------------------------------------------------------------- *)
1244 (* Drop ... ... . This is only allowed in + code, and arises when there is
1245 some - code between the ... *)
1246 (* drop whens as well - they serve no purpose in + code and they cause
1247 problems for drop_double_dots *)
1249 let rec drop_when = function
1251 | (PC.TWhen
(clt),info)::xs
->
1252 let rec loop = function
1254 | (PC.TLineEnd
(_
),info)::xs
-> drop_when xs
1255 | x
::xs
-> loop xs
in
1257 | x
::xs
-> x
::drop_when xs
1259 (* instead of dropping the double dots, we put TNothing in between them.
1260 these vanish after the parser, but keeping all the ...s in the + code makes
1261 it easier to align the + and - code in context_neg and in preparation for the
1262 isomorphisms. This shouldn't matter because the context code of the +
1263 slice is mostly ignored anyway *)
1264 let minus_to_nothing l
=
1265 (* for cases like | <..., which may or may not arise from removing minus
1266 code, depending on whether <... is a statement or expression *)
1269 let (d
,_
,_
,_
,_
,_
,_
,_
) = get_clt tok
in
1271 D.MINUS
| D.OPTMINUS
| D.UNIQUEMINUS
-> true
1272 | D.PLUS
| D.PLUSPLUS
-> false
1273 | D.CONTEXT
| D.UNIQUE
| D.OPT
-> false)
1275 let rec minus_loop = function
1277 | (d
::ds
) as l
-> if is_minus d
then minus_loop ds
else l
in
1278 let rec loop = function
1280 | ((PC.TMid0
(clt),i) as x
)::t1
::ts
when is_minus t1
->
1281 (match minus_loop ts
with
1282 ((PC.TOEllipsis
(_
),_
)::_
) | ((PC.TPOEllipsis
(_
),_
)::_
)
1283 | ((PC.TEllipsis
(_
),_
)::_
) as l
-> x
::(PC.TNothing
,i)::(loop l
)
1285 | t
::ts
-> t
::(loop ts
) in
1288 let rec drop_double_dots l
=
1289 let start = function
1290 (PC.TOEllipsis
(_
),_
) | (PC.TPOEllipsis
(_
),_
)
1291 (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *) ->
1294 let middle = function
1295 (PC.TEllipsis
(_
),_
) (* | (PC.TCircles(_),_) | (PC.TStars(_),_) *) -> true
1297 let whenline = function
1298 (PC.TLineEnd
(_
),_
) -> true
1299 (*| (PC.TMid0(_),_) -> true*)
1301 let final = function
1302 (PC.TCEllipsis
(_
),_
) | (PC.TPCEllipsis
(_
),_
)
1303 (* | (PC.TCCircles(_),_) | (PC.TCStars(_),_) *) ->
1306 let any_before x
= start x
or middle x
or final x
or whenline x
in
1307 let any_after x
= start x
or middle x
or final x
in
1308 let rec loop ((_
,i) as prev
) = function
1310 | x
::rest when any_before prev
&& any_after x
->
1311 (PC.TNothing
,i)::x
::(loop x
rest)
1312 | ((PC.TComma
(_
),_
) as c
)::x
::rest when any_before prev
&& any_after x
->
1313 c
::(PC.TNothing
,i)::x
::(loop x
rest)
1314 | x
::rest -> x
:: (loop x
rest) in
1317 | (x
::xs
) -> x
:: loop x xs
1319 (* ignore uncomparable pcre regular expressions *)
1320 let strip_for_fix l
=
1323 (PC.TMetaId
(nm
,_
,seed
,pure
,clt),info) ->
1324 (PC.TMetaId
(nm
,Ast.IdNoConstraint
,seed
,pure
,clt),info)
1325 | (PC.TMetaFunc
(nm
,_
,pure
,clt),info) ->
1326 (PC.TMetaFunc
(nm
,Ast.IdNoConstraint
,pure
,clt),info)
1327 | (PC.TMetaLocalFunc
(nm
,_
,pure
,clt),info) ->
1328 (PC.TMetaLocalFunc
(nm
,Ast.IdNoConstraint
,pure
,clt),info)
1329 | (PC.TMetaErr
(nm
,_
,pure
,clt),info) ->
1330 (PC.TMetaErr
(nm
,Ast0.NoConstraint
,pure
,clt),info)
1331 | (PC.TMetaExp
(nm
,_
,pure
,ty
,clt),info) ->
1332 (PC.TMetaExp
(nm
,Ast0.NoConstraint
,pure
,ty
,clt),info)
1333 | (PC.TMetaIdExp
(nm
,_
,pure
,ty
,clt),info) ->
1334 (PC.TMetaIdExp
(nm
,Ast0.NoConstraint
,pure
,ty
,clt),info)
1335 | (PC.TMetaLocalIdExp
(nm
,_
,pure
,ty
,clt),info) ->
1336 (PC.TMetaLocalIdExp
(nm
,Ast0.NoConstraint
,pure
,ty
,clt),info)
1337 | (PC.TMetaConst
(nm
,_
,pure
,ty
,clt),info) ->
1338 (PC.TMetaConst
(nm
,Ast0.NoConstraint
,pure
,ty
,clt),info)
1343 let rec loop f l stripped_l
=
1345 let stripped_cur = strip_for_fix cur in
1346 if stripped_l
= stripped_cur then l
else loop f
cur stripped_cur in
1347 loop f l
(strip_for_fix l
)
1349 (* ( | ... | ) also causes parsing problems *)
1353 let rec drop_empty_thing starter
middle ender
= function
1355 | hd
::rest when starter hd
->
1356 let rec loop = function
1357 x
::rest when middle x
-> loop rest
1358 | x
::rest when ender x
-> rest
1359 | _
-> raise Not_empty
in
1360 (match try Some
(loop rest) with Not_empty
-> None
with
1361 Some x
-> drop_empty_thing starter
middle ender x
1362 | None
-> hd
:: drop_empty_thing starter
middle ender
rest)
1363 | x
::rest -> x
:: drop_empty_thing starter
middle ender
rest
1367 (function (PC.TOPar0
(_
),_
) -> true | _
-> false)
1368 (function (PC.TMid0
(_
),_
) -> true | _
-> false)
1369 (function (PC.TCPar0
(_
),_
) -> true | _
-> false)
1371 let drop_empty_nest = drop_empty_thing
1373 (* ----------------------------------------------------------------------- *)
1376 let get_s_starts (_
, (s
,_
,(starts
, ends
))) =
1377 Printf.printf
"%d %d\n" starts ends
; (s
, starts
)
1380 let v = List.hd
!l
in
1385 PC.reinit (function _
-> PC.TArobArob
(* a handy token *))
1386 (Lexing.from_function
1387 (function buf
-> function n
-> raise
Common.Impossible
))
1389 let parse_one str parsefn file toks
=
1390 let all_tokens = ref toks
in
1391 let cur_tok = ref (List.hd
!all_tokens) in
1393 let lexer_function _
=
1394 let (v, info) = pop2 all_tokens in
1395 cur_tok := (v, info);
1399 Lexing.from_function
1400 (function buf
-> function n
-> raise
Common.Impossible
)
1405 try parsefn
lexer_function lexbuf_fake
1407 Lexer_cocci.Lexical s
->
1409 (Printf.sprintf
"%s: lexical error: %s\n =%s\n" str s
1410 (Common.error_message file
(get_s_starts !cur_tok) ))
1411 | Parser_cocci_menhir.Error
->
1413 (Printf.sprintf
"%s: parse error: \n = %s\n" str
1414 (Common.error_message file
(get_s_starts !cur_tok) ))
1415 | Semantic_cocci.Semantic s
->
1417 (Printf.sprintf
"%s: semantic error: %s\n =%s\n" str s
1418 (Common.error_message file
(get_s_starts !cur_tok) ))
1422 let prepare_tokens tokens
=
1424 (translate_when_true_false (* after insert_line_end *)
1427 (find_function_names
1430 (check_parentheses tokens
)))))))
1432 let prepare_mv_tokens tokens
=
1433 detect_types false (detect_attr tokens
)
1435 let unminus (d
,x1
,x2
,x3
,x4
,x5
,x6
,x7
) = (* for hidden variables *)
1437 D.MINUS
| D.OPTMINUS
| D.UNIQUEMINUS
-> (D.CONTEXT
,x1
,x2
,x3
,x4
,x5
,x6
,x7
)
1438 | D.PLUS
-> failwith
"unexpected plus code"
1439 | D.PLUSPLUS
-> failwith
"unexpected plus code"
1440 | D.CONTEXT
| D.UNIQUE
| D.OPT
-> (D.CONTEXT
,x1
,x2
,x3
,x4
,x5
,x6
,x7
)
1442 let process_minus_positions x name
clt meta
=
1443 let (arity
,ln
,lln
,offset
,col
,strbef
,straft
,pos
) = get_clt x
in
1444 let name = Parse_aux.clt2mcode
name (unminus clt) in
1445 update_clt x
(arity
,ln
,lln
,offset
,col
,strbef
,straft
,meta
name::pos
)
1447 (* first attach positions, then the others, so that positions can refer to
1448 the larger term represented by the preceding metavariable *)
1449 let rec consume_minus_positions toks
=
1450 let rec loop_pos = function
1452 | ((PC.TOPar0
(_
),_
) as x
)::xs
| ((PC.TCPar0
(_
),_
) as x
)::xs
1453 | ((PC.TMid0
(_
),_
) as x
)::xs
-> x
::loop_pos xs
1454 | x
::(PC.TPArob _
,_
)::(PC.TMetaPos
(name,constraints
,per
,clt),_
)::xs
->
1456 process_minus_positions x name clt
1458 Ast0.MetaPosTag
(Ast0.MetaPos
(name,constraints
,per
))) in
1460 | x::xs
-> x::loop_pos xs
in
1461 let rec loop_other = function
1463 | ((PC.TOPar0
(_
),_
) as x)::xs
| ((PC.TCPar0
(_
),_
) as x)::xs
1464 | ((PC.TMid0
(_
),_
) as x)::xs
-> x::loop_other xs
1465 | x::(PC.TPArob _
,_
)::(PC.TMetaId
(name,constraints
,seed
,pure
,clt),_
)::xs
->
1467 process_minus_positions x name clt
1471 (Ast0.MetaId
(name,constraints
,seed
,pure
)))) in
1472 (loop_other (x::xs
))
1473 | x::(PC.TPArob _
,_
)::(PC.TMetaExp
(name,constraints
,pure
,ty
,clt),_
)::xs
->
1475 process_minus_positions x name clt
1479 (Ast0.MetaExpr
(name,constraints
,ty
,Ast.ANY
,pure
)))) in
1480 (loop_other (x::xs
))
1481 | x::(PC.TPArob _
,_
)::(PC.TMetaInit
(name,pure
,clt),_
)::xs
->
1483 process_minus_positions x name clt
1485 Ast0.InitTag
(Ast0.wrap
(Ast0.MetaInit
(name,pure
)))) in
1486 (loop_other (x::xs
))
1487 | x::(PC.TPArob _
,_
)::(PC.TMetaType
(name,pure
,clt),_
)::xs
->
1489 process_minus_positions x name clt
1491 Ast0.TypeCTag
(Ast0.wrap
(Ast0.MetaType
(name,pure
)))) in
1492 (loop_other (x::xs
))
1493 | x::(PC.TPArob _
,_
)::(PC.TMetaDecl
(name,pure
,clt),_
)::xs
->
1495 process_minus_positions x name clt
1497 Ast0.DeclTag
(Ast0.wrap
(Ast0.MetaDecl
(name,pure
)))) in
1498 (loop_other (x::xs
))
1499 | x::(PC.TPArob _
,_
)::(PC.TMetaStm
(name,pure
,clt),_
)::xs
->
1501 process_minus_positions x name clt
1503 Ast0.StmtTag
(Ast0.wrap
(Ast0.MetaStmt
(name,pure
)))) in
1504 (loop_other (x::xs
))
1505 | x::xs
-> x::loop_other xs
in
1506 loop_other(loop_pos toks
)
1508 let rec consume_plus_positions = function
1510 | (PC.TPArob _
,_
)::x::xs
-> consume_plus_positions xs
1511 | x::xs
-> x::consume_plus_positions xs
1513 let any_modif rule
=
1515 match Ast0.get_mcode_mcodekind
x with
1516 Ast0.MINUS _
| Ast0.PLUS _
-> true
1518 let donothing r k e
= k e
in
1519 let bind x y
= x or y
in
1520 let option_default = false in
1522 V0.flat_combiner
bind option_default
1523 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1524 donothing donothing donothing donothing donothing donothing
1525 donothing donothing donothing donothing donothing donothing donothing
1526 donothing donothing donothing in
1527 List.exists
fn.VT0.combiner_rec_top_level rule
1529 let eval_virt virt
=
1532 if not
(List.mem
x virt
)
1533 then raise
(Bad_virt
x))
1534 !Flag.defined_virtual_rules
1536 let drop_last extra l
= List.rev
(extra
@(List.tl
(List.rev l
)))
1538 let partition_either l
=
1539 let rec part_either left right
= function
1540 | [] -> (List.rev left
, List.rev right
)
1543 | Common.Left e
-> part_either (e
:: left
) right l
1544 | Common.Right e
-> part_either left
(e
:: right
) l
) in
1547 let get_metavars parse_fn table file lexbuf
=
1548 let rec meta_loop acc
(* read one decl at a time *) =
1552 tokens_all table file
true lexbuf
[PC.TArobArob
;PC.TMPtVirg
]) in
1553 let tokens = prepare_mv_tokens tokens in
1555 [(PC.TArobArob
,_
)] -> List.rev acc
1557 let metavars = parse_one "meta" parse_fn file
tokens in
1558 meta_loop (metavars@acc
) in
1559 partition_either (meta_loop [])
1561 let get_script_metavars parse_fn table file lexbuf
=
1562 let rec meta_loop acc
=
1564 tokens_all table file
true lexbuf
[PC.TArobArob
; PC.TMPtVirg
] in
1565 let tokens = prepare_tokens tokens in
1567 [(PC.TArobArob
, _
)] -> List.rev acc
1569 let metavar = parse_one "scriptmeta" parse_fn file
tokens in
1570 meta_loop (metavar :: acc
)
1574 let get_rule_name parse_fn starts_with_name get_tokens file prefix
=
1575 Data.in_rule_name
:= true;
1576 let mknm _
= make_name prefix
(!Lexer_cocci.line
) in
1580 let (_
,tokens) = get_tokens
[PC.TArob
] in
1581 let check_name = function
1582 None
-> Some
(mknm())
1584 (if List.mem nm
reserved_names
1585 then failwith
(Printf.sprintf
"invalid name %s\n" nm
));
1587 match parse_one "rule name" parse_fn file
tokens with
1588 Ast.CocciRulename
(nm
,a
,b
,c
,d
,e
) ->
1589 Ast.CocciRulename
(check_name nm
,a
,b
,c
,d
,e
)
1590 | Ast.GeneratedRulename
(nm
,a
,b
,c
,d
,e
) ->
1591 Ast.GeneratedRulename
(check_name nm
,a
,b
,c
,d
,e
)
1592 | Ast.ScriptRulename
(nm
,s
,deps
) ->
1593 Ast.ScriptRulename
(check_name nm
,s
,deps
)
1594 | Ast.InitialScriptRulename
(_
,s
,deps
) ->
1595 Ast.InitialScriptRulename
(check_name None
,s
,deps
)
1596 | Ast.FinalScriptRulename
(_
,s
,deps
) ->
1597 Ast.FinalScriptRulename
(check_name None
,s
,deps
)
1599 Ast.CocciRulename
(Some
(mknm()),Ast.NoDep
,[],[],Ast.Undetermined
,false) in
1600 Data.in_rule_name
:= false;
1603 let parse_iso file
=
1604 let table = Common.full_charpos_to_pos file
in
1605 Common.with_open_infile file
(fun channel
->
1606 let lexbuf = Lexing.from_channel channel
in
1607 let get_tokens = tokens_all table file
false lexbuf in
1609 match get_tokens [PC.TArobArob
;PC.TArob
] with
1611 let parse_start start =
1612 let rev = List.rev start in
1613 let (arob
,_
) = List.hd
rev in
1614 (arob
= PC.TArob
,List.rev(List.tl
rev)) in
1615 let (starts_with_name
,start) = parse_start start in
1616 let rec loop starts_with_name
start =
1617 (!Data.init_rule
)();
1618 (* get metavariable declarations - have to be read before the
1620 let (rule_name
,_
,_
,_
,_
,_
) =
1621 match get_rule_name PC.iso_rule_name starts_with_name
get_tokens
1622 file
("iso file "^file
) with
1623 Ast.CocciRulename
(Some n
,a
,b
,c
,d
,e
) -> (n
,a
,b
,c
,d
,e
)
1624 | _
-> failwith
"Script rules cannot appear in isomorphism rules"
1626 Ast0.rule_name
:= rule_name
;
1628 match get_metavars PC.iso_meta_main
table file
lexbuf with
1629 (iso_metavars,[]) -> iso_metavars
1630 | _
-> failwith
"unexpected inheritance in iso" in
1634 [PC.TIsoStatement
;PC.TIsoExpression
;PC.TIsoArgExpression
;
1635 PC.TIsoTestExpression
; PC.TIsoToTestExpression
;
1636 PC.TIsoDeclaration
;PC.TIsoType
;PC.TIsoTopLevel
] in
1637 let next_start = List.hd
(List.rev tokens) in
1638 let dummy_info = ("",(-1,-1),(-1,-1)) in
1639 let tokens = drop_last [(PC.EOF
,dummy_info)] tokens in
1640 let tokens = prepare_tokens (start@tokens) in
1642 print_tokens "iso tokens" tokens;
1644 let entry = parse_one "iso main" PC.iso_main file
tokens in
1645 let entry = List.map
(List.map
Test_exps.process_anything
) entry in
1647 then (* The code below allows a header like Statement list,
1648 which is more than one word. We don't have that any more,
1649 but the code is left here in case it is put back. *)
1650 match get_tokens [PC.TArobArob
;PC.TArob
] with
1652 let (starts_with_name
,start) = parse_start start in
1653 (iso_metavars,entry,rule_name
) ::
1654 (loop starts_with_name
(next_start::start))
1655 | _
-> failwith
"isomorphism ends early"
1656 else [(iso_metavars,entry,rule_name
)] in
1657 loop starts_with_name
start
1658 | (false,_
) -> [] in
1659 List.iter
Iso_compile.process
res;
1662 let parse_iso_files existing_isos iso_files extra_path
=
1663 let get_names = List.map
(function (_
,_
,nm
) -> nm
) in
1664 let old_names = get_names existing_isos
in
1665 Data.in_iso
:= true;
1668 (function (prev
,names
) ->
1672 Common.Left
(fl
) -> Filename.concat extra_path fl
1673 | Common.Right
(fl
) -> Filename.concat
Config.path fl
in
1674 Lexer_cocci.init
();
1675 let current = parse_iso file in
1676 let new_names = get_names current in
1677 if List.exists
(function x -> List.mem
x names
) new_names
1678 then failwith
(Printf.sprintf
"repeated iso name found in %s" file);
1679 (current::prev
,new_names @ names
))
1680 ([],old_names) iso_files
in
1681 Data.in_iso
:= false;
1682 existing_isos
@(List.concat
(List.rev res))
1684 (* None = dependency not satisfied
1685 Some dep = dependency satisfied or unknown and dep has virts optimized
1687 let eval_depend dep virt
=
1690 Ast.Dep req
| Ast.EverDep req
->
1691 if List.mem req virt
1693 if List.mem req
!Flag.defined_virtual_rules
1697 | Ast.AntiDep antireq
| Ast.NeverDep antireq
->
1698 if List.mem antireq virt
1700 if not
(List.mem antireq
!Flag.defined_virtual_rules
)
1704 | Ast.AndDep
(d1
,d2
) ->
1705 (match (loop d1
, loop d2
) with
1706 (Ast.NoDep
,x) | (x,Ast.NoDep
) -> x
1707 | (Ast.FailDep
,x) | (x,Ast.FailDep
) -> Ast.FailDep
1708 | (x,y
) -> Ast.AndDep
(x,y
))
1709 | Ast.OrDep
(d1
,d2
) ->
1710 (match (loop d1
, loop d2
) with
1711 (Ast.NoDep
,x) | (x,Ast.NoDep
) -> Ast.NoDep
1712 | (Ast.FailDep
,x) | (x,Ast.FailDep
) -> x
1713 | (x,y
) -> Ast.OrDep
(x,y
))
1714 | Ast.NoDep
| Ast.FailDep
-> dep
1719 Lexer_cocci.init
();
1720 let rec parse_loop file =
1721 Lexer_cocci.include_init
();
1722 let table = Common.full_charpos_to_pos
file in
1723 Common.with_open_infile
file (fun channel
->
1724 let lexbuf = Lexing.from_channel channel
in
1725 let get_tokens = tokens_all table file false lexbuf in
1726 Data.in_prolog
:= true;
1727 let initial_tokens = get_tokens [PC.TArobArob
;PC.TArob
] in
1728 Data.in_prolog
:= false;
1730 match initial_tokens with
1732 (match List.rev data
with
1733 ((PC.TArobArob
as x),_
)::_
| ((PC.TArob
as x),_
)::_
->
1734 let include_and_iso_files =
1735 parse_one "include and iso file names" PC.include_main
file data
in
1737 let (include_files
,iso_files
,virt
) =
1739 (function (include_files
,iso_files
,virt
) ->
1741 Data.Include s
-> (s
::include_files
,iso_files
,virt
)
1742 | Data.Iso s
-> (include_files
,s
::iso_files
,virt
)
1743 | Data.Virt l
-> (include_files
,iso_files
,l
@virt
))
1744 ([],[],[]) include_and_iso_files in
1746 List.iter
(function x -> Hashtbl.add
Lexer_cocci.rule_names
x ())
1749 let (extra_iso_files
, extra_rules
, extra_virt
, extra_metas
) =
1750 let rec loop = function
1752 | (a
,b
,c
,d
)::rest ->
1753 let (x,y
,z
,zz
) = loop rest in
1754 (a
::x,b
::y
,c
::z
,d
@zz
) in
1755 loop (List.map
parse_loop include_files
) in
1757 let parse_cocci_rule ruletype old_metas
1758 (rule_name
, dependencies
, iso
, dropiso
, exists
, is_expression
) =
1759 let dropiso = !Flag_parsing_cocci.disabled_isos
@ dropiso in
1760 Ast0.rule_name
:= rule_name
;
1761 Data.inheritable_positions
:=
1762 rule_name
:: !Data.inheritable_positions
;
1764 (* get metavariable declarations *)
1765 let (metavars, inherited_metavars
) =
1766 get_metavars PC.meta_main
table file lexbuf in
1767 Hashtbl.add
Data.all_metadecls rule_name
metavars;
1768 Hashtbl.add
Lexer_cocci.rule_names rule_name
();
1769 Hashtbl.add
Lexer_cocci.all_metavariables rule_name
1771 (fun key
v rest -> (key
,v)::rest)
1772 Lexer_cocci.metavariables
[]);
1774 (* get transformation rules *)
1775 let (more
, tokens) = get_tokens [PC.TArobArob
; PC.TArob
] in
1776 let (minus_tokens
, _
) = split_token_stream tokens in
1777 let (_
, plus_tokens
) =
1778 split_token_stream (minus_to_nothing tokens) in
1781 print_tokens "minus tokens" minus_tokens;
1782 print_tokens "plus tokens" plus_tokens;
1785 let minus_tokens = consume_minus_positions minus_tokens in
1786 let plus_tokens = consume_plus_positions plus_tokens in
1787 let minus_tokens = prepare_tokens minus_tokens in
1788 let plus_tokens = prepare_tokens plus_tokens in
1791 print_tokens "minus tokens" minus_tokens;
1792 print_tokens "plus tokens" plus_tokens;
1796 process_pragmas None
[]
1797 (fix (function x -> drop_double_dots (drop_empty_or x))
1798 (drop_when plus_tokens)) in
1800 print_tokens "plus tokens" plus_tokens;
1801 Printf.printf "before minus parse\n";
1805 then parse_one "minus" PC.minus_exp_main
file minus_tokens
1806 else parse_one "minus" PC.minus_main
file minus_tokens in
1808 Unparse_ast0.unparse minus_res;
1809 Printf.printf "before plus parse\n";
1812 (* put ignore_patch_or_match with * case, which is less
1814 if !Flag.sgrep_mode2
or !D.ignore_patch_or_match
1815 then (* not actually used for anything, except context_neg *)
1817 (Iso_pattern.rebuild_mcode None
).VT0.rebuilder_rec_top_level
1818 (Top_level.top_level
false minus_res)
1821 then parse_one "plus" PC.plus_exp_main
file plus_tokens
1822 else parse_one "plus" PC.plus_main
file plus_tokens in
1823 let plus_res = Top_level.top_level
false plus_res in
1824 (* minus code has to be CODE if the + code is CODE, otherwise
1825 doesn't matter if + code is CODE or DECL or TOPCODE *)
1830 match Ast0.unwrap
x with Ast0.CODE _
-> true | _
-> false)
1833 then Top_level.top_level
true minus_res
1834 else Top_level.top_level
false minus_res in
1835 let minus_res = Top_level.clean
minus_res in
1836 let plus_res = Top_level.clean
plus_res in
1838 Unparse_ast0.unparse plus_res;
1839 Printf.printf "after plus parse\n";
1842 (if not
!Flag.sgrep_mode2
&&
1843 (any_modif minus_res or any_modif plus_res) &&
1844 not
(dependencies
= Ast.FailDep
)
1845 then Data.inheritable_positions
:= []);
1847 Check_meta.check_meta rule_name old_metas inherited_metavars
1848 metavars minus_res plus_res;
1850 (more
, Ast0.CocciRule
((minus_res, metavars,
1851 (iso
, dropiso, dependencies
, rule_name
, exists
)),
1852 (plus_res, metavars), ruletype
), metavars, tokens) in
1854 let rec collect_script_tokens = function
1855 [(PC.EOF
,_
)] | [(PC.TArobArob
,_
)] | [(PC.TArob
,_
)] -> ""
1856 | (PC.TScriptData
(s
),_
)::xs
-> s^
(collect_script_tokens xs
)
1860 Printf.printf
"%s\n" (token2c x))
1862 failwith
"Malformed script rule" in
1864 let parse_script_rule name language old_metas deps
=
1865 Lexer_script.file := file;
1866 Lexer_script.language
:= language
;
1867 let get_tokens = tokens_script_all table file false lexbuf in
1869 (* meta-variables *)
1873 get_script_metavars PC.script_meta_main
table file lexbuf) in
1874 let (metavars,script_metavars
) =
1876 (function (metavars,script_metavars
) ->
1878 (script_var
,Some
(parent
,var
)) ->
1879 ((script_var
,parent
,var
) :: metavars, script_metavars
)
1880 | ((Some script_var
,None
),None
) ->
1881 (metavars, (name,script_var
) :: script_metavars
)
1882 | _
-> failwith
"not possible")
1884 let metavars = List.rev metavars in
1885 let script_metavars = List.rev script_metavars in
1887 Hashtbl.add
Data.all_metadecls
name
1888 (List.map
(function x -> Ast.MetaIdDecl
(Ast.NONE
,x))
1890 Hashtbl.add
Lexer_cocci.rule_names
name ();
1891 (*TODOHashtbl.add Lexer_cocci.all_metavariables name script_metavars;*)
1894 let exists_in old_metas (py,(r,m)) =
1896 let test (rr,mr) x =
1897 let (ro,vo) = Ast.get_meta_name x in
1898 ro = rr && vo = mr in
1899 List.exists (test (r,m)) old_metas in
1903 let meta2c (r,n) = Printf.sprintf "%s.%s" r n in
1904 if not (exists_in old_metas x) then
1907 "Script references unknown meta-variable: %s"
1912 let (more
, tokens) = get_tokens [PC.TArobArob
; PC.TArob
] in
1913 let data = collect_script_tokens tokens in
1915 Ast0.ScriptRule
(name, language
, deps
, metavars,
1916 script_metavars, data),
1919 let parse_if_script_rule k
name language _ deps
=
1920 Lexer_script.file := file;
1921 Lexer_script.language
:= language
;
1922 let get_tokens = tokens_script_all table file false lexbuf in
1925 let (more
, tokens) = get_tokens [PC.TArobArob
; PC.TArob
] in
1926 let data = collect_script_tokens tokens in
1927 (more
,k
(name, language
, deps
, data),[],tokens) in
1929 let parse_iscript_rule =
1930 parse_if_script_rule
1931 (function (name,language
,deps
,data) ->
1932 Ast0.InitialScriptRule
(name,language
,deps
,data)) in
1934 let parse_fscript_rule =
1935 parse_if_script_rule
1936 (function (name,language
,deps
,data) ->
1937 Ast0.FinalScriptRule
(name,language
,deps
,data)) in
1939 let do_parse_script_rule fn name l old_metas deps
=
1940 fn name l old_metas
(eval_depend deps virt
) in
1942 let parse_rule old_metas starts_with_name
=
1944 get_rule_name PC.rule_name starts_with_name
get_tokens file
1947 Ast.CocciRulename
(Some s
, dep
, b
, c
, d
, e
) ->
1948 (match eval_depend dep virt
with
1950 D.ignore_patch_or_match
:= true;
1952 parse_cocci_rule Ast.Normal old_metas
1953 (s
, Ast.FailDep
, b
, c
, d
, e
) in
1954 D.ignore_patch_or_match
:= false;
1956 | dep
-> parse_cocci_rule Ast.Normal old_metas
(s
,dep
,b
,c
,d
,e
))
1957 | Ast.GeneratedRulename
(Some s
, dep
, b
, c
, d
, e
) ->
1958 (match eval_depend dep virt
with
1960 D.ignore_patch_or_match
:= true;
1961 Data.in_generating
:= true;
1963 parse_cocci_rule Ast.Generated old_metas
1964 (s
, Ast.FailDep
, b
, c
, d
, e
) in
1965 D.ignore_patch_or_match
:= false;
1966 Data.in_generating
:= false;
1969 Data.in_generating
:= true;
1971 parse_cocci_rule Ast.Generated old_metas
1973 Data.in_generating
:= false;
1975 | Ast.ScriptRulename
(Some s
,l
,deps
) ->
1976 do_parse_script_rule parse_script_rule s l old_metas deps
1977 | Ast.InitialScriptRulename
(Some s
,l
,deps
) ->
1978 do_parse_script_rule parse_iscript_rule s l old_metas deps
1979 | Ast.FinalScriptRulename
(Some s
,l
,deps
) ->
1980 do_parse_script_rule parse_fscript_rule s l old_metas deps
1981 | _
-> failwith
"Malformed rule name" in
1983 let rec loop old_metas starts_with_name
=
1984 (!Data.init_rule
)();
1986 let gen_starts_with_name more
tokens =
1988 (match List.hd
(List.rev tokens) with
1989 (PC.TArobArob
,_
) -> false
1990 | (PC.TArob
,_
) -> true
1991 | _
-> failwith
"unexpected token")
1994 let (more
, rule
, metavars, tokens) =
1995 parse_rule old_metas starts_with_name
in
1996 let all_metas = metavars @ old_metas
in
1999 let (all_rules
,all_metas) =
2000 loop all_metas (gen_starts_with_name more
tokens) in
2001 (rule
::all_rules
,all_metas)
2002 else ([rule
],all_metas) in
2004 let (all_rules
,all_metas) =
2005 loop extra_metas
(x = PC.TArob
) in
2008 (function prev
-> function cur -> Common.union_set
cur prev
)
2009 iso_files extra_iso_files
,
2010 (* included rules first *)
2011 List.fold_left
(function prev
-> function cur -> cur@prev
)
2012 all_rules
(List.rev extra_rules
),
2013 List.fold_left
(@) virt extra_virt
(*no dups allowed*),
2014 (all_metas : 'a list
))
2015 | _
-> failwith
"unexpected code before the first rule\n")
2016 | (false,[(PC.TArobArob
,_
)]) | (false,[(PC.TArob
,_
)]) ->
2017 ([],([] : Ast0.parsed_rule list
),[] (*virtual rules*), [] (*all metas*))
2018 | _
-> failwith
"unexpected code before the first rule\n" in
2022 (* parse to ast0 and then convert to ast *)
2023 let process file isofile verbose
=
2024 let extra_path = Filename.dirname
file in
2025 let (iso_files
, rules
, virt
, _metas
) = parse file in
2030 | Some iso_file
-> parse_iso_files [] [Common.Left iso_file
] "" in
2031 let global_isos = parse_iso_files std_isos iso_files
extra_path in
2032 let rules = Unitary_ast0.do_unitary
rules in
2036 Ast0.ScriptRule
(a
,b
,c
,d
,fv
,e
) ->
2037 [([],Ast.ScriptRule
(a
,b
,c
,d
,fv
,e
))]
2038 | Ast0.InitialScriptRule
(a
,b
,c
,d
) ->
2039 [([],Ast.InitialScriptRule
(a
,b
,c
,d
))]
2040 | Ast0.FinalScriptRule
(a
,b
,c
,d
) ->
2041 [([],Ast.FinalScriptRule
(a
,b
,c
,d
))]
2044 (iso
, dropiso, dependencies
, rule_name
, exists
)),
2045 (plus
, metavars),ruletype
) ->
2047 parse_iso_files global_isos
2048 (List.map
(function x -> Common.Left
x) iso
)
2051 (* check that dropped isos are actually available *)
2054 List.map
(function (_
,_
,nm
) -> nm
) chosen_isos in
2055 let local_iso_names = reserved_names @ iso_names in
2058 (function dropped
->
2059 not
(List.mem dropped
local_iso_names))
2062 ("invalid iso name " ^
bad_dropped ^
" in " ^ rule_name
)
2063 with Not_found
-> ());
2064 if List.mem
"all" dropiso
2066 if List.length
dropiso = 1
2068 else failwith
"disable all should only be by itself"
2069 else (* drop those isos *)
2071 (function (_
,_
,nm
) -> not
(List.mem nm
dropiso))
2074 match reserved_names with
2079 List.filter
(function x -> List.mem
x dropiso) others
)
2082 "bad list of reserved names - all must be at start" in
2083 let minus = Test_exps.process minus in
2084 let minus = Compute_lines.compute_lines
false minus in
2085 let plus = Compute_lines.compute_lines
false plus in
2087 (* only relevant to Flag.make_hrule *)
2088 (* doesn't handle multiple minirules properly, but since
2089 we don't really handle them in lots of other ways, it
2090 doesn't seem very important *)
2094 [match Ast0.unwrap p
with
2096 (match List.map
Ast0.unwrap
(Ast0.undots c
) with
2097 [Ast0.Exp e
] -> true | _
-> false)
2099 let minus = Arity.minus_arity
minus in
2100 let ((metavars,minus),function_prototypes
) =
2101 Function_prototypes.process
2102 rule_name
metavars dropped_isos minus plus ruletype
in
2103 let plus = Adjust_pragmas.process plus in
2104 (* warning! context_neg side-effects its arguments *)
2105 let (m
,p
) = List.split (Context_neg.context_neg
minus plus) in
2106 Type_infer.type_infer p
;
2107 (if not
(!Flag.sgrep_mode2
or dependencies
= Ast.FailDep
)
2108 then Insert_plus.insert_plus m p
(chosen_isos = []));
2109 Type_infer.type_infer
minus;
2110 let (extra_meta
, minus) =
2111 match (chosen_isos,ruletype
) with
2112 (* separate case for [] because applying isos puts
2113 some restrictions on the -+ code *)
2114 ([],_
) | (_
,Ast.Generated
) -> ([],minus)
2115 | _
-> Iso_pattern.apply_isos
chosen_isos minus rule_name
in
2116 (* after iso, because iso can intro ... *)
2117 let minus = Adjacency.compute_adjacency
minus in
2118 let minus = Comm_assoc.comm_assoc
minus rule_name
dropiso in
2120 if !Flag.sgrep_mode2
then minus
2121 else Single_statement.single_statement
minus in
2122 let minus = Simple_assignments.simple_assignments
minus in
2123 (* has to be last, introduced AsExpr, etc *)
2124 let minus = Get_metas.process minus in
2126 Ast0toast.ast0toast rule_name dependencies
dropped_isos
2127 exists
minus is_exp ruletype
in
2129 match function_prototypes
with
2130 None
-> [(extra_meta
@ metavars, minus_ast)]
2131 | Some mv_fp
-> [(extra_meta
@ metavars, minus_ast); mv_fp
])
2132 (* Ast0.CocciRule ((minus, metavarsm, (iso, dropiso, dependencies, rule_name, exists)), (plus, metavars))*)
2135 let parsed = List.concat
parsed in
2136 let parsed = Safe_for_multi_decls.safe_for_multi_decls
parsed in
2137 let disjd = Disjdistr.disj
parsed in
2139 let (metavars,code
,fvs
,neg_pos
,ua
,pos
) = Free_vars.free_vars
disjd in
2140 if !Flag_parsing_cocci.show_SP
2141 then List.iter
Pretty_print_cocci.unparse code
;
2144 Common.profile_code
"get_glimpse_constants" (* for glimpse *)
2145 (fun () -> Get_constants2.get_constants code neg_pos
) in
2147 (metavars,code
,fvs
,neg_pos
,ua
,pos
,search_tokens)