2 * Copyright 2010, INRIA, University of Copenhagen
3 * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
4 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
5 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
6 * This file is part of Coccinelle.
8 * Coccinelle is free software: you can redistribute it and/or modify
9 * it under the terms of the GNU General Public License as published by
10 * the Free Software Foundation, according to version 2 of the License.
12 * Coccinelle is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
17 * You should have received a copy of the GNU General Public License
18 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
20 * The authors reserve the right to distribute this or future versions of
21 * Coccinelle under other licenses.
25 (* Yoann Padioleau, Julia Lawall
27 * Copyright (C) 2006, 2007, 2008 Ecole des Mines de Nantes
29 * This program is free software; you can redistribute it and/or
30 * modify it under the terms of the GNU General Public License (GPL)
31 * version 2 as published by the Free Software Foundation.
33 * This program is distributed in the hope that it will be useful,
34 * but WITHOUT ANY WARRANTY; without even the implied warranty of
35 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
36 * file license.txt for more details.
38 * This file was part of Coccinelle.
46 module F
= Control_flow_c
48 module Flag
= Flag_matcher
50 (*****************************************************************************)
52 (*****************************************************************************)
53 let pr2, pr2_once
= Common.mk_pr2_wrappers
Flag_matcher.verbose_matcher
55 (*****************************************************************************)
57 (*****************************************************************************)
59 type sequence
= Ordered
| Unordered
62 match A.unwrap eas
with
64 | A.CIRCLES _
-> Unordered
65 | A.STARS _
-> failwith
"not handling stars"
67 let (redots
: 'a
A.dots
-> 'a list
-> 'a
A.dots
)=fun eas easundots
->
69 match A.unwrap eas
with
70 | A.DOTS _
-> A.DOTS easundots
71 | A.CIRCLES _
-> A.CIRCLES easundots
72 | A.STARS _
-> A.STARS easundots
76 let (need_unordered_initialisers
: B.initialiser
B.wrap2 list
-> bool) =
78 ibs
+> List.exists
(fun (ib
, icomma
) ->
79 match B.unwrap ib
with
88 (* For the #include <linux/...> in the .cocci, need to find where is
89 * the '+' attached to this element, to later find the first concrete
90 * #include <linux/xxx.h> or last one in the serie of #includes in the
93 type include_requirement
=
100 (* todo? put in semantic_c.ml *)
103 | LocalFunction
(* entails Function *)
107 let term mc
= A.unwrap_mcode mc
108 let mcodekind mc
= A.get_mcodekind mc
111 let mcode_contain_plus = function
112 | A.CONTEXT
(_
,A.NOTHING
) -> false
113 | A.CONTEXT _
-> true
114 | A.MINUS
(_
,_
,_
,[]) -> false
115 | A.MINUS
(_
,_
,_
,x
::xs
) -> true
116 | A.PLUS _
-> raise Impossible
118 let mcode_simple_minus = function
119 | A.MINUS
(_
,_
,_
,[]) -> true
123 (* In transformation.ml sometime I build some mcodekind myself and
124 * julia has put None for the pos. But there is no possible raise
125 * NoMatch in those cases because it is for the minusall trick or for
126 * the distribute, so either have to build those pos, in fact a range,
127 * because for the distribute have to erase a fullType with one
128 * mcodekind, or add an argument to tag_with_mck such as "safe" that
129 * don't do the check_pos. Hence this DontCarePos constructor. *)
133 {A.line
= 0; A.column
=0; A.strbef
=[]; A.straft
=[];},
134 (A.MINUS
(A.DontCarePos
,[],-1,[])),
137 let generalize_mcode ia
=
138 let (s1
, i
, mck
, pos
) = ia
in
141 | A.PLUS _
-> raise Impossible
142 | A.CONTEXT
(A.NoPos
,x
) ->
143 A.CONTEXT
(A.DontCarePos
,x
)
144 | A.MINUS
(A.NoPos
,inst
,adj
,x
) ->
145 A.MINUS
(A.DontCarePos
,inst
,adj
,x
)
147 | A.CONTEXT
((A.FixPos _
|A.DontCarePos
), _
)
148 | A.MINUS
((A.FixPos _
|A.DontCarePos
), _
, _
, _
)
152 (s1
, i
, new_mck, pos
)
156 (*---------------------------------------------------------------------------*)
158 (* 0x0 is equivalent to 0, value format isomorphism *)
159 let equal_c_int s1 s2
=
161 int_of_string s1
=|= int_of_string s2
162 with Failure
("int_of_string") ->
167 (*---------------------------------------------------------------------------*)
168 (* Normally A should reuse some types of Ast_c, so those
169 * functions should not exist.
171 * update: but now Ast_c depends on A, so can't make too
172 * A depends on Ast_c, so have to stay with those equal_xxx
176 let equal_unaryOp a b
=
178 | A.GetRef
, B.GetRef
-> true
179 | A.DeRef
, B.DeRef
-> true
180 | A.UnPlus
, B.UnPlus
-> true
181 | A.UnMinus
, B.UnMinus
-> true
182 | A.Tilde
, B.Tilde
-> true
183 | A.Not
, B.Not
-> true
184 | _
, B.GetRefLabel
-> false (* todo cocci? *)
185 | _
, (B.Not
|B.Tilde
|B.UnMinus
|B.UnPlus
|B.DeRef
|B.GetRef
) -> false
189 let equal_arithOp a b
=
191 | A.Plus
, B.Plus
-> true
192 | A.Minus
, B.Minus
-> true
193 | A.Mul
, B.Mul
-> true
194 | A.Div
, B.Div
-> true
195 | A.Mod
, B.Mod
-> true
196 | A.DecLeft
, B.DecLeft
-> true
197 | A.DecRight
, B.DecRight
-> true
198 | A.And
, B.And
-> true
199 | A.Or
, B.Or
-> true
200 | A.Xor
, B.Xor
-> true
201 | _
, (B.Xor
|B.Or
|B.And
|B.DecRight
|B.DecLeft
|B.Mod
|B.Div
|B.Mul
|B.Minus
|B.Plus
)
204 let equal_logicalOp a b
=
206 | A.Inf
, B.Inf
-> true
207 | A.Sup
, B.Sup
-> true
208 | A.InfEq
, B.InfEq
-> true
209 | A.SupEq
, B.SupEq
-> true
210 | A.Eq
, B.Eq
-> true
211 | A.NotEq
, B.NotEq
-> true
212 | A.AndLog
, B.AndLog
-> true
213 | A.OrLog
, B.OrLog
-> true
214 | _
, (B.OrLog
|B.AndLog
|B.NotEq
|B.Eq
|B.SupEq
|B.InfEq
|B.Sup
|B.Inf
)
217 let equal_assignOp a b
=
219 | A.SimpleAssign
, B.SimpleAssign
-> true
220 | A.OpAssign a
, B.OpAssign b
-> equal_arithOp a b
221 | _
, (B.OpAssign _
|B.SimpleAssign
) -> false
223 let equal_fixOp a b
=
225 | A.Dec
, B.Dec
-> true
226 | A.Inc
, B.Inc
-> true
227 | _
, (B.Inc
|B.Dec
) -> false
229 let equal_binaryOp a b
=
231 | A.Arith a
, B.Arith b
-> equal_arithOp a b
232 | A.Logical a
, B.Logical b
-> equal_logicalOp a b
233 | _
, (B.Logical _
| B.Arith _
) -> false
235 let equal_structUnion a b
=
237 | A.Struct
, B.Struct
-> true
238 | A.Union
, B.Union
-> true
239 | _
, (B.Struct
|B.Union
) -> false
243 | A.Signed
, B.Signed
-> true
244 | A.Unsigned
, B.UnSigned
-> true
245 | _
, (B.UnSigned
|B.Signed
) -> false
247 let equal_storage a b
=
249 | A.Static
, B.Sto
B.Static
250 | A.Auto
, B.Sto
B.Auto
251 | A.Register
, B.Sto
B.Register
252 | A.Extern
, B.Sto
B.Extern
254 | _
, (B.NoSto
| B.StoTypedef
) -> false
255 | _
, (B.Sto
(B.Register
|B.Static
|B.Auto
|B.Extern
)) -> false
258 (*---------------------------------------------------------------------------*)
260 let equal_metavarval valu valu'
=
261 match valu
, valu'
with
262 | Ast_c.MetaIdVal
(a
,_
), Ast_c.MetaIdVal
(b
,_
) -> a
=$
= b
263 | Ast_c.MetaFuncVal a
, Ast_c.MetaFuncVal b
-> a
=$
= b
264 | Ast_c.MetaLocalFuncVal a
, Ast_c.MetaLocalFuncVal b
->
265 (* do something more ? *)
268 (* al_expr before comparing !!! and accept when they match.
269 * Note that here we have Astc._expression, so it is a match
270 * modulo isomorphism (there is no metavariable involved here,
271 * just isomorphisms). => TODO call isomorphism_c_c instead of
272 * =*=. Maybe would be easier to transform ast_c in ast_cocci
273 * and call the iso engine of julia. *)
274 | Ast_c.MetaExprVal
(a
,_
), Ast_c.MetaExprVal
(b
,_
) ->
275 Lib_parsing_c.al_expr a
=*= Lib_parsing_c.al_expr b
276 | Ast_c.MetaExprListVal a
, Ast_c.MetaExprListVal b
->
277 Lib_parsing_c.al_arguments a
=*= Lib_parsing_c.al_arguments b
279 | Ast_c.MetaDeclVal a
, Ast_c.MetaDeclVal b
->
280 Lib_parsing_c.al_declaration a
=*= Lib_parsing_c.al_declaration b
281 | Ast_c.MetaFieldVal a
, Ast_c.MetaFieldVal b
->
282 Lib_parsing_c.al_field a
=*= Lib_parsing_c.al_field b
283 | Ast_c.MetaStmtVal a
, Ast_c.MetaStmtVal b
->
284 Lib_parsing_c.al_statement a
=*= Lib_parsing_c.al_statement b
285 | Ast_c.MetaInitVal a
, Ast_c.MetaInitVal b
->
286 Lib_parsing_c.al_init a
=*= Lib_parsing_c.al_init b
287 | Ast_c.MetaTypeVal a
, Ast_c.MetaTypeVal b
->
288 (* old: Lib_parsing_c.al_type a =*= Lib_parsing_c.al_type b *)
291 | Ast_c.MetaListlenVal a
, Ast_c.MetaListlenVal b
-> a
=|= b
293 | Ast_c.MetaParamVal a
, Ast_c.MetaParamVal b
->
294 Lib_parsing_c.al_param a
=*= Lib_parsing_c.al_param b
295 | Ast_c.MetaParamListVal a
, Ast_c.MetaParamListVal b
->
296 Lib_parsing_c.al_params a
=*= Lib_parsing_c.al_params b
298 | Ast_c.MetaPosVal
(posa1
,posa2
), Ast_c.MetaPosVal
(posb1
,posb2
) ->
299 Ast_cocci.equal_pos posa1 posb1
&& Ast_cocci.equal_pos posa2 posb2
301 | Ast_c.MetaPosValList l1
, Ast_c.MetaPosValList l2
->
303 (function (fla
,cea
,posa1
,posa2
) ->
305 (function (flb
,ceb
,posb1
,posb2
) ->
306 fla
=$
= flb
&& cea
=$
= ceb
&&
307 Ast_c.equal_posl posa1 posb1
&& Ast_c.equal_posl posa2 posb2
)
311 | (B.MetaPosValList _
|B.MetaListlenVal _
|B.MetaPosVal _
|B.MetaStmtVal _
312 |B.MetaDeclVal _
|B.MetaFieldVal _
|B.MetaTypeVal _
|B.MetaInitVal _
313 |B.MetaParamListVal _
|B.MetaParamVal _
|B.MetaExprListVal _
314 |B.MetaExprVal _
|B.MetaLocalFuncVal _
|B.MetaFuncVal _
|B.MetaIdVal _
318 (* probably only one argument needs to be stripped, because inherited
319 metavariables containing expressions are stripped in advance. But don't
320 know which one is which... *)
321 let equal_inh_metavarval valu valu'
=
322 match valu
, valu'
with
323 | Ast_c.MetaIdVal
(a
,_
), Ast_c.MetaIdVal
(b
,_
) -> a
=$
= b
324 | Ast_c.MetaFuncVal a
, Ast_c.MetaFuncVal b
-> a
=$
= b
325 | Ast_c.MetaLocalFuncVal a
, Ast_c.MetaLocalFuncVal b
->
326 (* do something more ? *)
329 (* al_expr before comparing !!! and accept when they match.
330 * Note that here we have Astc._expression, so it is a match
331 * modulo isomorphism (there is no metavariable involved here,
332 * just isomorphisms). => TODO call isomorphism_c_c instead of
333 * =*=. Maybe would be easier to transform ast_c in ast_cocci
334 * and call the iso engine of julia. *)
335 | Ast_c.MetaExprVal
(a
,_
), Ast_c.MetaExprVal
(b
,_
) ->
336 Lib_parsing_c.al_inh_expr a
=*= Lib_parsing_c.al_inh_expr b
337 | Ast_c.MetaExprListVal a
, Ast_c.MetaExprListVal b
->
338 Lib_parsing_c.al_inh_arguments a
=*= Lib_parsing_c.al_inh_arguments b
340 | Ast_c.MetaDeclVal a
, Ast_c.MetaDeclVal b
->
341 Lib_parsing_c.al_inh_declaration a
=*= Lib_parsing_c.al_inh_declaration b
342 | Ast_c.MetaFieldVal a
, Ast_c.MetaFieldVal b
->
343 Lib_parsing_c.al_inh_field a
=*= Lib_parsing_c.al_inh_field b
344 | Ast_c.MetaStmtVal a
, Ast_c.MetaStmtVal b
->
345 Lib_parsing_c.al_inh_statement a
=*= Lib_parsing_c.al_inh_statement b
346 | Ast_c.MetaInitVal a
, Ast_c.MetaInitVal b
->
347 Lib_parsing_c.al_inh_init a
=*= Lib_parsing_c.al_inh_init b
348 | Ast_c.MetaTypeVal a
, Ast_c.MetaTypeVal b
->
349 (* old: Lib_parsing_c.al_inh_type a =*= Lib_parsing_c.al_inh_type b *)
352 | Ast_c.MetaListlenVal a
, Ast_c.MetaListlenVal b
-> a
=|= b
354 | Ast_c.MetaParamVal a
, Ast_c.MetaParamVal b
->
355 Lib_parsing_c.al_param a
=*= Lib_parsing_c.al_param b
356 | Ast_c.MetaParamListVal a
, Ast_c.MetaParamListVal b
->
357 Lib_parsing_c.al_params a
=*= Lib_parsing_c.al_params b
359 | Ast_c.MetaPosVal
(posa1
,posa2
), Ast_c.MetaPosVal
(posb1
,posb2
) ->
360 Ast_cocci.equal_pos posa1 posb1
&& Ast_cocci.equal_pos posa2 posb2
362 | Ast_c.MetaPosValList l1
, Ast_c.MetaPosValList l2
->
364 (function (fla
,cea
,posa1
,posa2
) ->
366 (function (flb
,ceb
,posb1
,posb2
) ->
367 fla
=$
= flb
&& cea
=$
= ceb
&&
368 Ast_c.equal_posl posa1 posb1
&& Ast_c.equal_posl posa2 posb2
)
372 | (B.MetaPosValList _
|B.MetaListlenVal _
|B.MetaPosVal _
|B.MetaStmtVal _
373 |B.MetaDeclVal _
|B.MetaFieldVal _
|B.MetaTypeVal _
|B.MetaInitVal _
374 |B.MetaParamListVal _
|B.MetaParamVal _
|B.MetaExprListVal _
375 |B.MetaExprVal _
|B.MetaLocalFuncVal _
|B.MetaFuncVal _
|B.MetaIdVal _
380 (*---------------------------------------------------------------------------*)
381 (* could put in ast_c.ml, next to the split/unsplit_comma *)
382 let split_signb_baseb_ii (baseb
, ii
) =
383 let iis = ii
+> List.map
(fun info
-> (B.str_of_info info
), info
) in
384 match baseb
, iis with
386 | B.Void
, ["void",i1
] -> None
, [i1
]
388 | B.FloatType
(B.CFloat
),["float",i1
] -> None
, [i1
]
389 | B.FloatType
(B.CDouble
),["double",i1
] -> None
, [i1
]
390 | B.FloatType
(B.CLongDouble
),["long",i1
;"double",i2
] -> None
,[i1
;i2
]
392 | B.IntType
(B.CChar
), ["char",i1
] -> None
, [i1
]
395 | B.IntType
(B.Si
(sign
, base
)), xs
->
399 | (B.Signed
,(("signed",i1
)::rest
)) -> (Some
(B.Signed
,i1
),rest
)
400 | (B.Signed
,rest
) -> (None
,rest
)
401 | (B.UnSigned
,(("unsigned",i1
)::rest
)) -> (Some
(B.UnSigned
,i1
),rest
)
402 | (B.UnSigned
,rest
) -> (* is this case possible? *) (None
,rest
) in
403 (* The original code only allowed explicit signed and unsigned for char,
404 while this code allows char by itself. Not sure that needs to be
405 checked for here. If it does, then add a special case. *)
407 match (base
,rest
) with
408 B.CInt
, ["int",i1
] -> [i1
]
411 | B.CInt
, ["",i1
] -> (* no type is specified at all *)
412 (match i1
.B.pinfo
with
414 | _
-> failwith
("unrecognized signed int: "^
415 (String.concat
" "(List.map fst
iis))))
417 | B.CChar2
, ["char",i2
] -> [i2
]
419 | B.CShort
, ["short",i1
] -> [i1
]
420 | B.CShort
, ["short",i1
;"int",i2
] -> [i1
;i2
]
422 | B.CLong
, ["long",i1
] -> [i1
]
423 | B.CLong
, ["long",i1
;"int",i2
] -> [i1
;i2
]
425 | B.CLongLong
, ["long",i1
;"long",i2
] -> [i1
;i2
]
426 | B.CLongLong
, ["long",i1
;"long",i2
;"int",i3
] -> [i1
;i2
;i3
]
429 failwith
("strange type1, maybe because of weird order: "^
430 (String.concat
" " (List.map fst
iis))) in
432 | _
-> failwith
("strange type2, maybe because of weird order: "^
433 (String.concat
" " (List.map fst
iis)))
435 (*---------------------------------------------------------------------------*)
437 let rec unsplit_icomma xs
=
441 (match A.unwrap y
with
443 (x
, y
)::unsplit_icomma xs
444 | _
-> failwith
"wrong ast_cocci in initializer"
447 failwith
("wrong ast_cocci in initializer, should have pair " ^
452 let resplit_initialiser ibs iicomma
=
453 match iicomma
, ibs
with
456 failwith
"should have a iicomma, do you generate fakeInfo in parser?"
458 failwith
"shouldn't have a iicomma"
459 | [iicomma
], x
::xs
->
460 let elems = List.map fst
(x
::xs
) in
461 let commas = List.map snd
(x
::xs
) +> List.flatten
in
462 let commas = commas @ [iicomma
] in
464 | _
-> raise Impossible
468 let rec split_icomma xs
=
471 | (x
,y
)::xs
-> x
::y
::split_icomma xs
473 let rec unsplit_initialiser ibs_unsplit
=
474 match ibs_unsplit
with
475 | [] -> [], [] (* empty iicomma *)
477 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
478 (x
, [])::xs
, lastcomma
480 and unsplit_initialiser_bis comma_before
= function
481 | [] -> [], [comma_before
]
483 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
484 (x
, [comma_before
])::xs
, lastcomma
489 (*---------------------------------------------------------------------------*)
490 (* coupling: same in type_annotater_c.ml *)
491 let structdef_to_struct_name ty
=
493 | qu
, (B.StructUnion
(su
, sopt
, fields
), iis) ->
495 | Some s
, [i1
;i2
;i3
;i4
] ->
496 qu
, (B.StructUnionName
(su
, s
), [i1
;i2
])
500 | x
-> raise Impossible
502 | _
-> raise Impossible
504 (*---------------------------------------------------------------------------*)
505 let initialisation_to_affectation decl
=
507 | B.MacroDecl _
-> F.Decl decl
508 | B.DeclList
(xs
, iis) ->
510 (* todo?: should not do that if the variable is an array cos
511 * will have x[] = , mais de toute facon ca sera pas un InitExp
514 | [] -> raise Impossible
516 let ({B.v_namei
= var
;
517 B.v_type
= returnType
;
518 B.v_type_bis
= tybis
;
519 B.v_storage
= storage
;
526 | Some
(name
, iniopt
) ->
528 | Some
(iini
, (B.InitExpr e
, ii_empty2
)) ->
532 Ast_c.NotLocalDecl
-> Ast_c.NotLocalVar
534 Ast_c.LocalVar
(Ast_c.info_of_type returnType
) in
537 (* old: Lib_parsing_c.al_type returnType
538 * but this type has not the typename completed so
539 * instead try to use tybis
542 | Some ty_with_typename_completed
->
543 ty_with_typename_completed
544 | None
-> raise Impossible
548 ref (Some
(typexp,local),
552 Ast_c.mk_e_bis
(B.Ident
(ident)) typ Ast_c.noii
556 (B.Assignment
(idexpr,B.SimpleAssign
, e
)) [iini
] in
564 pr2_once
"TODO: initialisation_to_affectation for multi vars";
565 (* todo? do a fold_left and generate 'x = a, y = b' etc, use
566 * the Sequence expression operator of C and make an
567 * ExprStatement from that.
576 (*****************************************************************************)
577 (* Functor parameter combinators *)
578 (*****************************************************************************)
580 * src: papers on parser combinators in haskell (cf a pearl by meijer in ICFP)
582 * version0: was not tagging the SP, so just tag the C
584 * (tin -> 'c tout) -> ('c -> (tin -> 'b tout)) -> (tin -> 'b tout)
585 * val return : 'b -> tin -> 'b tout
586 * val fail : tin -> 'b tout
588 * version1: now also tag the SP so return a ('a * 'b)
591 type mode
= PatternMode
| TransformMode
599 type ('a
, 'b
) matcher
= 'a
-> 'b
-> tin
-> ('a
* 'b
) tout
604 (tin
-> ('a
* 'b
) tout
) ->
605 ('a
-> 'b
-> (tin
-> ('c
* 'd
) tout
)) ->
606 (tin
-> ('c
* 'd
) tout
)
608 val return
: ('a
* 'b
) -> tin
-> ('a
*'b
) tout
609 val fail
: tin
-> ('a
* 'b
) tout
621 val (>&&>) : (tin
-> bool) -> (tin
-> 'x tout
) -> (tin
-> 'x tout
)
623 val tokenf
: ('a
A.mcode
, B.info
) matcher
624 val tokenf_mck
: (A.mcodekind, B.info
) matcher
627 (A.meta_name
A.mcode
, B.expression
) matcher
629 (A.meta_name
A.mcode
, (Ast_c.argument
, Ast_c.il
) either list
) matcher
631 (A.meta_name
A.mcode
, Ast_c.fullType
) matcher
633 (A.meta_name
A.mcode
,
634 (Ast_c.parameterType
, Ast_c.il
) either list
) matcher
636 (A.meta_name
A.mcode
, Ast_c.parameterType
) matcher
638 (A.meta_name
A.mcode
, Ast_c.initialiser
) matcher
640 (A.meta_name
A.mcode
, Ast_c.declaration
) matcher
642 (A.meta_name
A.mcode
, Ast_c.field
) matcher
644 (A.meta_name
A.mcode
, Control_flow_c.node
) matcher
646 val distrf_define_params
:
647 (A.meta_name
A.mcode
, (string Ast_c.wrap
, Ast_c.il
) either list
)
650 val distrf_struct_fields
:
651 (A.meta_name
A.mcode
, B.field list
) matcher
654 (A.meta_name
A.mcode
, (B.constant
, string) either
B.wrap
) matcher
657 (A.expression
, B.expression
) matcher
-> (A.expression
, F.node
) matcher
660 (A.expression
, B.expression
) matcher
->
661 (A.expression
, B.expression
) matcher
664 (A.fullType
, B.fullType
) matcher
-> (A.fullType
, F.node
) matcher
667 (A.initialiser
, B.initialiser
) matcher
-> (A.initialiser
, F.node
) matcher
670 A.keep_binding
-> A.inherited
->
671 A.meta_name
A.mcode
* Ast_c.metavar_binding_kind
*
672 (unit -> Common.filename
* string * Ast_c.posl
* Ast_c.posl
) ->
673 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
675 val check_idconstraint
:
676 ('a
-> 'b
-> bool) -> 'a
-> 'b
->
677 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
679 val check_constraints_ne
:
680 ('a
, 'b
) matcher
-> 'a list
-> 'b
->
681 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
683 val all_bound
: A.meta_name list
-> (tin
-> bool)
685 val optional_storage_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
686 val optional_qualifier_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
687 val value_format_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
692 (*****************************************************************************)
693 (* Functor code, "Cocci vs C" *)
694 (*****************************************************************************)
697 functor (X
: PARAM
) ->
700 type ('a
, 'b
) matcher
= 'a
-> 'b
-> X.tin
-> ('a
* 'b
) X.tout
703 let return = X.return
706 let (>||>) = X.(>||>)
707 let (>|+|>) = X.(>|+|>)
708 let (>&&>) = X.(>&&>)
710 let tokenf = X.tokenf
712 (* should be raise Impossible when called from transformation.ml *)
715 | PatternMode
-> fail
716 | TransformMode
-> raise Impossible
719 let (option: ('a
,'b
) matcher
-> ('a
option,'b
option) matcher
)= fun f t1 t2
->
721 | (Some t1
, Some t2
) ->
722 f t1 t2
>>= (fun t1 t2
->
723 return (Some t1
, Some t2
)
725 | (None
, None
) -> return (None
, None
)
728 (* Dots are sometimes used as metavariables, since like metavariables they
729 can match other things. But they no longer have the same type. Perhaps these
730 functions could be avoided by introducing an appropriate level of polymorphism,
731 but I don't know how to declare polymorphism across functors *)
732 let dots2metavar (_
,info
,mcodekind,pos
) =
733 (("","..."),info
,mcodekind,pos
)
734 let metavar2dots (_
,info
,mcodekind,pos
) = ("...",info
,mcodekind,pos
)
736 let satisfies_regexpconstraint c id
: bool =
738 A.IdRegExp
(_
,recompiled
) -> Str.string_match recompiled id
0
739 | A.IdNotRegExp
(_
,recompiled
) -> not
(Str.string_match recompiled id
0)
741 let satisfies_iconstraint c id
: bool =
744 let satisfies_econstraint c exp
: bool =
745 let warning s
= pr2_once
("WARNING: "^s
); false in
746 match Ast_c.unwrap_expr exp
with
747 Ast_c.Ident
(name
) ->
749 Ast_c.RegularName rname
->
750 satisfies_regexpconstraint c
(Ast_c.unwrap_st rname
)
751 | Ast_c.CppConcatenatedName _
->
753 "Unable to apply a constraint on a CppConcatenatedName identifier!"
754 | Ast_c.CppVariadicName _
->
756 "Unable to apply a constraint on a CppVariadicName identifier!"
757 | Ast_c.CppIdentBuilder _
->
759 "Unable to apply a constraint on a CppIdentBuilder identifier!")
760 | Ast_c.Constant cst
->
762 | Ast_c.String
(str
, _
) -> satisfies_regexpconstraint c str
763 | Ast_c.MultiString strlist
->
764 warning "Unable to apply a constraint on an multistring constant!"
765 | Ast_c.Char
(char
, _
) -> satisfies_regexpconstraint c char
766 | Ast_c.Int
(int , _
) -> satisfies_regexpconstraint c
int
767 | Ast_c.Float
(float, _
) -> satisfies_regexpconstraint c
float)
768 | _
-> warning "Unable to apply a constraint on an expression!"
770 (*---------------------------------------------------------------------------*)
782 (*---------------------------------------------------------------------------*)
783 let rec (expression
: (A.expression
, Ast_c.expression
) matcher
) =
785 if A.get_test_exp ea
&& not
(Ast_c.is_test eb
) then fail
787 X.all_bound
(A.get_inherited ea
) >&&>
788 let wa x
= A.rewrap ea x
in
789 match A.unwrap ea
, eb
with
791 (* general case: a MetaExpr can match everything *)
792 | A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
),
793 (((expr
, opttypb
), ii
) as expb
) ->
795 (* old: before have a MetaConst. Now we factorize and use 'form' to
796 * differentiate between different cases *)
797 let rec matches_id = function
798 B.Ident
(name
) -> true
799 | B.Cast
(ty
,e
) -> matches_id (B.unwrap_expr e
)
802 match (form
,expr
) with
805 let rec matches = function
806 B.Constant
(c
) -> true
807 | B.Ident
(nameidb
) ->
808 let s = Ast_c.str_of_name nameidb
in
809 if s =~
"^[A-Z_][A-Z_0-9]*$"
811 pr2_once
("warning: " ^
s ^
" treated as a constant");
815 | B.Cast
(ty
,e
) -> matches (B.unwrap_expr e
)
816 | B.Unary
(e
,B.UnMinus
) -> matches (B.unwrap_expr e
)
817 | B.SizeOfExpr
(exp
) -> true
818 | B.SizeOfType
(ty
) -> true
824 (Some
(_
,Ast_c.LocalVar _
),_
) -> true
826 | (A.ID
,e
) -> matches_id e
in
830 (let (opttypb
,_testb
) = !opttypb
in
831 match opttypa
, opttypb
with
832 | None
, _
-> return ((),())
834 pr2_once
("Missing type information. Certainly a pb in " ^
835 "annotate_typer.ml");
838 | Some tas
, Some tb
->
839 tas
+> List.fold_left
(fun acc ta
->
840 acc
>|+|> compatible_type ta tb
) fail
843 let meta_expr_val l x
= Ast_c.MetaExprVal
(x
,l
) in
844 match constraints
with
845 Ast_cocci.NoConstraint
-> return (meta_expr_val [],())
846 | Ast_cocci.NotIdCstrt cstrt
->
847 X.check_idconstraint
satisfies_econstraint cstrt eb
848 (fun () -> return (meta_expr_val [],()))
849 | Ast_cocci.NotExpCstrt cstrts
->
850 X.check_constraints_ne expression cstrts eb
851 (fun () -> return (meta_expr_val [],()))
852 | Ast_cocci.SubExpCstrt cstrts
->
853 return (meta_expr_val cstrts
,()))
857 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_expr expb
) in
858 X.envf keep inherited
(ida
, wrapper expb
, max_min)
860 X.distrf_e ida expb
>>=
863 A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
)+>
871 * | A.MetaExpr(ida,false,opttypa,_inherited), expb ->
872 * D.distribute_mck (mcodekind ida) D.distribute_mck_e expb binding
874 * but bug! because if have not tagged SP, then transform without doing
875 * any checks. Hopefully now have tagged SP technique.
880 * | A.Edots _, _ -> raise Impossible.
882 * In fact now can also have the Edots inside normal expression, not
883 * just in arg lists. in 'x[...];' less: in if(<... x ... y ...>)
885 | A.Edots
(mcode
, None
), expb
->
886 X.distrf_e
(dots2metavar mcode
) expb
>>= (fun mcode expb
->
888 A.Edots
(metavar2dots mcode
, None
) +> A.rewrap ea
,
893 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
896 | A.Ident ida
, ((B.Ident
(nameidb
), typ),noii
) ->
898 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
900 ((A.Ident ida
)) +> wa,
901 ((B.Ident
(nameidb
), typ),Ast_c.noii
)
907 | A.MetaErr _
, _
-> failwith
"not handling MetaErr"
909 (* todo?: handle some isomorphisms in int/float ? can have different
910 * format : 1l can match a 1.
912 * todo: normally string can contain some metavar too, so should
913 * recurse on the string
915 | A.Constant
(ia1
), ((B.Constant
(ib
) , typ),ii
) ->
916 (* for everything except the String case where can have multi elems *)
918 let ib1 = tuple_of_list1 ii
in
919 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
921 ((A.Constant ia1
)) +> wa,
922 ((B.Constant
(ib
), typ),[ib1])
925 (match term ia1
, ib
with
926 | A.Int x
, B.Int
(y
,_
) ->
927 X.value_format_flag
(fun use_value_equivalence
->
928 if use_value_equivalence
938 | A.Char x
, B.Char
(y
,_
) when x
=$
= y
(* todo: use kind ? *)
940 | A.Float x
, B.Float
(y
,_
) when x
=$
= y
(* todo: use floatType ? *)
943 | A.String sa
, B.String
(sb
,_kind
) when sa
=$
= sb
->
946 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
948 ((A.Constant ia1
)) +> wa,
949 ((B.Constant
(ib
), typ),[ib1])
951 | _
-> fail (* multi string, not handled *)
954 | _
, B.MultiString _
-> (* todo cocci? *) fail
955 | _
, (B.String _
| B.Float _
| B.Char _
| B.Int _
) -> fail
959 | A.FunCall
(ea
, ia1
, eas
, ia2
), ((B.FunCall
(eb
, ebs
), typ),ii
) ->
960 (* todo: do special case to allow IdMetaFunc, cos doing the
961 * recursive call will be too late, match_ident will not have the
962 * info whether it was a function. todo: but how detect when do
963 * x.field = f; how know that f is a Func ? By having computed
964 * some information before the matching!
966 * Allow match with FunCall containing types. Now ast_cocci allow
967 * type in parameter, and morover ast_cocci allow f(...) and those
968 * ... could match type.
970 let (ib1, ib2
) = tuple_of_list2 ii
in
971 expression ea eb
>>= (fun ea eb
->
972 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
973 tokenf ia2 ib2
>>= (fun ia2 ib2
->
974 arguments
(seqstyle eas
) (A.undots eas
) ebs
>>= (fun easundots ebs
->
975 let eas = redots
eas easundots
in
977 ((A.FunCall
(ea
, ia1
, eas, ia2
)) +> wa,
978 ((B.FunCall
(eb
, ebs
),typ), [ib1;ib2
])
984 | A.Assignment
(ea1
, opa
, ea2
, simple
),
985 ((B.Assignment
(eb1
, opb
, eb2
), typ),ii
) ->
986 let (opbi
) = tuple_of_list1 ii
in
987 if equal_assignOp (term opa
) opb
989 expression ea1 eb1
>>= (fun ea1 eb1
->
990 expression ea2 eb2
>>= (fun ea2 eb2
->
991 tokenf opa opbi
>>= (fun opa opbi
->
993 ((A.Assignment
(ea1
, opa
, ea2
, simple
))) +> wa,
994 ((B.Assignment
(eb1
, opb
, eb2
), typ), [opbi
])
998 | A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
),((B.CondExpr
(eb1
,eb2opt
,eb3
),typ),ii
) ->
999 let (ib1, ib2
) = tuple_of_list2 ii
in
1000 expression ea1 eb1
>>= (fun ea1 eb1
->
1001 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
1002 expression ea3 eb3
>>= (fun ea3 eb3
->
1003 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1004 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1006 ((A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
))) +> wa,
1007 ((B.CondExpr
(eb1
, eb2opt
, eb3
),typ), [ib1;ib2
])
1010 (* todo?: handle some isomorphisms here ? *)
1011 | A.Postfix
(ea
, opa
), ((B.Postfix
(eb
, opb
), typ),ii
) ->
1012 let opbi = tuple_of_list1 ii
in
1013 if equal_fixOp (term opa
) opb
1015 expression ea eb
>>= (fun ea eb
->
1016 tokenf opa
opbi >>= (fun opa
opbi ->
1018 ((A.Postfix
(ea
, opa
))) +> wa,
1019 ((B.Postfix
(eb
, opb
), typ),[opbi])
1024 | A.Infix
(ea
, opa
), ((B.Infix
(eb
, opb
), typ),ii
) ->
1025 let opbi = tuple_of_list1 ii
in
1026 if equal_fixOp (term opa
) opb
1028 expression ea eb
>>= (fun ea eb
->
1029 tokenf opa
opbi >>= (fun opa
opbi ->
1031 ((A.Infix
(ea
, opa
))) +> wa,
1032 ((B.Infix
(eb
, opb
), typ),[opbi])
1036 | A.Unary
(ea
, opa
), ((B.Unary
(eb
, opb
), typ),ii
) ->
1037 let opbi = tuple_of_list1 ii
in
1038 if equal_unaryOp (term opa
) opb
1040 expression ea eb
>>= (fun ea eb
->
1041 tokenf opa
opbi >>= (fun opa
opbi ->
1043 ((A.Unary
(ea
, opa
))) +> wa,
1044 ((B.Unary
(eb
, opb
), typ),[opbi])
1048 | A.Binary
(ea1
, opa
, ea2
), ((B.Binary
(eb1
, opb
, eb2
), typ),ii
) ->
1049 let opbi = tuple_of_list1 ii
in
1050 if equal_binaryOp (term opa
) opb
1052 expression ea1 eb1
>>= (fun ea1 eb1
->
1053 expression ea2 eb2
>>= (fun ea2 eb2
->
1054 tokenf opa
opbi >>= (fun opa
opbi ->
1056 ((A.Binary
(ea1
, opa
, ea2
))) +> wa,
1057 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1061 | A.Nested
(ea1
, opa
, ea2
), eb
->
1063 expression ea1 eb
>|+|>
1065 ((B.Binary
(eb1
, opb
, eb2
), typ),ii
)
1066 when equal_binaryOp (term opa
) opb
->
1067 let opbi = tuple_of_list1 ii
in
1069 (expression ea1 eb1
>>= (fun ea1 eb1
->
1070 expression ea2 eb2
>>= (fun ea2 eb2
->
1071 tokenf opa
opbi >>= (fun opa
opbi ->
1073 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1074 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1077 (expression ea2 eb1
>>= (fun ea2 eb1
->
1078 expression ea1 eb2
>>= (fun ea1 eb2
->
1079 tokenf opa
opbi >>= (fun opa
opbi ->
1081 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1082 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1085 (loop eb1
>>= (fun ea1 eb1
->
1086 expression ea2 eb2
>>= (fun ea2 eb2
->
1087 tokenf opa
opbi >>= (fun opa
opbi ->
1089 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1090 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1093 (expression ea2 eb1
>>= (fun ea2 eb1
->
1094 loop eb2
>>= (fun ea1 eb2
->
1095 tokenf opa
opbi >>= (fun opa
opbi ->
1097 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1098 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1100 left_to_right >|+|> right_to_left >|+|> in_left >|+|> in_right
1104 (* todo?: handle some isomorphisms here ? (with pointers = Unary Deref) *)
1105 | A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
),((B.ArrayAccess
(eb1
, eb2
), typ),ii
) ->
1106 let (ib1, ib2
) = tuple_of_list2 ii
in
1107 expression ea1 eb1
>>= (fun ea1 eb1
->
1108 expression ea2 eb2
>>= (fun ea2 eb2
->
1109 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1110 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1112 ((A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
))) +> wa,
1113 ((B.ArrayAccess
(eb1
, eb2
),typ), [ib1;ib2
])
1116 (* todo?: handle some isomorphisms here ? *)
1117 | A.RecordAccess
(ea
, ia1
, ida
), ((B.RecordAccess
(eb
, idb
), typ),ii
) ->
1118 let (ib1) = tuple_of_list1 ii
in
1119 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
1120 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1121 expression ea eb
>>= (fun ea eb
->
1123 ((A.RecordAccess
(ea
, ia1
, ida
))) +> wa,
1124 ((B.RecordAccess
(eb
, idb
), typ), [ib1])
1129 | A.RecordPtAccess
(ea
,ia1
,ida
),((B.RecordPtAccess
(eb
, idb
), typ), ii
) ->
1130 let (ib1) = tuple_of_list1 ii
in
1131 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
1132 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1133 expression ea eb
>>= (fun ea eb
->
1135 ((A.RecordPtAccess
(ea
, ia1
, ida
))) +> wa,
1136 ((B.RecordPtAccess
(eb
, idb
), typ), [ib1])
1140 (* todo?: handle some isomorphisms here ?
1141 * todo?: do some iso-by-absence on cast ?
1142 * by trying | ea, B.Case (typb, eb) -> match_e_e ea eb ?
1145 | A.Cast
(ia1
, typa
, ia2
, ea
), ((B.Cast
(typb
, eb
), typ),ii
) ->
1146 let (ib1, ib2
) = tuple_of_list2 ii
in
1147 fullType typa typb
>>= (fun typa typb
->
1148 expression ea eb
>>= (fun ea eb
->
1149 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1150 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1152 ((A.Cast
(ia1
, typa
, ia2
, ea
))) +> wa,
1153 ((B.Cast
(typb
, eb
),typ),[ib1;ib2
])
1156 | A.SizeOfExpr
(ia1
, ea
), ((B.SizeOfExpr
(eb
), typ),ii
) ->
1157 let ib1 = tuple_of_list1 ii
in
1158 expression ea eb
>>= (fun ea eb
->
1159 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1161 ((A.SizeOfExpr
(ia1
, ea
))) +> wa,
1162 ((B.SizeOfExpr
(eb
), typ),[ib1])
1165 | A.SizeOfType
(ia1
, ia2
, typa
, ia3
), ((B.SizeOfType typb
, typ),ii
) ->
1166 let (ib1,ib2
,ib3
) = tuple_of_list3 ii
in
1167 fullType typa typb
>>= (fun typa typb
->
1168 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1169 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1170 tokenf ia3 ib3
>>= (fun ia3 ib3
->
1172 ((A.SizeOfType
(ia1
, ia2
, typa
, ia3
))) +> wa,
1173 ((B.SizeOfType
(typb
),typ),[ib1;ib2
;ib3
])
1177 (* todo? iso ? allow all the combinations ? *)
1178 | A.Paren
(ia1
, ea
, ia2
), ((B.ParenExpr
(eb
), typ),ii
) ->
1179 let (ib1, ib2
) = tuple_of_list2 ii
in
1180 expression ea eb
>>= (fun ea eb
->
1181 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1182 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1184 ((A.Paren
(ia1
, ea
, ia2
))) +> wa,
1185 ((B.ParenExpr
(eb
), typ), [ib1;ib2
])
1188 | A.NestExpr
(starter
,exps
,ender
,None
,true), eb
->
1189 (match A.get_mcodekind starter
with
1190 A.MINUS _
-> failwith
"TODO: only context nests supported"
1192 (match A.unwrap exps
with
1194 X.cocciExpExp expression exp eb
>>= (fun exp eb
->
1197 (starter
,A.rewrap exps
(A.DOTS
[exp
]),ender
,None
,true)) +> wa,
1203 "for nestexpr, only handling the case with dots and only one exp")
1205 | A.NestExpr _
, _
->
1206 failwith
"only handling multi and no when code in a nest expr"
1208 (* only in arg lists or in define body *)
1209 | A.TypeExp _
, _
-> fail
1211 (* only in arg lists *)
1212 | A.MetaExprList _
, _
1219 | A.DisjExpr
eas, eb
->
1220 eas +> List.fold_left
(fun acc ea
-> acc
>|+|> (expression ea eb
)) fail
1222 | A.UniqueExp _
,_
| A.OptExp _
,_
->
1223 failwith
"not handling Opt/Unique/Multi on expr"
1225 (* Because of Exp cant put a raise Impossible; have to put a fail *)
1227 (* have not a counter part in coccinelle, for the moment *)
1228 | _
, ((B.Sequence _
,_
),_
)
1229 | _
, ((B.StatementExpr _
,_
),_
)
1230 | _
, ((B.Constructor _
,_
),_
)
1235 (((B.Cast
(_
, _
)|B.ParenExpr _
|B.SizeOfType _
|B.SizeOfExpr _
|
1236 B.RecordPtAccess
(_
, _
)|
1237 B.RecordAccess
(_
, _
)|B.ArrayAccess
(_
, _
)|
1238 B.Binary
(_
, _
, _
)|B.Unary
(_
, _
)|
1239 B.Infix
(_
, _
)|B.Postfix
(_
, _
)|
1240 B.Assignment
(_
, _
, _
)|B.CondExpr
(_
, _
, _
)|
1241 B.FunCall
(_
, _
)|B.Constant _
|B.Ident _
),
1249 (* ------------------------------------------------------------------------- *)
1250 and (ident_cpp
: info_ident
-> (A.ident, B.name
) matcher
) =
1251 fun infoidb ida idb
->
1253 | B.RegularName
(s, iis) ->
1254 let iis = tuple_of_list1
iis in
1255 ident infoidb ida
(s, iis) >>= (fun ida
(s,iis) ->
1258 (B.RegularName
(s, [iis]))
1260 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
1262 (* This should be moved to the Id case of ident. Metavariables
1263 should be allowed to be bound to such variables. But doing so
1264 would require implementing an appropriate distr function *)
1267 and (ident: info_ident
-> (A.ident, string * Ast_c.info
) matcher
) =
1268 fun infoidb ida
((idb
, iib
)) -> (* (idb, iib) as ib *)
1269 let check_constraints constraints idb
=
1270 let meta_id_val l x
= Ast_c.MetaIdVal
(x
,l
) in
1271 match constraints
with
1272 A.IdNoConstraint
-> return (meta_id_val [],())
1273 | A.IdNegIdSet
(str
,meta
) ->
1274 X.check_idconstraint
satisfies_iconstraint str idb
1275 (fun () -> return (meta_id_val meta
,()))
1276 | A.IdRegExpConstraint re
->
1277 X.check_idconstraint
satisfies_regexpconstraint re idb
1278 (fun () -> return (meta_id_val [],())) in
1279 X.all_bound
(A.get_inherited ida
) >&&>
1280 match A.unwrap ida
with
1282 if (term sa
) =$
= idb
then
1283 tokenf sa iib
>>= (fun sa iib
->
1285 ((A.Id sa
)) +> A.rewrap ida
,
1290 | A.MetaId
(mida
,constraints
,keep
,inherited
) ->
1291 check_constraints constraints idb
>>=
1293 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1294 (* use drop_pos for ids so that the pos is not added a second time in
1295 the call to tokenf *)
1296 X.envf keep inherited
(A.drop_pos mida
, wrapper idb
, max_min)
1298 tokenf mida iib
>>= (fun mida iib
->
1300 ((A.MetaId
(mida
, constraints
, keep
, inherited
)) +> A.rewrap ida
,
1305 | A.MetaFunc
(mida
,constraints
,keep
,inherited
) ->
1307 check_constraints constraints idb
>>=
1309 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1310 X.envf keep inherited
(A.drop_pos mida
,Ast_c.MetaFuncVal idb
,max_min)
1312 tokenf mida iib
>>= (fun mida iib
->
1314 ((A.MetaFunc
(mida
,constraints
,keep
,inherited
)))+>A.rewrap ida
,
1319 | LocalFunction
| Function
-> is_function()
1321 failwith
"MetaFunc, need more semantic info about id"
1322 (* the following implementation could possibly be useful, if one
1323 follows the convention that a macro is always in capital letters
1324 and that a macro is not a function.
1325 (if idb =~ "^[A-Z_][A-Z_0-9]*$" then fail else is_function())*)
1328 | A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
) ->
1331 check_constraints constraints idb
>>=
1333 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1334 X.envf keep inherited
1335 (A.drop_pos mida
,Ast_c.MetaLocalFuncVal idb
, max_min)
1337 tokenf mida iib
>>= (fun mida iib
->
1339 ((A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
)))
1345 | DontKnow
-> failwith
"MetaLocalFunc, need more semantic info about id"
1348 | A.OptIdent _
| A.UniqueIdent _
->
1349 failwith
"not handling Opt/Unique for ident"
1353 (* ------------------------------------------------------------------------- *)
1354 and (arguments
: sequence
->
1355 (A.expression list
, Ast_c.argument
Ast_c.wrap2 list
) matcher
) =
1356 fun seqstyle eas ebs
->
1358 | Unordered
-> failwith
"not handling ooo"
1360 arguments_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1361 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1363 (* because '...' can match nothing, need to take care when have
1364 * ', ...' or '...,' as in f(..., X, Y, ...). It must match
1365 * f(1,2) for instance.
1366 * So I have added special cases such as (if startxs = []) and code
1367 * in the Ecomma matching rule.
1369 * old: Must do some try, for instance when f(...,X,Y,...) have to
1370 * test the transfo for all the combinaitions and if multiple transfo
1371 * possible ? pb ? => the type is to return a expression option ? use
1372 * some combinators to help ?
1373 * update: with the tag-SP approach, no more a problem.
1376 and arguments_bis
= fun eas ebs
->
1378 | [], [] -> return ([], [])
1379 | [], eb
::ebs
-> fail
1381 X.all_bound
(A.get_inherited ea
) >&&>
1382 (match A.unwrap ea
, ebs
with
1383 | A.Edots
(mcode
, optexpr
), ys
->
1384 (* todo: if optexpr, then a WHEN and so may have to filter yys *)
1385 if optexpr
<> None
then failwith
"not handling when in argument";
1387 (* '...' can take more or less the beginnings of the arguments *)
1388 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1389 startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
1392 (* allow '...', and maybe its associated ',' to match nothing.
1393 * for the associated ',' see below how we handle the EComma
1398 if mcode_contain_plus (mcodekind mcode
)
1400 (* failwith "I have no token that I could accroche myself on" *)
1401 else return (dots2metavar mcode
, [])
1403 (* subtil: we dont want the '...' to match until the
1404 * comma. cf -test pb_params_iso. We would get at
1405 * "already tagged" error.
1406 * this is because both f (... x, ...) and f (..., x, ...)
1407 * would match a f(x,3) with our "optional-comma" strategy.
1409 (match Common.last startxs
with
1412 X.distrf_args
(dots2metavar mcode
) startxs
1415 >>= (fun mcode startxs
->
1416 let mcode = metavar2dots mcode in
1417 arguments_bis
eas endxs
>>= (fun eas endxs
->
1419 (A.Edots
(mcode, optexpr
) +> A.rewrap ea
) ::eas,
1425 | A.EComma ia1
, Right ii
::ebs
->
1426 let ib1 = tuple_of_list1 ii
in
1427 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1428 arguments_bis
eas ebs
>>= (fun eas ebs
->
1430 (A.EComma ia1
+> A.rewrap ea
)::eas,
1434 | A.EComma ia1
, ebs
->
1435 (* allow ',' to maching nothing. optional comma trick *)
1436 if mcode_contain_plus (mcodekind ia1
)
1438 else arguments_bis
eas ebs
1440 | A.MetaExprList
(ida
,leninfo
,keep
,inherited
),ys
->
1441 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1442 startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
1447 if mcode_contain_plus (mcodekind ida
)
1449 (* failwith "no token that I could accroche myself on" *)
1452 (match Common.last startxs
with
1460 let startxs'
= Ast_c.unsplit_comma
startxs in
1461 let len = List.length
startxs'
in
1464 | A.MetaListLen
(lenname
,lenkeep
,leninherited
) ->
1465 let max_min _
= failwith
"no pos" in
1466 X.envf lenkeep leninherited
1467 (lenname
, Ast_c.MetaListlenVal
(len), max_min)
1470 then (function f
-> f
())
1471 else (function f
-> fail)
1472 | A.AnyListLen
-> function f
-> f
()
1476 Lib_parsing_c.lin_col_by_pos
1477 (Lib_parsing_c.ii_of_args
startxs) in
1478 X.envf keep inherited
1479 (ida
, Ast_c.MetaExprListVal
startxs'
, max_min)
1482 then return (ida
, [])
1483 else X.distrf_args ida
(Ast_c.split_comma
startxs'
)
1485 >>= (fun ida
startxs ->
1486 arguments_bis
eas endxs
>>= (fun eas endxs
->
1488 (A.MetaExprList
(ida
,leninfo
,keep
,inherited
))
1489 +> A.rewrap ea
::eas,
1497 | _unwrapx
, (Left eb
)::ebs
->
1498 argument ea eb
>>= (fun ea eb
->
1499 arguments_bis
eas ebs
>>= (fun eas ebs
->
1500 return (ea
::eas, Left eb
::ebs
)
1502 | _unwrapx
, (Right y
)::ys
-> raise Impossible
1503 | _unwrapx
, [] -> fail
1507 and argument arga argb
=
1508 X.all_bound
(A.get_inherited arga
) >&&>
1509 match A.unwrap arga
, argb
with
1511 Right
(B.ArgType
{B.p_register
=b
,iib
; p_namei
=sopt
;p_type
=tyb
}) ->
1513 if b
|| sopt
<> None
1515 (* failwith "the argument have a storage and ast_cocci does not have"*)
1518 (* b = false and sopt = None *)
1519 fullType tya tyb
>>= (fun tya tyb
->
1521 (A.TypeExp tya
) +> A.rewrap arga
,
1522 (Right
(B.ArgType
{B.p_register
=(b
,iib
);
1527 | A.TypeExp tya
, _
-> fail
1528 | _
, Right
(B.ArgType _
) -> fail
1530 expression arga argb
>>= (fun arga argb
->
1531 return (arga
, Left argb
)
1533 | _
, Right
(B.ArgAction y
) -> fail
1536 (* ------------------------------------------------------------------------- *)
1537 (* todo? facto code with argument ? *)
1538 and (parameters
: sequence
->
1539 (A.parameterTypeDef list
, Ast_c.parameterType
Ast_c.wrap2 list
)
1541 fun seqstyle eas ebs
->
1543 | Unordered
-> failwith
"not handling ooo"
1545 parameters_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1546 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1550 and parameters_bis
eas ebs
=
1552 | [], [] -> return ([], [])
1553 | [], eb
::ebs
-> fail
1555 (* the management of positions is inlined into each case, because
1556 sometimes there is a Param and sometimes a ParamList *)
1557 X.all_bound
(A.get_inherited ea
) >&&>
1558 (match A.unwrap ea
, ebs
with
1559 | A.Pdots
(mcode), ys
->
1561 (* '...' can take more or less the beginnings of the arguments *)
1562 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1563 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
1568 if mcode_contain_plus (mcodekind mcode)
1570 (* failwith "I have no token that I could accroche myself on"*)
1571 else return (dots2metavar mcode, [])
1573 (match Common.last
startxs with
1576 X.distrf_params
(dots2metavar mcode) startxs
1578 ) >>= (fun mcode startxs ->
1579 let mcode = metavar2dots mcode in
1580 parameters_bis
eas endxs
>>= (fun eas endxs
->
1582 (A.Pdots
(mcode) +> A.rewrap ea
) ::eas,
1588 | A.PComma ia1
, Right ii
::ebs
->
1589 let ib1 = tuple_of_list1 ii
in
1590 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1591 parameters_bis
eas ebs
>>= (fun eas ebs
->
1593 (A.PComma ia1
+> A.rewrap ea
)::eas,
1598 | A.PComma ia1
, ebs
->
1599 (* try optional comma trick *)
1600 if mcode_contain_plus (mcodekind ia1
)
1602 else parameters_bis
eas ebs
1605 | A.MetaParamList
(ida
,leninfo
,keep
,inherited
),ys
->
1606 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1607 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
1612 if mcode_contain_plus (mcodekind ida
)
1614 (* failwith "I have no token that I could accroche myself on" *)
1617 (match Common.last
startxs with
1625 let startxs'
= Ast_c.unsplit_comma
startxs in
1626 let len = List.length
startxs'
in
1629 A.MetaListLen
(lenname
,lenkeep
,leninherited
) ->
1630 let max_min _
= failwith
"no pos" in
1631 X.envf lenkeep leninherited
1632 (lenname
, Ast_c.MetaListlenVal
(len), max_min)
1635 then (function f
-> f
())
1636 else (function f
-> fail)
1637 | A.AnyListLen
-> function f
-> f
()
1641 Lib_parsing_c.lin_col_by_pos
1642 (Lib_parsing_c.ii_of_params
startxs) in
1643 X.envf keep inherited
1644 (ida
, Ast_c.MetaParamListVal
startxs'
, max_min)
1647 then return (ida
, [])
1648 else X.distrf_params ida
(Ast_c.split_comma
startxs'
)
1649 ) >>= (fun ida
startxs ->
1650 parameters_bis
eas endxs
>>= (fun eas endxs
->
1652 (A.MetaParamList
(ida
,leninfo
,keep
,inherited
))
1653 +> A.rewrap ea
::eas,
1661 | A.VoidParam ta
, ys
->
1662 (match eas, ebs
with
1664 let {B.p_register
=(hasreg
,iihasreg
);
1666 p_type
=tb
; } = eb
in
1668 if idbopt
=*= None
&& not hasreg
1671 | (qub
, (B.BaseType
B.Void
,_
)) ->
1672 fullType ta tb
>>= (fun ta tb
->
1674 [(A.VoidParam ta
) +> A.rewrap ea
],
1675 [Left
{B.p_register
=(hasreg
, iihasreg
);
1684 | (A.OptParam _
| A.UniqueParam _
), _
->
1685 failwith
"handling Opt/Unique for Param"
1687 | A.Pcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
1690 | A.MetaParam
(ida
,keep
,inherited
), (Left eb
)::ebs
->
1691 (* todo: use quaopt, hasreg ? *)
1693 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_param eb
) in
1694 X.envf keep inherited
(ida
,Ast_c.MetaParamVal eb
,max_min) (fun () ->
1695 X.distrf_param ida eb
1696 ) >>= (fun ida eb
->
1697 parameters_bis
eas ebs
>>= (fun eas ebs
->
1699 (A.MetaParam
(ida
,keep
,inherited
))+> A.rewrap ea
::eas,
1704 | A.Param
(typa
, idaopt
), (Left eb
)::ebs
->
1705 (*this should succeed if the C code has a name, and fail otherwise*)
1706 parameter
(idaopt
, typa
) eb
>>= (fun (idaopt
, typa
) eb
->
1707 parameters_bis
eas ebs
>>= (fun eas ebs
->
1709 (A.Param
(typa
, idaopt
))+> A.rewrap ea
:: eas,
1713 | _unwrapx
, (Right y
)::ys
-> raise Impossible
1714 | _unwrapx
, [] -> fail
1720 let split_register_param = fun (hasreg, idb, ii_b_s) ->
1721 match hasreg, idb, ii_b_s with
1722 | false, Some s, [i1] -> Left (s, [], i1)
1723 | true, Some s, [i1;i2] -> Left (s, [i1], i2)
1724 | _, None, ii -> Right ii
1725 | _ -> raise Impossible
1729 and parameter
= fun (idaopt
, typa
) paramb
->
1731 let {B.p_register
= (hasreg
,iihasreg
);
1732 p_namei
= nameidbopt
;
1733 p_type
= typb
;} = paramb
in
1735 fullType typa typb
>>= (fun typa typb
->
1736 match idaopt
, nameidbopt
with
1737 | Some ida
, Some nameidb
->
1738 (* todo: if minus on ida, should also minus the iihasreg ? *)
1739 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1742 {B.p_register
= (hasreg
, iihasreg
);
1743 p_namei
= Some
(nameidb
);
1750 {B.p_register
=(hasreg
,iihasreg
);
1756 (* why handle this case ? because of transform_proto ? we may not
1757 * have an ident in the proto.
1758 * If have some plus on ida ? do nothing about ida ?
1760 (* not anymore !!! now that julia is handling the proto.
1761 | _, Right iihasreg ->
1764 ((hasreg, None, typb), iihasreg)
1768 | Some _
, None
-> fail
1769 | None
, Some _
-> fail
1775 (* ------------------------------------------------------------------------- *)
1776 and (declaration
: (A.mcodekind * bool * A.declaration
,B.declaration
) matcher
) =
1777 fun (mckstart
, allminus
, decla
) declb
->
1778 X.all_bound
(A.get_inherited decla
) >&&>
1779 match A.unwrap decla
, declb
with
1781 (* Un MetaDecl est introduit dans l'asttoctl pour sauter au dessus
1782 * de toutes les declarations qui sont au debut d'un fonction et
1783 * commencer le reste du match au premier statement. Alors, ca matche
1784 * n'importe quelle declaration. On n'a pas besoin d'ajouter
1785 * quoi que ce soit dans l'environnement. C'est une sorte de DDots.
1787 * When the SP want to remove the whole function, the minus is not
1788 * on the MetaDecl but on the MetaRuleElem. So there should
1789 * be no transform of MetaDecl, just matching are allowed.
1792 | A.MetaDecl
(ida
,keep
,inherited
), _
->
1794 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_decl declb
) in
1795 X.envf keep inherited
(ida
, Ast_c.MetaDeclVal declb
, max_min) (fun () ->
1796 X.distrf_decl ida declb
1797 ) >>= (fun ida declb
->
1798 return ((mckstart
, allminus
,
1799 (A.MetaDecl
(ida
, keep
, inherited
))+> A.rewrap decla
),
1801 | _
, (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
)) ->
1802 onedecl allminus decla
(var
,iiptvirgb
,iisto
) >>=
1803 (fun decla
(var
,iiptvirgb
,iisto
)->
1804 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1806 (mckstart
, allminus
, decla
),
1807 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1810 | _
, (B.DeclList
(xs
, iiptvirgb
::iifakestart
::iisto
)) ->
1811 if X.mode
=*= PatternMode
1813 xs
+> List.fold_left
(fun acc var
->
1815 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1816 onedecl allminus decla
(var
, iiptvirgb
, iisto
) >>=
1817 (fun decla
(var
, iiptvirgb
, iisto
) ->
1819 (mckstart
, allminus
, decla
),
1820 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1824 failwith
"More that one variable in decl. Have to split to transform."
1826 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
), B.MacroDecl
((sb
,ebs
),ii
) ->
1827 let (iisb
, lpb
, rpb
, iiendb
, iifakestart
, iistob
) =
1829 | iisb
::lpb
::rpb
::iiendb
::iifakestart
::iisto
->
1830 (iisb
,lpb
,rpb
,iiendb
, iifakestart
,iisto
)
1831 | _
-> raise Impossible
1834 then minusize_list iistob
1835 else return ((), iistob
)
1836 ) >>= (fun () iistob
->
1838 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1839 ident DontKnow sa
(sb
, iisb
) >>= (fun sa
(sb
, iisb
) ->
1840 tokenf lpa lpb
>>= (fun lpa lpb
->
1841 tokenf rpa rpb
>>= (fun rpa rpb
->
1842 tokenf enda iiendb
>>= (fun enda iiendb
->
1843 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
1844 let eas = redots
eas easundots
in
1847 (mckstart
, allminus
,
1848 (A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
)) +> A.rewrap decla
),
1849 (B.MacroDecl
((sb
,ebs
),
1850 [iisb
;lpb
;rpb
;iiendb
;iifakestart
] ++ iistob
))
1853 | _
, (B.MacroDecl _
|B.DeclList _
) -> fail
1856 and onedecl
= fun allminus decla
(declb
, iiptvirgb
, iistob
) ->
1857 X.all_bound
(A.get_inherited decla
) >&&>
1858 match A.unwrap decla
, declb
with
1860 (* kind of typedef iso, we must unfold, it's for the case
1861 * T { }; that we want to match against typedef struct { } xx_t;
1864 | A.TyDecl
(tya0
, ptvirga
),
1865 ({B.v_namei
= Some
(nameidb
, None
);
1867 B.v_storage
= (B.StoTypedef
, inl
);
1870 B.v_type_bis
= typb0bis
;
1873 (match A.unwrap tya0
, typb0
with
1874 | A.Type
(cv1
,tya1
), ((qu
,il
),typb1
) ->
1876 (match A.unwrap tya1
, typb1
with
1877 | A.StructUnionDef
(tya2
, lba
, declsa
, rba
),
1878 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
1880 let (iisub
, iisbopt
, lbb
, rbb
) =
1883 let (iisub
, lbb
, rbb
) = tuple_of_list3 ii
in
1884 (iisub
, [], lbb
, rbb
)
1887 "warning: both a typedef (%s) and struct name introduction (%s)"
1888 (Ast_c.str_of_name nameidb
) s
1890 pr2 "warning: I will consider only the typedef";
1891 let (iisub
, iisb
, lbb
, rbb
) = tuple_of_list4 ii
in
1892 (iisub
, [iisb
], lbb
, rbb
)
1895 structdef_to_struct_name
1896 (Ast_c.nQ
, (B.StructUnion
(sub
, sbopt
, declsb
), ii
))
1899 Ast_c.nQ
,((B.TypeName
(nameidb
, Some
1900 (Lib_parsing_c.al_type
structnameb))), [])
1903 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1904 tokenf lba lbb
>>= (fun lba lbb
->
1905 tokenf rba rbb
>>= (fun rba rbb
->
1906 struct_fields
(A.undots declsa
) declsb
>>=(fun undeclsa declsb
->
1907 let declsa = redots
declsa undeclsa
in
1909 (match A.unwrap tya2
with
1910 | A.Type
(cv3
, tya3
) ->
1911 (match A.unwrap tya3
with
1912 | A.MetaType
(ida
,keep
, inherited
) ->
1914 fullType tya2
fake_typeb >>= (fun tya2
fake_typeb ->
1916 A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1 in
1917 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1920 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1921 [iisub
] @ iisbopt
@ [lbb
;rbb
] in
1922 let typb0 = ((qu
, il
), typb1) in
1924 match fake_typeb with
1925 | _nQ
, ((B.TypeName
(nameidb
, _typ
)),[]) ->
1928 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1929 (({B.v_namei
= Some
(nameidb
, None
);
1931 B.v_storage
= (B.StoTypedef
, inl
);
1934 B.v_type_bis
= typb0bis
;
1936 iivirg
),iiptvirgb
,iistob
)
1938 | _
-> raise Impossible
1941 | A.StructUnionName
(sua
, sa
) ->
1942 fullType tya2
structnameb >>= (fun tya2
structnameb ->
1944 let tya1 = A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1
1946 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1948 match structnameb with
1949 | _nQ
, (B.StructUnionName
(sub
, s), [iisub
;iisbopt
]) ->
1951 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1952 [iisub
;iisbopt
;lbb
;rbb
] in
1953 let typb0 = ((qu
, il
), typb1) in
1956 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1957 (({B.v_namei
= Some
(nameidb
, None
);
1959 B.v_storage
= (B.StoTypedef
, inl
);
1962 B.v_type_bis
= typb0bis
;
1964 iivirg
),iiptvirgb
,iistob
)
1966 | _
-> raise Impossible
1968 | _
-> raise Impossible
1977 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1978 ({B.v_namei
= Some
(nameidb
, _
);B.v_storage
= (B.StoTypedef
,_
);}, iivirg
)
1981 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1982 ({B.v_namei
=Some
(nameidb
, _
);B.v_storage
=(B.StoTypedef
,_
);}, iivirg
)
1987 (* could handle iso here but handled in standard.iso *)
1988 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1989 ({B.v_namei
= Some
(nameidb
, None
);
1994 B.v_type_bis
= typbbis
;
1997 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1998 fullType typa typb
>>= (fun typa typb
->
1999 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
2000 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
2001 (fun stoa
(stob
, iistob
) ->
2003 (A.UnInit
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
2004 (({B.v_namei
= Some
(nameidb
, None
);
2009 B.v_type_bis
= typbbis
;
2014 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
2015 ({B.v_namei
= Some
(nameidb
, Some
(iieqb
, inib
));
2020 B.v_type_bis
= typbbis
;
2023 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2024 tokenf eqa iieqb
>>= (fun eqa iieqb
->
2025 fullType typa typb
>>= (fun typa typb
->
2026 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
2027 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
2028 (fun stoa
(stob
, iistob
) ->
2029 initialiser inia inib
>>= (fun inia inib
->
2031 (A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
)) +> A.rewrap decla
,
2032 (({B.v_namei
= Some
(nameidb
, Some
(iieqb
, inib
));
2037 B.v_type_bis
= typbbis
;
2042 (* do iso-by-absence here ? allow typedecl and var ? *)
2043 | A.TyDecl
(typa
, ptvirga
),
2044 ({B.v_namei
= None
; B.v_type
= typb
;
2048 B.v_type_bis
= typbbis
;
2051 if stob
=*= (B.NoSto
, false)
2053 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2054 fullType typa typb
>>= (fun typa typb
->
2056 (A.TyDecl
(typa
, ptvirga
)) +> A.rewrap decla
,
2057 (({B.v_namei
= None
;
2062 B.v_type_bis
= typbbis
;
2063 }, iivirg
), iiptvirgb
, iistob
)
2068 | A.Typedef
(stoa
, typa
, ida
, ptvirga
),
2069 ({B.v_namei
= Some
(nameidb
, None
);
2071 B.v_storage
= (B.StoTypedef
,inline
);
2074 B.v_type_bis
= typbbis
;
2077 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2078 fullType typa typb
>>= (fun typa typb
->
2081 tokenf stoa iitypedef
>>= (fun stoa iitypedef
->
2082 return (stoa
, [iitypedef
])
2084 | _
-> failwith
"weird, have both typedef and inline or nothing";
2085 ) >>= (fun stoa iistob
->
2086 (match A.unwrap ida
with
2087 | A.MetaType
(_
,_
,_
) ->
2090 Ast_c.nQ
, ((B.TypeName
(nameidb
, Ast_c.noTypedefDef
())), [])
2092 fullTypebis ida
fake_typeb >>= (fun ida
fake_typeb ->
2093 match fake_typeb with
2094 | _nQ
, ((B.TypeName
(nameidb
, _typ
)), []) ->
2095 return (ida
, nameidb
)
2096 | _
-> raise Impossible
2101 | B.RegularName
(sb
, iidb
) ->
2102 let iidb1 = tuple_of_list1 iidb
in
2106 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
2108 (A.TypeName sa
) +> A.rewrap ida
,
2109 B.RegularName
(sb
, [iidb1])
2113 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
2117 | _
-> raise Impossible
2119 ) >>= (fun ida nameidb
->
2121 (A.Typedef
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
2122 (({B.v_namei
= Some
(nameidb
, None
);
2124 B.v_storage
= (B.StoTypedef
,inline
);
2127 B.v_type_bis
= typbbis
;
2135 | _
, ({B.v_namei
= None
;}, _
) ->
2136 (* old: failwith "no variable in this declaration, weird" *)
2141 | A.DisjDecl declas
, declb
->
2142 declas
+> List.fold_left
(fun acc decla
->
2144 (* (declaration (mckstart, allminus, decla) declb) *)
2145 (onedecl allminus decla
(declb
,iiptvirgb
, iistob
))
2150 (* only in struct type decls *)
2151 | A.Ddots
(dots
,whencode
), _
->
2154 | A.OptDecl _
, _
| A.UniqueDecl _
, _
->
2155 failwith
"not handling Opt/Unique Decl"
2157 | _
, ({B.v_namei
=Some _
}, _
) ->
2163 (* ------------------------------------------------------------------------- *)
2165 and (initialiser
: (A.initialiser
, Ast_c.initialiser
) matcher
) = fun ia ib
->
2166 X.all_bound
(A.get_inherited ia
) >&&>
2167 match (A.unwrap ia
,ib
) with
2169 | (A.MetaInit
(ida
,keep
,inherited
), ib
) ->
2171 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_ini ib
) in
2172 X.envf keep inherited
(ida
, Ast_c.MetaInitVal ib
, max_min)
2174 X.distrf_ini ida ib
>>= (fun ida ib
->
2176 A.MetaInit
(ida
,keep
,inherited
) +> A.rewrap ia
,
2181 | (A.InitExpr expa
, ib
) ->
2182 (match A.unwrap expa
, ib
with
2183 | A.Edots
(mcode, None
), ib
->
2184 X.distrf_ini
(dots2metavar mcode) ib
>>= (fun mcode ib
->
2187 (A.Edots
(metavar2dots mcode, None
) +> A.rewrap expa
)
2192 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
2194 | _
, (B.InitExpr expb
, ii
) ->
2196 expression expa expb
>>= (fun expa expb
->
2198 (A.InitExpr expa
) +> A.rewrap ia
,
2199 (B.InitExpr expb
, ii
)
2204 | (A.InitList
(allminus
, ia1
, ias
, ia2
, []), (B.InitList ibs
, ii
)) ->
2206 | ib1::ib2
::iicommaopt
->
2207 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2208 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2209 initialisers allminus ias
(ibs
, iicommaopt
) >>=
2210 (fun ias
(ibs
,iicommaopt
) ->
2212 (A.InitList
(allminus
, ia1
, ias
, ia2
, [])) +> A.rewrap ia
,
2213 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2216 | _
-> raise Impossible
2219 | (A.InitList
(allminus
, i1
, ias
, i2
, whencode
),(B.InitList ibs
, _ii
)) ->
2220 failwith
"TODO: not handling whencode in initialisers"
2223 | (A.InitGccExt
(designatorsa
, ia2
, inia
),
2224 (B.InitDesignators
(designatorsb
, inib
), ii2
))->
2226 let iieq = tuple_of_list1 ii2
in
2228 tokenf ia2
iieq >>= (fun ia2
iieq ->
2229 designators designatorsa designatorsb
>>=
2230 (fun designatorsa designatorsb
->
2231 initialiser inia inib
>>= (fun inia inib
->
2233 (A.InitGccExt
(designatorsa
, ia2
, inia
)) +> A.rewrap ia
,
2234 (B.InitDesignators
(designatorsb
, inib
), [iieq])
2240 | (A.InitGccName
(ida
, ia1
, inia
), (B.InitFieldOld
(idb
, inib
), ii
)) ->
2243 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2244 initialiser inia inib
>>= (fun inia inib
->
2245 tokenf ia1 iicolon
>>= (fun ia1 iicolon
->
2247 (A.InitGccName
(ida
, ia1
, inia
)) +> A.rewrap ia
,
2248 (B.InitFieldOld
(idb
, inib
), [iidb
;iicolon
])
2255 | A.IComma
(comma
), _
->
2258 | A.UniqueIni _
,_
| A.OptIni _
,_
->
2259 failwith
"not handling Opt/Unique on initialisers"
2261 | _
, (B.InitIndexOld
(_
, _
), _
) -> fail
2262 | _
, (B.InitFieldOld
(_
, _
), _
) -> fail
2264 | _
, ((B.InitDesignators
(_
, _
)|B.InitList _
|B.InitExpr _
), _
)
2267 and designators dla dlb
=
2268 match (dla
,dlb
) with
2269 ([],[]) -> return ([], [])
2270 | ([],_
) | (_
,[]) -> fail
2271 | (da
::dla
,db
::dlb
) ->
2272 designator da db
>>= (fun da db
->
2273 designators dla dlb
>>= (fun dla dlb
->
2274 return (da
::dla
, db
::dlb
)))
2276 and designator da db
=
2278 (A.DesignatorField
(ia1
, ida
), (B.DesignatorField idb
,ii1
)) ->
2280 let (iidot
, iidb
) = tuple_of_list2 ii1
in
2281 tokenf ia1 iidot
>>= (fun ia1 iidot
->
2282 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2284 A.DesignatorField
(ia1
, ida
),
2285 (B.DesignatorField idb
, [iidot
;iidb
])
2288 | (A.DesignatorIndex
(ia1
,ea
,ia2
), (B.DesignatorIndex eb
, ii1
)) ->
2290 let (ib1, ib2
) = tuple_of_list2 ii1
in
2291 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2292 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2293 expression ea eb
>>= (fun ea eb
->
2295 A.DesignatorIndex
(ia1
,ea
,ia2
),
2296 (B.DesignatorIndex eb
, [ib1;ib2
])
2299 | (A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2300 (B.DesignatorRange
(e1b
, e2b
), ii1
)) ->
2302 let (ib1, ib2
, ib3
) = tuple_of_list3 ii1
in
2303 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2304 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2305 tokenf ia3 ib3
>>= (fun ia3 ib3
->
2306 expression e1a e1b
>>= (fun e1a e1b
->
2307 expression e2a e2b
>>= (fun e2a e2b
->
2309 A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2310 (B.DesignatorRange
(e1b
, e2b
), [ib1;ib2
;ib3
])
2312 | (_
, ((B.DesignatorField _
|B.DesignatorIndex _
|B.DesignatorRange _
), _
)) ->
2316 and initialisers
= fun allminus ias
(ibs
, iicomma
) ->
2317 let ias_unsplit = unsplit_icomma ias
in
2318 let ibs_split = resplit_initialiser ibs iicomma
in
2321 if need_unordered_initialisers ibs
2322 then initialisers_unordered2 allminus
2323 else initialisers_ordered2
2325 f ias_unsplit ibs_split >>=
2326 (fun ias_unsplit ibs_split ->
2328 split_icomma ias_unsplit,
2329 unsplit_initialiser ibs_split
2333 (* todo: one day julia will reput a IDots *)
2334 and initialisers_ordered2
= fun ias ibs
->
2336 | [], [] -> return ([], [])
2337 | (x
, xcomma
)::xs
, (y
, commay
)::ys
->
2338 (match A.unwrap xcomma
with
2339 | A.IComma commax
->
2340 tokenf commax commay
>>= (fun commax commay
->
2341 initialiser x y
>>= (fun x y
->
2342 initialisers_ordered2 xs ys
>>= (fun xs ys
->
2344 (x
, (A.IComma commax
) +> A.rewrap xcomma
)::xs
,
2348 | _
-> raise Impossible
(* unsplit_iicomma wrong *)
2353 and initialisers_unordered2
= fun allminus ias ibs
->
2359 let rec loop = function
2360 [] -> return ([],[])
2361 | (ib
,comma
)::ibs
->
2362 X.distrf_ini
minusizer ib
>>= (fun _ ib
->
2363 tokenf minusizer comma
>>= (fun _ comma
->
2364 loop ibs
>>= (fun l ibs
->
2365 return(l
,(ib
,comma
)::ibs
)))) in
2367 else return ([], ys
)
2368 | (x
,xcomma
)::xs
, ys
->
2370 let permut = Common.uncons_permut_lazy ys
in
2371 permut +> List.fold_left
(fun acc
((e
, pos
), rest
) ->
2374 (match A.unwrap xcomma
, e
with
2375 | A.IComma commax
, (y
, commay
) ->
2376 tokenf commax commay
>>= (fun commax commay
->
2377 initialiser x y
>>= (fun x y
->
2379 (x
, (A.IComma commax
) +> A.rewrap xcomma
),
2383 | _
-> raise Impossible
(* unsplit_iicomma wrong *)
2386 let rest = Lazy.force
rest in
2387 initialisers_unordered2 allminus xs
rest >>= (fun xs
rest ->
2390 Common.insert_elem_pos
(e
, pos
) rest
2395 (* ------------------------------------------------------------------------- *)
2396 and (struct_fields
: (A.declaration list
, B.field list
) matcher
) =
2399 | [], [] -> return ([], [])
2400 | [], eb
::ebs
-> fail
2402 X.all_bound
(A.get_inherited ea
) >&&>
2403 (match A.unwrap ea
, ebs
with
2404 | A.Ddots
(mcode, optwhen
), ys
->
2405 if optwhen
<> None
then failwith
"not handling when in argument";
2407 (* '...' can take more or less the beginnings of the arguments *)
2410 then [(ys
,[])] (* hack! the only one that can work *)
2411 else Common.zip
(Common.inits ys
) (Common.tails ys
) in
2412 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
2417 if mcode_contain_plus (mcodekind mcode)
2419 (* failwith "I have no token that I could accroche myself on" *)
2420 else return (dots2metavar mcode, [])
2423 X.distrf_struct_fields
(dots2metavar mcode) startxs
2424 ) >>= (fun mcode startxs ->
2425 let mcode = metavar2dots mcode in
2426 struct_fields
eas endxs
>>= (fun eas endxs
->
2428 (A.Ddots
(mcode, optwhen
) +> A.rewrap ea
) ::eas,
2433 | _unwrapx
, eb
::ebs
->
2434 struct_field ea eb
>>= (fun ea eb
->
2435 struct_fields
eas ebs
>>= (fun eas ebs
->
2436 return (ea
::eas, eb
::ebs
)
2439 | _unwrapx
, [] -> fail
2442 and (struct_field
: (A.declaration
, B.field
) matcher
) = fun fa fb
->
2444 match A.unwrap fa
,fb
with
2445 | A.MetaField
(ida
,keep
,inherited
), _
->
2447 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_field fb
) in
2448 X.envf keep inherited
(ida
, Ast_c.MetaFieldVal fb
, max_min) (fun () ->
2449 X.distrf_field ida fb
2450 ) >>= (fun ida fb
->
2451 return ((A.MetaField
(ida
, keep
, inherited
))+> A.rewrap fa
,
2453 | _
,B.DeclarationField
(B.FieldDeclList
(onefield_multivars
,iiptvirg
)) ->
2455 let iiptvirgb = tuple_of_list1 iiptvirg
in
2457 (match onefield_multivars
with
2458 | [] -> raise Impossible
2459 | [onevar
,iivirg
] ->
2460 assert (null iivirg
);
2462 | B.BitField
(sopt
, typb
, _
, expr
) ->
2463 pr2_once
"warning: bitfield not handled by ast_cocci";
2465 | B.Simple
(None
, typb
) ->
2466 pr2_once
"warning: unamed struct field not handled by ast_cocci";
2468 | B.Simple
(Some nameidb
, typb
) ->
2470 (* build a declaration from a struct field *)
2471 let allminus = false in
2473 let stob = B.NoSto
, false in
2475 ({B.v_namei
= Some
(nameidb
, None
);
2478 B.v_local
= Ast_c.NotLocalDecl
;
2479 B.v_attr
= Ast_c.noattr
;
2480 B.v_type_bis
= ref None
;
2481 (* the struct field should also get expanded ? no it's not
2482 * important here, we will rematch very soon *)
2486 onedecl
allminus fa
(fake_var,iiptvirgb,iisto) >>=
2487 (fun fa
(var
,iiptvirgb,iisto) ->
2490 | ({B.v_namei
= Some
(nameidb
, None
);
2495 let onevar = B.Simple
(Some nameidb
, typb
) in
2499 ((B.DeclarationField
2500 (B.FieldDeclList
([onevar, iivirg
], [iiptvirgb])))
2503 | _
-> raise Impossible
2508 pr2_once
"PB: More that one variable in decl. Have to split";
2511 | _
,B.EmptyField _iifield
->
2514 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
),B.MacroDeclField
((sb
,ebs
),ii
) ->
2516 | _
,B.MacroDeclField
((sb
,ebs
),ii
) -> fail
2518 | _
,B.CppDirectiveStruct directive
-> fail
2519 | _
,B.IfdefStruct directive
-> fail
2523 (* ------------------------------------------------------------------------- *)
2524 and (fullType
: (A.fullType
, Ast_c.fullType
) matcher
) =
2526 X.optional_qualifier_flag
(fun optional_qualifier
->
2527 X.all_bound
(A.get_inherited typa
) >&&>
2528 match A.unwrap typa
, typb
with
2529 | A.Type
(cv
,ty1
), ((qu
,il
),ty2
) ->
2531 if qu
.B.const
&& qu
.B.volatile
2534 ("warning: the type is both const & volatile but cocci " ^
2535 "does not handle that");
2537 (* Drop out the const/volatile part that has been matched.
2538 * This is because a SP can contain const T v; in which case
2539 * later in match_t_t when we encounter a T, we must not add in
2540 * the environment the whole type.
2545 (* "iso-by-absence" *)
2548 fullTypebis ty1
((qu
,il
), ty2
) >>= (fun ty1 fullty2
->
2550 (A.Type
(None
, ty1
)) +> A.rewrap typa
,
2554 (match optional_qualifier
, qu
.B.const
|| qu
.B.volatile
with
2555 | false, false -> do_stuff ()
2556 | false, true -> fail
2557 | true, false -> do_stuff ()
2560 then pr2_once
"USING optional_qualifier builtin isomorphism";
2566 (* todo: can be __const__ ? can be const & volatile so
2567 * should filter instead ?
2569 (match term x
, il
with
2570 | A.Const
, [i1
] when qu
.B.const
->
2572 tokenf x i1
>>= (fun x i1
->
2573 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2575 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2579 | A.Volatile
, [i1
] when qu
.B.volatile
->
2580 tokenf x i1
>>= (fun x i1
->
2581 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2583 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2591 | A.DisjType typas
, typb
->
2593 List.fold_left
(fun acc typa
-> acc
>|+|> (fullType typa typb
)) fail
2595 | A.OptType
(_
), _
| A.UniqueType
(_
), _
2596 -> failwith
"not handling Opt/Unique on type"
2601 * Why not (A.typeC, Ast_c.typeC) matcher ?
2602 * because when there is MetaType, we want that T record the whole type,
2603 * including the qualifier, and so this type (and the new_il function in
2604 * preceding function).
2607 and (fullTypebis
: (A.typeC
, Ast_c.fullType
) matcher
) =
2609 X.all_bound
(A.get_inherited ta
) >&&>
2610 match A.unwrap ta
, tb
with
2613 | A.MetaType
(ida
,keep
, inherited
), typb
->
2615 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
2616 X.envf keep inherited
(ida
, B.MetaTypeVal typb
, max_min) (fun () ->
2617 X.distrf_type ida typb
>>= (fun ida typb
->
2619 A.MetaType
(ida
,keep
, inherited
) +> A.rewrap ta
,
2623 | unwrap
, (qub
, typb
) ->
2624 typeC ta typb
>>= (fun ta typb
->
2625 return (ta
, (qub
, typb
))
2628 and simulate_signed ta basea stringsa signaopt tb baseb ii rebuilda
=
2629 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2630 * And even if in baseb we have a Signed Int, that does not mean
2631 * that ii is of length 2, cos Signed is the default, so if in signa
2632 * we have Signed explicitely ? we cant "accrocher" this mcode to
2633 * something :( So for the moment when there is signed in cocci,
2634 * we force that there is a signed in c too (done in pattern.ml).
2636 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2639 (* handle some iso on type ? (cf complex C rule for possible implicit
2641 match basea
, baseb
with
2642 | A.VoidType
, B.Void
2643 | A.FloatType
, B.FloatType
(B.CFloat
)
2644 | A.DoubleType
, B.FloatType
(B.CDouble
) ->
2645 assert (signaopt
=*= None
);
2646 let stringa = tuple_of_list1 stringsa
in
2647 let (ibaseb
) = tuple_of_list1 ii
in
2648 tokenf stringa ibaseb
>>= (fun stringa ibaseb
->
2650 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2651 (B.BaseType baseb
, [ibaseb
])
2654 | A.CharType
, B.IntType
B.CChar
when signaopt
=*= None
->
2655 let stringa = tuple_of_list1 stringsa
in
2656 let ibaseb = tuple_of_list1 ii
in
2657 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2659 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2660 (B.BaseType
(B.IntType
B.CChar
), [ibaseb])
2663 | A.CharType
,B.IntType
(B.Si
(_sign
, B.CChar2
)) when signaopt
<> None
->
2664 let stringa = tuple_of_list1 stringsa
in
2665 let ibaseb = tuple_of_list1 iibaseb
in
2666 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2667 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2669 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2670 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2673 | A.ShortType
, B.IntType
(B.Si
(_
, B.CShort
))
2674 | A.IntType
, B.IntType
(B.Si
(_
, B.CInt
))
2675 | A.LongType
, B.IntType
(B.Si
(_
, B.CLong
)) ->
2676 let stringa = tuple_of_list1 stringsa
in
2679 (* iso-by-presence ? *)
2680 (* when unsigned int in SP, allow have just unsigned in C ? *)
2681 if mcode_contain_plus (mcodekind stringa)
2685 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2687 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2688 (B.BaseType
(baseb
), iisignbopt
++ [])
2694 "warning: long int or short int not handled by ast_cocci";
2698 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2699 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2701 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2702 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2704 | _
-> raise Impossible
2709 | A.LongLongType
, B.IntType
(B.Si
(_
, B.CLongLong
)) ->
2710 let (string1a
,string2a
) = tuple_of_list2 stringsa
in
2712 [ibase1b
;ibase2b
] ->
2713 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2714 tokenf string1a ibase1b
>>= (fun base1a ibase1b
->
2715 tokenf string2a ibase2b
>>= (fun base2a ibase2b
->
2717 (rebuilda
([base1a
;base2a
], signaopt
)) +> A.rewrap ta
,
2718 (B.BaseType
(baseb
), iisignbopt
++ [ibase1b
;ibase2b
])
2720 | [] -> fail (* should something be done in this case? *)
2721 | _
-> raise Impossible
)
2724 | _
, B.FloatType
B.CLongDouble
2727 "warning: long double not handled by ast_cocci";
2730 | _
, (B.Void
|B.FloatType _
|B.IntType _
) -> fail
2732 and simulate_signed_meta ta basea signaopt tb baseb ii rebuilda
=
2733 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2734 * And even if in baseb we have a Signed Int, that does not mean
2735 * that ii is of length 2, cos Signed is the default, so if in signa
2736 * we have Signed explicitely ? we cant "accrocher" this mcode to
2737 * something :( So for the moment when there is signed in cocci,
2738 * we force that there is a signed in c too (done in pattern.ml).
2740 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2742 let match_to_type rebaseb
=
2743 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2744 let fta = A.rewrap basea
(A.Type
(None
,basea
)) in
2745 let ftb = Ast_c.nQ
,(B.BaseType
(rebaseb
), iibaseb
) in
2746 fullType
fta ftb >>= (fun fta (_
,tb
) ->
2747 (match A.unwrap
fta,tb
with
2748 A.Type
(_
,basea
), (B.BaseType baseb
, ii
) ->
2750 (rebuilda
(basea
, signaopt
)) +> A.rewrap ta
,
2751 (B.BaseType
(baseb
), iisignbopt
++ ii
)
2753 | _
-> failwith
"not possible"))) in
2755 (* handle some iso on type ? (cf complex C rule for possible implicit
2758 | B.IntType
(B.Si
(_sign
, B.CChar2
)) ->
2759 match_to_type (B.IntType
B.CChar
)
2761 | B.IntType
(B.Si
(_
, ty
)) ->
2763 | [] -> fail (* metavariable has to match something *)
2765 | _
-> match_to_type (B.IntType
(B.Si
(B.Signed
, ty
)))
2769 | (B.Void
|B.FloatType _
|B.IntType _
) -> fail
2771 and (typeC
: (A.typeC
, Ast_c.typeC
) matcher
) =
2773 match A.unwrap ta
, tb
with
2774 | A.BaseType
(basea
,stringsa
), (B.BaseType baseb
, ii
) ->
2775 simulate_signed ta basea stringsa None tb baseb ii
2776 (function (stringsa
, signaopt
) -> A.BaseType
(basea
,stringsa
))
2777 | A.SignedT
(signaopt
, Some basea
), (B.BaseType baseb
, ii
) ->
2778 (match A.unwrap basea
with
2779 A.BaseType
(basea1
,strings1
) ->
2780 simulate_signed ta basea1 strings1
(Some signaopt
) tb baseb ii
2781 (function (strings1
, Some signaopt
) ->
2784 Some
(A.rewrap basea
(A.BaseType
(basea1
,strings1
))))
2785 | _
-> failwith
"not possible")
2786 | A.MetaType
(ida
,keep
,inherited
) ->
2787 simulate_signed_meta ta basea
(Some signaopt
) tb baseb ii
2788 (function (basea
, Some signaopt
) ->
2789 A.SignedT
(signaopt
,Some basea
)
2790 | _
-> failwith
"not possible")
2791 | _
-> failwith
"not possible")
2792 | A.SignedT
(signa
,None
), (B.BaseType baseb
, ii
) ->
2793 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2794 (match iibaseb
, baseb
with
2795 | [], B.IntType
(B.Si
(_sign
, B.CInt
)) ->
2796 sign
(Some signa
) signbopt >>= (fun signaopt iisignbopt
->
2798 | None
-> raise Impossible
2801 (A.SignedT
(signa
,None
)) +> A.rewrap ta
,
2802 (B.BaseType baseb
, iisignbopt
)
2810 (* todo? iso with array *)
2811 | A.Pointer
(typa
, iamult
), (B.Pointer typb
, ii
) ->
2812 let (ibmult
) = tuple_of_list1 ii
in
2813 fullType typa typb
>>= (fun typa typb
->
2814 tokenf iamult ibmult
>>= (fun iamult ibmult
->
2816 (A.Pointer
(typa
, iamult
)) +> A.rewrap ta
,
2817 (B.Pointer typb
, [ibmult
])
2820 | A.FunctionType
(allminus,tyaopt
,lpa
,paramsa
,rpa
),
2821 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
) ->
2823 let (lpb
, rpb
) = tuple_of_list2 ii
in
2827 ("Not handling well variable length arguments func. "^
2828 "You have been warned");
2829 tokenf lpa lpb
>>= (fun lpa lpb
->
2830 tokenf rpa rpb
>>= (fun rpa rpb
->
2831 fullType_optional_allminus
allminus tyaopt tyb
>>= (fun tyaopt tyb
->
2832 parameters
(seqstyle paramsa
) (A.undots paramsa
) paramsb
>>=
2833 (fun paramsaundots paramsb
->
2834 let paramsa = redots
paramsa paramsaundots
in
2836 (A.FunctionType
(allminus,tyaopt
,lpa
,paramsa,rpa
) +> A.rewrap ta
,
2837 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), [lpb
;rpb
])
2845 | A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
),
2846 (B.ParenType t1
, ii
) ->
2847 let (lp1b
, rp1b
) = tuple_of_list2 ii
in
2848 let (qu1b
, t1b
) = t1
in
2850 | B.Pointer t2
, ii
->
2851 let (starb
) = tuple_of_list1 ii
in
2852 let (qu2b
, t2b
) = t2
in
2854 | B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
->
2855 let (lp2b
, rp2b
) = tuple_of_list2 ii
in
2860 ("Not handling well variable length arguments func. "^
2861 "You have been warned");
2863 fullType tya tyb
>>= (fun tya tyb
->
2864 tokenf lp1a lp1b
>>= (fun lp1a lp1b
->
2865 tokenf rp1a rp1b
>>= (fun rp1a rp1b
->
2866 tokenf lp2a lp2b
>>= (fun lp2a lp2b
->
2867 tokenf rp2a rp2b
>>= (fun rp2a rp2b
->
2868 tokenf stara starb
>>= (fun stara starb
->
2869 parameters
(seqstyle paramsa) (A.undots
paramsa) paramsb
>>=
2870 (fun paramsaundots paramsb
->
2871 let paramsa = redots
paramsa paramsaundots
in
2875 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))),
2880 (B.Pointer
t2, [starb
]))
2884 (A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
))
2886 (B.ParenType
t1, [lp1b
;rp1b
])
2899 (* todo: handle the iso on optionnal size specifification ? *)
2900 | A.Array
(typa
, ia1
, eaopt
, ia2
), (B.Array
(ebopt
, typb
), ii
) ->
2901 let (ib1, ib2
) = tuple_of_list2 ii
in
2902 fullType typa typb
>>= (fun typa typb
->
2903 option expression eaopt ebopt
>>= (fun eaopt ebopt
->
2904 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2905 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2907 (A.Array
(typa
, ia1
, eaopt
, ia2
)) +> A.rewrap ta
,
2908 (B.Array
(ebopt
, typb
), [ib1;ib2
])
2912 (* todo: could also match a Struct that has provided a name *)
2913 (* This is for the case where the SmPL code contains "struct x", without
2914 a definition. In this case, the name field is always present.
2915 This case is also called from the case for A.StructUnionDef when
2916 a name is present in the C code. *)
2917 | A.StructUnionName
(sua
, Some sa
), (B.StructUnionName
(sub
, sb
), ii
) ->
2918 (* sa is now an ident, not an mcode, old: ... && (term sa) =$= sb *)
2919 let (ib1, ib2
) = tuple_of_list2 ii
in
2920 if equal_structUnion (term sua
) sub
2922 ident DontKnow sa
(sb
, ib2
) >>= (fun sa
(sb
, ib2
) ->
2923 tokenf sua
ib1 >>= (fun sua
ib1 ->
2925 (A.StructUnionName
(sua
, Some sa
)) +> A.rewrap ta
,
2926 (B.StructUnionName
(sub
, sb
), [ib1;ib2
])
2931 | A.StructUnionDef
(ty
, lba
, declsa, rba
),
2932 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
2934 let (ii_sub_sb
, lbb
, rbb
) =
2936 [iisub
; lbb
; rbb
] -> (Common.Left iisub
,lbb
,rbb
)
2937 | [iisub
; iisb
; lbb
; rbb
] -> (Common.Right
(iisub
,iisb
),lbb
,rbb
)
2938 | _
-> failwith
"list of length 3 or 4 expected" in
2941 match (sbopt
,ii_sub_sb
) with
2942 (None
,Common.Left iisub
) ->
2943 (* the following doesn't reconstruct the complete SP code, just
2944 the part that matched *)
2946 match A.unwrap
s with
2948 (match A.unwrap ty
with
2949 A.StructUnionName
(sua
, None
) ->
2950 (match (term sua
, sub
) with
2952 | (A.Union
,B.Union
) -> return ((),())
2955 tokenf sua iisub
>>= (fun sua iisub
->
2958 A.StructUnionName
(sua
, None
) +> A.rewrap
ty)
2960 return (ty,[iisub
])))
2962 | A.DisjType
(disjs
) ->
2964 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
2968 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
2970 (* build a StructUnionName from a StructUnion *)
2971 let fake_su = B.nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) in
2973 fullType
ty fake_su >>= (fun ty fake_su ->
2975 | _nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) ->
2976 return (ty, [iisub
; iisb
])
2977 | _
-> raise Impossible
)
2981 >>= (fun ty ii_sub_sb
->
2983 tokenf lba lbb
>>= (fun lba lbb
->
2984 tokenf rba rbb
>>= (fun rba rbb
->
2985 struct_fields
(A.undots
declsa) declsb
>>=(fun undeclsa declsb
->
2986 let declsa = redots
declsa undeclsa
in
2989 (A.StructUnionDef
(ty, lba
, declsa, rba
)) +> A.rewrap ta
,
2990 (B.StructUnion
(sub
, sbopt
, declsb
),ii_sub_sb
@[lbb
;rbb
])
2994 (* todo? handle isomorphisms ? because Unsigned Int can be match on a
2995 * uint in the C code. But some CEs consists in renaming some types,
2996 * so we don't want apply isomorphisms every time.
2998 | A.TypeName sa
, (B.TypeName
(nameb
, typb
), noii
) ->
3002 | B.RegularName
(sb
, iidb
) ->
3003 let iidb1 = tuple_of_list1 iidb
in
3007 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
3009 (A.TypeName sa
) +> A.rewrap ta
,
3010 (B.TypeName
(B.RegularName
(sb
, [iidb1]), typb
), noii
)
3014 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
3019 | _
, (B.TypeOfExpr e
, ii
) -> fail
3020 | _
, (B.TypeOfType e
, ii
) -> fail
3022 | _
, (B.ParenType e
, ii
) -> fail (* todo ?*)
3023 | A.EnumName
(en
,namea
), (B.EnumName nameb
, ii
) ->
3024 let (ib1,ib2
) = tuple_of_list2 ii
in
3025 ident DontKnow namea
(nameb
, ib2
) >>= (fun namea
(nameb
, ib2
) ->
3026 tokenf en
ib1 >>= (fun en
ib1 ->
3028 (A.EnumName
(en
, namea
)) +> A.rewrap ta
,
3029 (B.EnumName nameb
, [ib1;ib2
])
3032 | _
, (B.Enum _
, _
) -> fail (* todo cocci ?*)
3035 ((B.TypeName _
| B.StructUnionName
(_
, _
) | B.EnumName _
|
3036 B.StructUnion
(_
, _
, _
) |
3037 B.FunctionType _
| B.Array
(_
, _
) | B.Pointer _
|
3043 (* todo: iso on sign, if not mentioned then free. tochange?
3044 * but that require to know if signed int because explicit
3045 * signed int, or because implicit signed int.
3048 and sign signa signb
=
3049 match signa
, signb
with
3050 | None
, None
-> return (None
, [])
3051 | Some signa
, Some
(signb
, ib
) ->
3052 if equal_sign (term signa
) signb
3053 then tokenf signa ib
>>= (fun signa ib
->
3054 return (Some signa
, [ib
])
3060 and minusize_list iixs
=
3061 iixs
+> List.fold_left
(fun acc ii
->
3062 acc
>>= (fun xs ys
->
3063 tokenf minusizer ii
>>= (fun minus ii
->
3064 return (minus
::xs
, ii
::ys
)
3065 ))) (return ([],[]))
3066 >>= (fun _xsminys ys
->
3067 return ((), List.rev ys
)
3070 and storage_optional_allminus
allminus stoa
(stob, iistob
) =
3071 (* "iso-by-absence" for storage, and return type. *)
3072 X.optional_storage_flag
(fun optional_storage
->
3073 match stoa
, stob with
3074 | None
, (stobis
, inline
) ->
3078 minusize_list iistob
>>= (fun () iistob
->
3079 return (None
, (stob, iistob
))
3081 else return (None
, (stob, iistob
))
3084 (match optional_storage
, stobis
with
3085 | false, B.NoSto
-> do_minus ()
3087 | true, B.NoSto
-> do_minus ()
3090 then pr2_once
"USING optional_storage builtin isomorphism";
3094 | Some x
, ((stobis
, inline
)) ->
3095 if equal_storage (term x
) stobis
3097 let rec loop acc
= function
3100 let str = B.str_of_info i1
in
3102 "static" | "extern" | "auto" | "register" ->
3103 (* not very elegant, but tokenf doesn't know what token to
3105 tokenf x i1
>>= (fun x i1
->
3106 let rebuilt = (List.rev acc
) @ i1
:: iistob
in
3107 return (Some x
, ((stobis
, inline
), rebuilt)))
3108 | _
-> loop (i1
::acc
) iistob
) in
3113 and inline_optional_allminus
allminus inla
(stob, iistob
) =
3114 (* "iso-by-absence" for storage, and return type. *)
3115 X.optional_storage_flag
(fun optional_storage
->
3116 match inla
, stob with
3117 | None
, (stobis
, inline
) ->
3121 minusize_list iistob
>>= (fun () iistob
->
3122 return (None
, (stob, iistob
))
3124 else return (None
, (stob, iistob
))
3133 then pr2_once
"USING optional_storage builtin isomorphism";
3136 else fail (* inline not in SP and present in C code *)
3139 | Some x
, ((stobis
, inline
)) ->
3142 let rec loop acc
= function
3145 let str = B.str_of_info i1
in
3148 (* not very elegant, but tokenf doesn't know what token to
3150 tokenf x i1
>>= (fun x i1
->
3151 let rebuilt = (List.rev acc
) @ i1
:: iistob
in
3152 return (Some x
, ((stobis
, inline
), rebuilt)))
3153 | _
-> loop (i1
::acc
) iistob
) in
3155 else fail (* SP has inline, but the C code does not *)
3158 and fullType_optional_allminus
allminus tya retb
=
3163 X.distrf_type
minusizer retb
>>= (fun _x retb
->
3167 else return (None
, retb
)
3169 fullType tya retb
>>= (fun tya retb
->
3170 return (Some tya
, retb
)
3175 (*---------------------------------------------------------------------------*)
3177 and compatible_base_type a signa b
=
3178 let ok = return ((),()) in
3181 | Type_cocci.VoidType
, B.Void
->
3182 assert (signa
=*= None
);
3184 | Type_cocci.CharType
, B.IntType
B.CChar
when signa
=*= None
->
3186 | Type_cocci.CharType
, B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3187 compatible_sign signa signb
3188 | Type_cocci.ShortType
, B.IntType
(B.Si
(signb
, B.CShort
)) ->
3189 compatible_sign signa signb
3190 | Type_cocci.IntType
, B.IntType
(B.Si
(signb
, B.CInt
)) ->
3191 compatible_sign signa signb
3192 | Type_cocci.LongType
, B.IntType
(B.Si
(signb
, B.CLong
)) ->
3193 compatible_sign signa signb
3194 | _
, B.IntType
(B.Si
(signb
, B.CLongLong
)) ->
3195 pr2_once
"no longlong in cocci";
3197 | Type_cocci.FloatType
, B.FloatType
B.CFloat
->
3198 assert (signa
=*= None
);
3200 | Type_cocci.DoubleType
, B.FloatType
B.CDouble
->
3201 assert (signa
=*= None
);
3203 | _
, B.FloatType
B.CLongDouble
->
3204 pr2_once
"no longdouble in cocci";
3206 | Type_cocci.BoolType
, _
-> failwith
"no booltype in C"
3208 | _
, (B.Void
|B.FloatType _
|B.IntType _
) -> fail
3210 and compatible_base_type_meta a signa qua b ii
local =
3212 | Type_cocci.MetaType
(ida
,keep
,inherited
),
3213 B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3214 compatible_sign signa signb
>>= fun _ _
->
3215 let newb = ((qua
, (B.BaseType
(B.IntType
B.CChar
),ii
)),local) in
3216 compatible_type a
newb
3217 | Type_cocci.MetaType
(ida
,keep
,inherited
), B.IntType
(B.Si
(signb
, ty)) ->
3218 compatible_sign signa signb
>>= fun _ _
->
3220 ((qua
, (B.BaseType
(B.IntType
(B.Si
(B.Signed
, ty))),ii
)),local) in
3221 compatible_type a
newb
3222 | _
, B.FloatType
B.CLongDouble
->
3223 pr2_once
"no longdouble in cocci";
3226 | _
, (B.Void
|B.FloatType _
|B.IntType _
) -> fail
3229 and compatible_type a
(b
,local) =
3230 let ok = return ((),()) in
3232 let rec loop = function
3233 | Type_cocci.BaseType a
, (qua
, (B.BaseType b
,ii
)) ->
3234 compatible_base_type a None b
3236 | Type_cocci.SignedT
(signa
,None
), (qua
, (B.BaseType b
,ii
)) ->
3237 compatible_base_type
Type_cocci.IntType
(Some signa
) b
3239 | Type_cocci.SignedT
(signa
,Some
ty), (qua
, (B.BaseType b
,ii
)) ->
3241 Type_cocci.BaseType
ty ->
3242 compatible_base_type
ty (Some signa
) b
3243 | Type_cocci.MetaType
(ida
,keep
,inherited
) ->
3244 compatible_base_type_meta
ty (Some signa
) qua b ii
local
3245 | _
-> failwith
"not possible")
3247 | Type_cocci.Pointer a
, (qub
, (B.Pointer b
, ii
)) ->
3249 | Type_cocci.FunctionPointer a
, _
->
3251 "TODO: function pointer type doesn't store enough information to determine compatability"
3252 | Type_cocci.Array a
, (qub
, (B.Array
(eopt
, b
),ii
)) ->
3253 (* no size info for cocci *)
3255 | Type_cocci.StructUnionName
(sua
, _
, sa
),
3256 (qub
, (B.StructUnionName
(sub
, sb
),ii
)) ->
3257 if equal_structUnion_type_cocci sua sub
&& sa
=$
= sb
3260 | Type_cocci.EnumName
(_
, sa
),
3261 (qub
, (B.EnumName
(sb
),ii
)) ->
3265 | Type_cocci.TypeName sa
, (qub
, (B.TypeName
(namesb
, _typb
),noii
)) ->
3266 let sb = Ast_c.str_of_name namesb
in
3271 | Type_cocci.ConstVol
(qua
, a
), (qub
, b
) ->
3272 if (fst qub
).B.const
&& (fst qub
).B.volatile
3275 pr2_once
("warning: the type is both const & volatile but cocci " ^
3276 "does not handle that");
3282 | Type_cocci.Const
-> (fst qub
).B.const
3283 | Type_cocci.Volatile
-> (fst qub
).B.volatile
3285 then loop (a
,(Ast_c.nQ
, b
))
3288 | Type_cocci.MetaType
(ida
,keep
,inherited
), typb
->
3290 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
3291 X.envf keep inherited
(A.make_mcode ida
, B.MetaTypeVal typb
, max_min)
3295 (* subtil: must be after the MetaType case *)
3296 | a
, (qub
, (B.TypeName
(_namesb
, Some b
), noii
)) ->
3297 (* kind of typedef iso *)
3304 (* for metavariables of type expression *^* *)
3305 | Type_cocci.Unknown
, _
-> ok
3310 B.TypeOfType _
|B.TypeOfExpr _
|B.ParenType _
|
3311 B.EnumName _
|B.StructUnion
(_
, _
, _
)|B.Enum
(_
, _
)
3318 B.StructUnionName
(_
, _
)|
3320 B.Array
(_
, _
)|B.Pointer _
|B.TypeName _
|
3329 and compatible_sign signa signb
=
3330 let ok = return ((),()) in
3331 match signa
, signb
with
3333 | Some
Type_cocci.Signed
, B.Signed
3334 | Some
Type_cocci.Unsigned
, B.UnSigned
3339 and equal_structUnion_type_cocci a b
=
3341 | Type_cocci.Struct
, B.Struct
-> true
3342 | Type_cocci.Union
, B.Union
-> true
3343 | _
, (B.Struct
| B.Union
) -> false
3347 (*---------------------------------------------------------------------------*)
3348 and inc_file
(a
, before_after
) (b
, h_rel_pos
) =
3350 let rec aux_inc (ass
, bss
) passed
=
3354 let passed = List.rev
passed in
3356 (match before_after
, !h_rel_pos
with
3357 | IncludeNothing
, _
-> true
3358 | IncludeMcodeBefore
, Some x
->
3359 List.mem
passed (x
.Ast_c.first_of
)
3361 | IncludeMcodeAfter
, Some x
->
3362 List.mem
passed (x
.Ast_c.last_of
)
3364 (* no info, maybe cos of a #include <xx.h> that was already in a .h *)
3368 | (A.IncPath x
)::xs
, y
::ys
-> x
=$
= y
&& aux_inc (xs
, ys
) (x
::passed)
3369 | _
-> failwith
"IncDots not in last place or other pb"
3374 | A.Local ass
, B.Local bss
->
3375 aux_inc (ass
, bss
) []
3376 | A.NonLocal ass
, B.NonLocal bss
->
3377 aux_inc (ass
, bss
) []
3382 (*---------------------------------------------------------------------------*)
3384 and (define_params
: sequence
->
3385 (A.define_param list
, (string B.wrap
) B.wrap2 list
) matcher
) =
3386 fun seqstyle eas ebs
->
3388 | Unordered
-> failwith
"not handling ooo"
3390 define_paramsbis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
3391 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
3394 (* todo? facto code with argument and parameters ? *)
3395 and define_paramsbis
= fun eas ebs
->
3397 | [], [] -> return ([], [])
3398 | [], eb
::ebs
-> fail
3400 X.all_bound
(A.get_inherited ea
) >&&>
3401 (match A.unwrap ea
, ebs
with
3402 | A.DPdots
(mcode), ys
->
3404 (* '...' can take more or less the beginnings of the arguments *)
3405 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
3406 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
3411 if mcode_contain_plus (mcodekind mcode)
3413 (* failwith "I have no token that I could accroche myself on" *)
3414 else return (dots2metavar mcode, [])
3416 (match Common.last
startxs with
3419 X.distrf_define_params
(dots2metavar mcode) startxs
3421 ) >>= (fun mcode startxs ->
3422 let mcode = metavar2dots mcode in
3423 define_paramsbis
eas endxs
>>= (fun eas endxs
->
3425 (A.DPdots
(mcode) +> A.rewrap ea
) ::eas,
3431 | A.DPComma ia1
, Right ii
::ebs
->
3432 let ib1 = tuple_of_list1 ii
in
3433 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3434 define_paramsbis
eas ebs
>>= (fun eas ebs
->
3436 (A.DPComma ia1
+> A.rewrap ea
)::eas,
3441 | A.DPComma ia1
, ebs
->
3442 if mcode_contain_plus (mcodekind ia1
)
3445 (define_paramsbis
eas ebs
) (* try optional comma trick *)
3447 | (A.OptDParam _
| A.UniqueDParam _
), _
->
3448 failwith
"handling Opt/Unique for define parameters"
3450 | A.DPcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
3452 | A.DParam ida
, (Left
(idb
, ii
))::ebs
->
3453 let ib1 = tuple_of_list1 ii
in
3454 ident DontKnow ida
(idb
, ib1) >>= (fun ida
(idb
, ib1) ->
3455 define_paramsbis
eas ebs
>>= (fun eas ebs
->
3457 (A.DParam ida
)+> A.rewrap ea
:: eas,
3458 (Left
(idb
, [ib1]))::ebs
3461 | _unwrapx
, (Right y
)::ys
-> raise Impossible
3462 | _unwrapx
, [] -> fail
3467 (*****************************************************************************)
3469 (*****************************************************************************)
3471 (* no global solution for positions here, because for a statement metavariable
3472 we want a MetaStmtVal, and for the others, it's not clear what we want *)
3474 let rec (rule_elem_node
: (A.rule_elem
, Control_flow_c.node
) matcher
) =
3477 x
>>= (fun a b
-> return (A.rewrap re a
, F.rewrap node b
))
3479 X.all_bound
(A.get_inherited re
) >&&>
3482 match A.unwrap re
, F.unwrap node
with
3484 (* note: the order of the clauses is important. *)
3486 | _
, F.Enter
| _
, F.Exit
| _
, F.ErrorExit
-> fail2()
3488 (* the metaRuleElem contains just '-' information. We dont need to add
3489 * stuff in the environment. If we need stuff in environment, because
3490 * there is a + S somewhere, then this will be done via MetaStmt, not
3492 * Can match TrueNode/FalseNode/... so must be placed before those cases.
3495 | A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
->
3496 let default = A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
in
3497 (match unwrap_node
with
3499 | F.TrueNode
| F.FalseNode
| F.AfterNode
3500 | F.LoopFallThroughNode
| F.FallThroughNode
3502 if X.mode
=*= PatternMode
3505 if mcode_contain_plus (mcodekind mcode)
3506 then failwith
"try add stuff on fake node"
3507 (* minusize or contextize a fake node is ok *)
3510 | F.EndStatement None
->
3511 if X.mode
=*= PatternMode
then return default
3513 (* DEAD CODE NOW ? only useful in -no_cocci_vs_c_3 ?
3514 if mcode_contain_plus (mcodekind mcode)
3516 let fake_info = Ast_c.fakeInfo() in
3517 distrf distrf_node (mcodekind mcode)
3518 (F.EndStatement (Some fake_info))
3519 else return unwrap_node
3523 | F.EndStatement
(Some i1
) ->
3524 tokenf mcode i1
>>= (fun mcode i1
->
3526 A.MetaRuleElem
(mcode,keep
, inherited
),
3527 F.EndStatement
(Some i1
)
3531 if X.mode
=*= PatternMode
then return default
3532 else failwith
"a MetaRuleElem can't transform a headfunc"
3534 if X.mode
=*= PatternMode
then return default
3536 X.distrf_node
(generalize_mcode mcode) node
>>= (fun mcode node
->
3538 A.MetaRuleElem
(mcode,keep
, inherited
),
3544 (* rene cant have found that a state containing a fake/exit/... should be
3546 * TODO: and F.Fake ?
3548 | _
, F.EndStatement _
| _
, F.CaseNode _
3549 | _
, F.TrueNode
| _
, F.FalseNode
| _
, F.AfterNode
3550 | _
, F.FallThroughNode
| _
, F.LoopFallThroughNode
3554 (* really ? diff between pattern.ml and transformation.ml *)
3555 | _
, F.Fake
-> fail2()
3558 (* cas general: a Meta can match everything. It matches only
3559 * "header"-statement. We transform only MetaRuleElem, not MetaStmt.
3560 * So can't have been called in transform.
3562 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), F.Decl
(_
) -> fail
3564 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), unwrap_node
->
3565 (* todo: should not happen in transform mode *)
3567 (match Control_flow_c.extract_fullstatement node
with
3570 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_stmt stb
) in
3571 X.envf keep inherited
(ida
, Ast_c.MetaStmtVal stb
, max_min)
3573 (* no need tag ida, we can't be called in transform-mode *)
3575 A.MetaStmt
(ida
, keep
, metainfoMaybeTodo
, inherited
),
3583 | A.MetaStmtList _
, _
->
3584 failwith
"not handling MetaStmtList"
3586 | A.TopExp ea
, F.DefineExpr eb
->
3587 expression ea eb
>>= (fun ea eb
->
3593 | A.TopExp ea
, F.DefineType eb
->
3594 (match A.unwrap ea
with
3596 fullType ft eb
>>= (fun ft eb
->
3598 A.TopExp
(A.rewrap ea
(A.TypeExp
(ft
))),
3605 (* It is important to put this case before the one that fails because
3606 * of the lack of the counter part of a C construct in SmPL (for instance
3607 * there is not yet a CaseRange in SmPL). Even if SmPL don't handle
3608 * yet certain constructs, those constructs may contain expression
3609 * that we still want and can transform.
3612 | A.Exp exp
, nodeb
->
3614 (* kind of iso, initialisation vs affectation *)
3616 match A.unwrap exp
, nodeb
with
3617 | A.Assignment
(ea
, op
, eb
, true), F.Decl decl
->
3618 initialisation_to_affectation decl
+> F.rewrap node
3623 (* Now keep fullstatement inside the control flow node,
3624 * so that can then get in a MetaStmtVar the fullstatement to later
3625 * pp back when the S is in a +. But that means that
3626 * Exp will match an Ifnode even if there is no such exp
3627 * inside the condition of the Ifnode (because the exp may
3628 * be deeper, in the then branch). So have to not visit
3629 * all inside a node anymore.
3631 * update: j'ai choisi d'accrocher au noeud du CFG Ã la
3632 * fois le fullstatement et le partialstatement et appeler le
3633 * visiteur que sur le partialstatement.
3636 match Ast_cocci.get_pos re
with
3637 | None
-> expression
3641 Lib_parsing_c.max_min_by_pos
(Lib_parsing_c.ii_of_expr eb
) in
3642 let keep = Type_cocci.Unitary
in
3643 let inherited = false in
3644 let max_min _
= failwith
"no pos" in
3645 X.envf
keep inherited (pos
, B.MetaPosVal
(min
,max
), max_min)
3651 X.cocciExp
expfn exp
node >>= (fun exp
node ->
3659 X.cocciTy fullType
ty node >>= (fun ty node ->
3666 | A.TopInit init
, nodeb
->
3667 X.cocciInit initialiser init
node >>= (fun init
node ->
3675 | A.FunHeader
(mckstart
, allminus, fninfoa
, ida
, oparen
, paramsa, cparen
),
3676 F.FunHeader
({B.f_name
= nameidb
;
3677 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3681 f_old_c_style
= oldstyle
;
3686 then pr2 "OLD STYLE DECL NOT WELL SUPPORTED";
3689 (* fninfoa records the order in which the SP specified the various
3690 information, but this isn't taken into account in the matching.
3691 Could this be a problem for transformation? *)
3694 List.filter
(function A.FStorage
(s) -> true | _
-> false) fninfoa
3695 with [A.FStorage
(s)] -> Some
s | _
-> None
in
3697 match List.filter
(function A.FType
(s) -> true | _
-> false) fninfoa
3698 with [A.FType
(t
)] -> Some t
| _
-> None
in
3701 match List.filter
(function A.FInline
(i
) -> true | _
-> false) fninfoa
3702 with [A.FInline
(i
)] -> Some i
| _
-> None
in
3704 (match List.filter
(function A.FAttr
(a
) -> true | _
-> false) fninfoa
3705 with [A.FAttr
(a
)] -> failwith
"not checking attributes" | _
-> ());
3708 | ioparenb
::icparenb
::iifakestart
::iistob
->
3710 (* maybe important to put ident as the first tokens to transform.
3711 * It's related to transform_proto. So don't change order
3714 ident_cpp LocalFunction ida nameidb
>>= (fun ida nameidb
->
3715 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
3716 tokenf oparen ioparenb
>>= (fun oparen ioparenb
->
3717 tokenf cparen icparenb
>>= (fun cparen icparenb
->
3718 parameters
(seqstyle paramsa)
3719 (A.undots
paramsa) paramsb
>>=
3720 (fun paramsaundots paramsb
->
3721 let paramsa = redots
paramsa paramsaundots
in
3722 inline_optional_allminus
allminus
3723 inla (stob, iistob
) >>= (fun inla (stob, iistob
) ->
3724 storage_optional_allminus
allminus
3725 stoa (stob, iistob
) >>= (fun stoa (stob, iistob
) ->
3730 ("Not handling well variable length arguments func. "^
3731 "You have been warned");
3733 then minusize_list iidotsb
3734 else return ((),iidotsb
)
3735 ) >>= (fun () iidotsb
->
3737 fullType_optional_allminus
allminus tya retb
>>= (fun tya retb
->
3740 (match stoa with Some st
-> [A.FStorage st
] | None
-> []) ++
3741 (match inla with Some i
-> [A.FInline i
] | None
-> []) ++
3742 (match tya with Some t
-> [A.FType t
] | None
-> [])
3747 A.FunHeader
(mckstart
,allminus,fninfoa,ida
,oparen
,
3749 F.FunHeader
({B.f_name
= nameidb
;
3750 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3754 f_old_c_style
= oldstyle
; (* TODO *)
3756 ioparenb
::icparenb
::iifakestart
::iistob
)
3759 | _
-> raise Impossible
3767 | A.Decl
(mckstart
,allminus,decla
), F.Decl declb
->
3768 declaration
(mckstart
,allminus,decla
) declb
>>=
3769 (fun (mckstart
,allminus,decla
) declb
->
3771 A.Decl
(mckstart
,allminus,decla
),
3776 | A.SeqStart
mcode, F.SeqStart
(st
, level
, i1
) ->
3777 tokenf mcode i1
>>= (fun mcode i1
->
3780 F.SeqStart
(st
, level
, i1
)
3783 | A.SeqEnd
mcode, F.SeqEnd
(level
, i1
) ->
3784 tokenf mcode i1
>>= (fun mcode i1
->
3787 F.SeqEnd
(level
, i1
)
3790 | A.ExprStatement
(ea
, ia1
), F.ExprStatement
(st
, (Some eb
, ii
)) ->
3791 let ib1 = tuple_of_list1 ii
in
3792 expression ea eb
>>= (fun ea eb
->
3793 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3795 A.ExprStatement
(ea
, ia1
),
3796 F.ExprStatement
(st
, (Some eb
, [ib1]))
3801 | A.IfHeader
(ia1
,ia2
, ea
, ia3
), F.IfHeader
(st
, (eb
,ii
)) ->
3802 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3803 expression ea eb
>>= (fun ea eb
->
3804 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3805 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3806 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3808 A.IfHeader
(ia1
, ia2
, ea
, ia3
),
3809 F.IfHeader
(st
, (eb
,[ib1;ib2
;ib3
]))
3812 | A.Else ia
, F.Else ib
->
3813 tokenf ia ib
>>= (fun ia ib
->
3814 return (A.Else ia
, F.Else ib
)
3817 | A.WhileHeader
(ia1
, ia2
, ea
, ia3
), F.WhileHeader
(st
, (eb
, ii
)) ->
3818 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3819 expression ea eb
>>= (fun ea eb
->
3820 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3821 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3822 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3824 A.WhileHeader
(ia1
, ia2
, ea
, ia3
),
3825 F.WhileHeader
(st
, (eb
, [ib1;ib2
;ib3
]))
3828 | A.DoHeader ia
, F.DoHeader
(st
, ib
) ->
3829 tokenf ia ib
>>= (fun ia ib
->
3834 | A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
), F.DoWhileTail
(eb
, ii
) ->
3835 let (ib1, ib2
, ib3
, ib4
) = tuple_of_list4 ii
in
3836 expression ea eb
>>= (fun ea eb
->
3837 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3838 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3839 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3840 tokenf ia4 ib4
>>= (fun ia4 ib4
->
3842 A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
),
3843 F.DoWhileTail
(eb
, [ib1;ib2
;ib3
;ib4
])
3845 | A.IteratorHeader
(ia1
, ia2
, eas, ia3
), F.MacroIterHeader
(st
, ((s,ebs
),ii
))
3847 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3849 ident DontKnow ia1
(s, ib1) >>= (fun ia1
(s, ib1) ->
3850 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3851 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3852 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
3853 let eas = redots
eas easundots
in
3855 A.IteratorHeader
(ia1
, ia2
, eas, ia3
),
3856 F.MacroIterHeader
(st
, ((s,ebs
), [ib1;ib2
;ib3
]))
3861 | A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3862 F.ForHeader
(st
, (((eb1opt
,ib3s
), (eb2opt
,ib4s
), (eb3opt
,ib4vide
)), ii
))
3864 assert (null ib4vide
);
3865 let (ib1, ib2
, ib5
) = tuple_of_list3 ii
in
3866 let ib3 = tuple_of_list1 ib3s
in
3867 let ib4 = tuple_of_list1 ib4s
in
3869 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3870 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3871 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3872 tokenf ia4
ib4 >>= (fun ia4
ib4 ->
3873 tokenf ia5 ib5
>>= (fun ia5 ib5
->
3874 option expression ea1opt eb1opt
>>= (fun ea1opt eb1opt
->
3875 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
3876 option expression ea3opt eb3opt
>>= (fun ea3opt eb3opt
->
3878 A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3879 F.ForHeader
(st
, (((eb1opt
,[ib3]), (eb2opt
,[ib4]), (eb3opt
,[])),
3885 | A.SwitchHeader
(ia1
,ia2
,ea
,ia3
), F.SwitchHeader
(st
, (eb
,ii
)) ->
3886 let (ib1, ib2
, ib3) = tuple_of_list3 ii
in
3887 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3888 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3889 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3890 expression ea eb
>>= (fun ea eb
->
3892 A.SwitchHeader
(ia1
,ia2
,ea
,ia3
),
3893 F.SwitchHeader
(st
, (eb
,[ib1;ib2
;ib3]))
3896 | A.Break
(ia1
, ia2
), F.Break
(st
, ((),ii
)) ->
3897 let (ib1, ib2
) = tuple_of_list2 ii
in
3898 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3899 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3902 F.Break
(st
, ((),[ib1;ib2
]))
3905 | A.Continue
(ia1
, ia2
), F.Continue
(st
, ((),ii
)) ->
3906 let (ib1, ib2
) = tuple_of_list2 ii
in
3907 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3908 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3910 A.Continue
(ia1
, ia2
),
3911 F.Continue
(st
, ((),[ib1;ib2
]))
3914 | A.Return
(ia1
, ia2
), F.Return
(st
, ((),ii
)) ->
3915 let (ib1, ib2
) = tuple_of_list2 ii
in
3916 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3917 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3919 A.Return
(ia1
, ia2
),
3920 F.Return
(st
, ((),[ib1;ib2
]))
3923 | A.ReturnExpr
(ia1
, ea
, ia2
), F.ReturnExpr
(st
, (eb
, ii
)) ->
3924 let (ib1, ib2
) = tuple_of_list2 ii
in
3925 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3926 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3927 expression ea eb
>>= (fun ea eb
->
3929 A.ReturnExpr
(ia1
, ea
, ia2
),
3930 F.ReturnExpr
(st
, (eb
, [ib1;ib2
]))
3935 | A.Include
(incla
,filea
),
3936 F.Include
{B.i_include
= (fileb
, ii
);
3937 B.i_rel_pos
= h_rel_pos
;
3938 B.i_is_in_ifdef
= inifdef
;
3941 assert (copt
=*= None
);
3943 let include_requirment =
3944 match mcodekind incla
, mcodekind filea
with
3945 | A.CONTEXT
(_
, A.BEFORE _
), _
->
3947 | _
, A.CONTEXT
(_
, A.AFTER _
) ->
3953 let (inclb
, iifileb
) = tuple_of_list2 ii
in
3954 if inc_file
(term filea
, include_requirment) (fileb
, h_rel_pos
)
3956 tokenf incla inclb
>>= (fun incla inclb
->
3957 tokenf filea iifileb
>>= (fun filea iifileb
->
3959 A.Include
(incla
, filea
),
3960 F.Include
{B.i_include
= (fileb
, [inclb
;iifileb
]);
3961 B.i_rel_pos
= h_rel_pos
;
3962 B.i_is_in_ifdef
= inifdef
;
3970 | A.DefineHeader
(definea
,ida
,params
), F.DefineHeader
((idb
, ii
), defkind
) ->
3971 let (defineb
, iidb
, ieol
) = tuple_of_list3 ii
in
3972 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
3973 tokenf definea defineb
>>= (fun definea defineb
->
3974 (match A.unwrap params
, defkind
with
3975 | A.NoParams
, B.DefineVar
->
3977 A.NoParams
+> A.rewrap params
,
3980 | A.DParams
(lpa
,eas,rpa
), (B.DefineFunc
(ebs
, ii
)) ->
3981 let (lpb
, rpb
) = tuple_of_list2 ii
in
3982 tokenf lpa lpb
>>= (fun lpa lpb
->
3983 tokenf rpa rpb
>>= (fun rpa rpb
->
3985 define_params
(seqstyle eas) (A.undots
eas) ebs
>>=
3986 (fun easundots ebs
->
3987 let eas = redots
eas easundots
in
3989 A.DParams
(lpa
,eas,rpa
) +> A.rewrap params
,
3990 B.DefineFunc
(ebs
,[lpb
;rpb
])
3994 ) >>= (fun params defkind
->
3996 A.DefineHeader
(definea
, ida
, params
),
3997 F.DefineHeader
((idb
,[defineb
;iidb
;ieol
]),defkind
)
4002 | A.Default
(def
,colon
), F.Default
(st
, ((),ii
)) ->
4003 let (ib1, ib2
) = tuple_of_list2 ii
in
4004 tokenf def
ib1 >>= (fun def
ib1 ->
4005 tokenf colon ib2
>>= (fun colon ib2
->
4007 A.Default
(def
,colon
),
4008 F.Default
(st
, ((),[ib1;ib2
]))
4013 | A.Case
(case
,ea
,colon
), F.Case
(st
, (eb
,ii
)) ->
4014 let (ib1, ib2
) = tuple_of_list2 ii
in
4015 tokenf case
ib1 >>= (fun case
ib1 ->
4016 expression ea eb
>>= (fun ea eb
->
4017 tokenf colon ib2
>>= (fun colon ib2
->
4019 A.Case
(case
,ea
,colon
),
4020 F.Case
(st
, (eb
,[ib1;ib2
]))
4023 (* only occurs in the predicates generated by asttomember *)
4024 | A.DisjRuleElem
eas, _
->
4026 List.fold_left
(fun acc ea
-> acc
>|+|> (rule_elem_node ea
node)) fail)
4027 >>= (fun ea eb
-> return (A.unwrap ea
,F.unwrap eb
))
4029 | _
, F.ExprStatement
(_
, (None
, ii
)) -> fail (* happen ? *)
4031 | A.Label
(id
,dd
), F.Label
(st
, nameb
, ((),ii
)) ->
4032 let (ib2
) = tuple_of_list1 ii
in
4033 ident_cpp DontKnow id nameb
>>= (fun ida nameb
->
4034 tokenf dd ib2
>>= (fun dd ib2
->
4037 F.Label
(st
,nameb
, ((),[ib2
]))
4040 | A.Goto
(goto
,id
,sem
), F.Goto
(st
,nameb
, ((),ii
)) ->
4041 let (ib1,ib3) = tuple_of_list2 ii
in
4042 tokenf goto
ib1 >>= (fun goto
ib1 ->
4043 ident_cpp DontKnow id nameb
>>= (fun id nameb
->
4044 tokenf sem
ib3 >>= (fun sem
ib3 ->
4046 A.Goto
(goto
,id
,sem
),
4047 F.Goto
(st
,nameb
, ((),[ib1;ib3]))
4050 (* have not a counter part in coccinelle, for the moment *)
4051 (* todo?: print a warning at least ? *)
4057 | _
, (F.IfdefEndif _
|F.IfdefElse _
|F.IfdefHeader _
)
4061 (F.MacroStmt
(_
, _
)| F.DefineDoWhileZeroHeader _
| F.EndNode
|F.TopNode
)
4064 (F.Label
(_
, _
, _
)|F.Break
(_
, _
)|F.Continue
(_
, _
)|F.Default
(_
, _
)|
4065 F.Case
(_
, _
)|F.Include _
|F.Goto _
|F.ExprStatement _
|
4066 F.DefineType _
|F.DefineExpr _
|F.DefineTodo
|
4067 F.DefineHeader
(_
, _
)|F.ReturnExpr
(_
, _
)|F.Return
(_
, _
)|F.MacroIterHeader
(_
, _
)|
4068 F.SwitchHeader
(_
, _
)|F.ForHeader
(_
, _
)|F.DoWhileTail _
|F.DoHeader
(_
, _
)|
4069 F.WhileHeader
(_
, _
)|F.Else _
|F.IfHeader
(_
, _
)|
4070 F.SeqEnd
(_
, _
)|F.SeqStart
(_
, _
, _
)|
4071 F.Decl _
|F.FunHeader _
)