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
28 * Copyright (C) 2009, 2010 DIKU, INRIA, LIP6
30 * This program is free software; you can redistribute it and/or
31 * modify it under the terms of the GNU General Public License (GPL)
32 * version 2 as published by the Free Software Foundation.
34 * This program is distributed in the hope that it will be useful,
35 * but WITHOUT ANY WARRANTY; without even the implied warranty of
36 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
37 * file license.txt for more details.
39 * This file was part of Coccinelle.
47 module F
= Control_flow_c
49 module Flag
= Flag_matcher
51 (*****************************************************************************)
53 (*****************************************************************************)
54 let pr2, pr2_once
= Common.mk_pr2_wrappers
Flag_matcher.verbose_matcher
56 let (+++) a b
= match a
with Some x
-> Some x
| None
-> b
58 (*****************************************************************************)
60 (*****************************************************************************)
62 type sequence
= Ordered
| Unordered
65 match A.unwrap eas
with
67 | A.CIRCLES _
-> Unordered
68 | A.STARS _
-> failwith
"not handling stars"
70 let (redots
: 'a
A.dots
-> 'a list
-> 'a
A.dots
)=fun eas easundots
->
72 match A.unwrap eas
with
73 | A.DOTS _
-> A.DOTS easundots
74 | A.CIRCLES _
-> A.CIRCLES easundots
75 | A.STARS _
-> A.STARS easundots
79 let (need_unordered_initialisers
: B.initialiser
B.wrap2 list
-> bool) =
81 ibs
+> List.exists
(fun (ib
, icomma
) ->
82 match B.unwrap ib
with
91 (* For the #include <linux/...> in the .cocci, need to find where is
92 * the '+' attached to this element, to later find the first concrete
93 * #include <linux/xxx.h> or last one in the series of #includes in the
96 type include_requirement
=
103 (* todo? put in semantic_c.ml *)
106 | LocalFunction
(* entails Function *)
110 let term mc
= A.unwrap_mcode mc
111 let mcodekind mc
= A.get_mcodekind mc
114 let mcode_contain_plus = function
115 | A.CONTEXT
(_
,A.NOTHING
) -> false
116 | A.CONTEXT _
-> true
117 | A.MINUS
(_
,_
,_
,[]) -> false
118 | A.MINUS
(_
,_
,_
,x
::xs
) -> true
119 | A.PLUS _
-> raise Impossible
121 let mcode_simple_minus = function
122 | A.MINUS
(_
,_
,_
,[]) -> true
126 (* In transformation.ml sometime I build some mcodekind myself and
127 * julia has put None for the pos. But there is no possible raise
128 * NoMatch in those cases because it is for the minusall trick or for
129 * the distribute, so either have to build those pos, in fact a range,
130 * because for the distribute have to erase a fullType with one
131 * mcodekind, or add an argument to tag_with_mck such as "safe" that
132 * don't do the check_pos. Hence this DontCarePos constructor. *)
136 {A.line
= 0; A.column
=0; A.strbef
=[]; A.straft
=[];},
137 (A.MINUS
(A.DontCarePos
,[],-1,[])),
140 let generalize_mcode ia
=
141 let (s1
, i
, mck
, pos
) = ia
in
144 | A.PLUS _
-> raise Impossible
145 | A.CONTEXT
(A.NoPos
,x
) ->
146 A.CONTEXT
(A.DontCarePos
,x
)
147 | A.MINUS
(A.NoPos
,inst
,adj
,x
) ->
148 A.MINUS
(A.DontCarePos
,inst
,adj
,x
)
150 | A.CONTEXT
((A.FixPos _
|A.DontCarePos
), _
)
151 | A.MINUS
((A.FixPos _
|A.DontCarePos
), _
, _
, _
)
155 (s1
, i
, new_mck, pos
)
159 (*---------------------------------------------------------------------------*)
161 (* 0x0 is equivalent to 0, value format isomorphism *)
162 let equal_c_int s1 s2
=
164 int_of_string s1
=|= int_of_string s2
165 with Failure
("int_of_string") ->
170 (*---------------------------------------------------------------------------*)
171 (* Normally A should reuse some types of Ast_c, so those
172 * functions should not exist.
174 * update: but now Ast_c depends on A, so can't make too
175 * A depends on Ast_c, so have to stay with those equal_xxx
179 let equal_unaryOp a b
=
181 | A.GetRef
, B.GetRef
-> true
182 | A.DeRef
, B.DeRef
-> true
183 | A.UnPlus
, B.UnPlus
-> true
184 | A.UnMinus
, B.UnMinus
-> true
185 | A.Tilde
, B.Tilde
-> true
186 | A.Not
, B.Not
-> true
187 | _
, B.GetRefLabel
-> false (* todo cocci? *)
188 | _
, (B.Not
|B.Tilde
|B.UnMinus
|B.UnPlus
|B.DeRef
|B.GetRef
) -> false
192 let equal_arithOp a b
=
194 | A.Plus
, B.Plus
-> true
195 | A.Minus
, B.Minus
-> true
196 | A.Mul
, B.Mul
-> true
197 | A.Div
, B.Div
-> true
198 | A.Mod
, B.Mod
-> true
199 | A.DecLeft
, B.DecLeft
-> true
200 | A.DecRight
, B.DecRight
-> true
201 | A.And
, B.And
-> true
202 | A.Or
, B.Or
-> true
203 | A.Xor
, B.Xor
-> true
204 | _
, (B.Xor
|B.Or
|B.And
|B.DecRight
|B.DecLeft
|B.Mod
|B.Div
|B.Mul
|B.Minus
|B.Plus
)
207 let equal_logicalOp a b
=
209 | A.Inf
, B.Inf
-> true
210 | A.Sup
, B.Sup
-> true
211 | A.InfEq
, B.InfEq
-> true
212 | A.SupEq
, B.SupEq
-> true
213 | A.Eq
, B.Eq
-> true
214 | A.NotEq
, B.NotEq
-> true
215 | A.AndLog
, B.AndLog
-> true
216 | A.OrLog
, B.OrLog
-> true
217 | _
, (B.OrLog
|B.AndLog
|B.NotEq
|B.Eq
|B.SupEq
|B.InfEq
|B.Sup
|B.Inf
)
220 let equal_assignOp a b
=
222 | A.SimpleAssign
, B.SimpleAssign
-> true
223 | A.OpAssign a
, B.OpAssign b
-> equal_arithOp a b
224 | _
, (B.OpAssign _
|B.SimpleAssign
) -> false
226 let equal_fixOp a b
=
228 | A.Dec
, B.Dec
-> true
229 | A.Inc
, B.Inc
-> true
230 | _
, (B.Inc
|B.Dec
) -> false
232 let equal_binaryOp a b
=
234 | A.Arith a
, B.Arith b
-> equal_arithOp a b
235 | A.Logical a
, B.Logical b
-> equal_logicalOp a b
236 | _
, (B.Logical _
| B.Arith _
) -> false
238 let equal_structUnion a b
=
240 | A.Struct
, B.Struct
-> true
241 | A.Union
, B.Union
-> true
242 | _
, (B.Struct
|B.Union
) -> false
246 | A.Signed
, B.Signed
-> true
247 | A.Unsigned
, B.UnSigned
-> true
248 | _
, (B.UnSigned
|B.Signed
) -> false
250 let equal_storage a b
=
252 | A.Static
, B.Sto
B.Static
253 | A.Auto
, B.Sto
B.Auto
254 | A.Register
, B.Sto
B.Register
255 | A.Extern
, B.Sto
B.Extern
257 | _
, (B.NoSto
| B.StoTypedef
) -> false
258 | _
, (B.Sto
(B.Register
|B.Static
|B.Auto
|B.Extern
)) -> false
261 (*---------------------------------------------------------------------------*)
263 let equal_metavarval valu valu'
=
264 match valu
, valu'
with
265 | Ast_c.MetaIdVal
(a
,_
), Ast_c.MetaIdVal
(b
,_
) -> a
=$
= b
266 | Ast_c.MetaFuncVal a
, Ast_c.MetaFuncVal b
-> a
=$
= b
267 | Ast_c.MetaLocalFuncVal a
, Ast_c.MetaLocalFuncVal b
->
268 (* do something more ? *)
271 (* al_expr before comparing !!! and accept when they match.
272 * Note that here we have Astc._expression, so it is a match
273 * modulo isomorphism (there is no metavariable involved here,
274 * just isomorphisms). => TODO call isomorphism_c_c instead of
275 * =*=. Maybe would be easier to transform ast_c in ast_cocci
276 * and call the iso engine of julia. *)
277 | Ast_c.MetaExprVal
(a
,_
), Ast_c.MetaExprVal
(b
,_
) ->
278 Lib_parsing_c.al_expr a
=*= Lib_parsing_c.al_expr b
279 | Ast_c.MetaExprListVal a
, Ast_c.MetaExprListVal b
->
280 Lib_parsing_c.al_arguments a
=*= Lib_parsing_c.al_arguments b
282 | Ast_c.MetaDeclVal a
, Ast_c.MetaDeclVal b
->
283 Lib_parsing_c.al_declaration a
=*= Lib_parsing_c.al_declaration b
284 | Ast_c.MetaFieldVal a
, Ast_c.MetaFieldVal b
->
285 Lib_parsing_c.al_field a
=*= Lib_parsing_c.al_field b
286 | Ast_c.MetaStmtVal a
, Ast_c.MetaStmtVal b
->
287 Lib_parsing_c.al_statement a
=*= Lib_parsing_c.al_statement b
288 | Ast_c.MetaInitVal a
, Ast_c.MetaInitVal b
->
289 Lib_parsing_c.al_init a
=*= Lib_parsing_c.al_init b
290 | Ast_c.MetaTypeVal a
, Ast_c.MetaTypeVal b
->
291 (* old: Lib_parsing_c.al_type a =*= Lib_parsing_c.al_type b *)
294 | Ast_c.MetaListlenVal a
, Ast_c.MetaListlenVal b
-> a
=|= b
296 | Ast_c.MetaParamVal a
, Ast_c.MetaParamVal b
->
297 Lib_parsing_c.al_param a
=*= Lib_parsing_c.al_param b
298 | Ast_c.MetaParamListVal a
, Ast_c.MetaParamListVal b
->
299 Lib_parsing_c.al_params a
=*= Lib_parsing_c.al_params b
301 | Ast_c.MetaPosVal
(posa1
,posa2
), Ast_c.MetaPosVal
(posb1
,posb2
) ->
302 Ast_cocci.equal_pos posa1 posb1
&& Ast_cocci.equal_pos posa2 posb2
304 | Ast_c.MetaPosValList l1
, Ast_c.MetaPosValList l2
->
306 (function (fla
,cea
,posa1
,posa2
) ->
308 (function (flb
,ceb
,posb1
,posb2
) ->
309 fla
=$
= flb
&& cea
=$
= ceb
&&
310 Ast_c.equal_posl posa1 posb1
&& Ast_c.equal_posl posa2 posb2
)
314 | (B.MetaPosValList _
|B.MetaListlenVal _
|B.MetaPosVal _
|B.MetaStmtVal _
315 |B.MetaDeclVal _
|B.MetaFieldVal _
|B.MetaTypeVal _
|B.MetaInitVal _
316 |B.MetaParamListVal _
|B.MetaParamVal _
|B.MetaExprListVal _
317 |B.MetaExprVal _
|B.MetaLocalFuncVal _
|B.MetaFuncVal _
|B.MetaIdVal _
321 (* probably only one argument needs to be stripped, because inherited
322 metavariables containing expressions are stripped in advance. But don't
323 know which one is which... *)
324 let equal_inh_metavarval valu valu'
=
325 match valu
, valu'
with
326 | Ast_c.MetaIdVal
(a
,_
), Ast_c.MetaIdVal
(b
,_
) -> a
=$
= b
327 | Ast_c.MetaFuncVal a
, Ast_c.MetaFuncVal b
-> a
=$
= b
328 | Ast_c.MetaLocalFuncVal a
, Ast_c.MetaLocalFuncVal b
->
329 (* do something more ? *)
332 (* al_expr before comparing !!! and accept when they match.
333 * Note that here we have Astc._expression, so it is a match
334 * modulo isomorphism (there is no metavariable involved here,
335 * just isomorphisms). => TODO call isomorphism_c_c instead of
336 * =*=. Maybe would be easier to transform ast_c in ast_cocci
337 * and call the iso engine of julia. *)
338 | Ast_c.MetaExprVal
(a
,_
), Ast_c.MetaExprVal
(b
,_
) ->
339 Lib_parsing_c.al_inh_expr a
=*= Lib_parsing_c.al_inh_expr b
340 | Ast_c.MetaExprListVal a
, Ast_c.MetaExprListVal b
->
341 Lib_parsing_c.al_inh_arguments a
=*= Lib_parsing_c.al_inh_arguments b
343 | Ast_c.MetaDeclVal a
, Ast_c.MetaDeclVal b
->
344 Lib_parsing_c.al_inh_declaration a
=*= Lib_parsing_c.al_inh_declaration b
345 | Ast_c.MetaFieldVal a
, Ast_c.MetaFieldVal b
->
346 Lib_parsing_c.al_inh_field a
=*= Lib_parsing_c.al_inh_field b
347 | Ast_c.MetaStmtVal a
, Ast_c.MetaStmtVal b
->
348 Lib_parsing_c.al_inh_statement a
=*= Lib_parsing_c.al_inh_statement b
349 | Ast_c.MetaInitVal a
, Ast_c.MetaInitVal b
->
350 Lib_parsing_c.al_inh_init a
=*= Lib_parsing_c.al_inh_init b
351 | Ast_c.MetaTypeVal a
, Ast_c.MetaTypeVal b
->
352 (* old: Lib_parsing_c.al_inh_type a =*= Lib_parsing_c.al_inh_type b *)
355 | Ast_c.MetaListlenVal a
, Ast_c.MetaListlenVal b
-> a
=|= b
357 | Ast_c.MetaParamVal a
, Ast_c.MetaParamVal b
->
358 Lib_parsing_c.al_param a
=*= Lib_parsing_c.al_param b
359 | Ast_c.MetaParamListVal a
, Ast_c.MetaParamListVal b
->
360 Lib_parsing_c.al_params a
=*= Lib_parsing_c.al_params b
362 | Ast_c.MetaPosVal
(posa1
,posa2
), Ast_c.MetaPosVal
(posb1
,posb2
) ->
363 Ast_cocci.equal_pos posa1 posb1
&& Ast_cocci.equal_pos posa2 posb2
365 | Ast_c.MetaPosValList l1
, Ast_c.MetaPosValList l2
->
367 (function (fla
,cea
,posa1
,posa2
) ->
369 (function (flb
,ceb
,posb1
,posb2
) ->
370 fla
=$
= flb
&& cea
=$
= ceb
&&
371 Ast_c.equal_posl posa1 posb1
&& Ast_c.equal_posl posa2 posb2
)
375 | (B.MetaPosValList _
|B.MetaListlenVal _
|B.MetaPosVal _
|B.MetaStmtVal _
376 |B.MetaDeclVal _
|B.MetaFieldVal _
|B.MetaTypeVal _
|B.MetaInitVal _
377 |B.MetaParamListVal _
|B.MetaParamVal _
|B.MetaExprListVal _
378 |B.MetaExprVal _
|B.MetaLocalFuncVal _
|B.MetaFuncVal _
|B.MetaIdVal _
383 (*---------------------------------------------------------------------------*)
384 (* could put in ast_c.ml, next to the split/unsplit_comma *)
385 let split_signb_baseb_ii (baseb
, ii
) =
386 let iis = ii
+> List.map
(fun info
-> (B.str_of_info info
), info
) in
387 match baseb
, iis with
389 | B.Void
, ["void",i1
] -> None
, [i1
]
391 | B.FloatType
(B.CFloat
),["float",i1
] -> None
, [i1
]
392 | B.FloatType
(B.CDouble
),["double",i1
] -> None
, [i1
]
393 | B.FloatType
(B.CLongDouble
),["long",i1
;"double",i2
] -> None
,[i1
;i2
]
395 | B.IntType
(B.CChar
), ["char",i1
] -> None
, [i1
]
398 | B.IntType
(B.Si
(sign
, base
)), xs
->
402 | (B.Signed
,(("signed",i1
)::rest
)) -> (Some
(B.Signed
,i1
),rest
)
403 | (B.Signed
,rest
) -> (None
,rest
)
404 | (B.UnSigned
,(("unsigned",i1
)::rest
)) -> (Some
(B.UnSigned
,i1
),rest
)
405 | (B.UnSigned
,rest
) -> (* is this case possible? *) (None
,rest
) in
406 (* The original code only allowed explicit signed and unsigned for char,
407 while this code allows char by itself. Not sure that needs to be
408 checked for here. If it does, then add a special case. *)
410 match (base
,rest
) with
411 B.CInt
, ["int",i1
] -> [i1
]
414 | B.CInt
, ["",i1
] -> (* no type is specified at all *)
415 (match i1
.B.pinfo
with
417 | _
-> failwith
("unrecognized signed int: "^
418 (String.concat
" "(List.map fst
iis))))
420 | B.CChar2
, ["char",i2
] -> [i2
]
422 | B.CShort
, ["short",i1
] -> [i1
]
423 | B.CShort
, ["short",i1
;"int",i2
] -> [i1
;i2
]
425 | B.CLong
, ["long",i1
] -> [i1
]
426 | B.CLong
, ["long",i1
;"int",i2
] -> [i1
;i2
]
428 | B.CLongLong
, ["long",i1
;"long",i2
] -> [i1
;i2
]
429 | B.CLongLong
, ["long",i1
;"long",i2
;"int",i3
] -> [i1
;i2
;i3
]
432 failwith
("strange type1, maybe because of weird order: "^
433 (String.concat
" " (List.map fst
iis))) in
435 | _
-> failwith
("strange type2, maybe because of weird order: "^
436 (String.concat
" " (List.map fst
iis)))
438 (*---------------------------------------------------------------------------*)
440 let rec unsplit_icomma xs
=
444 (match A.unwrap y
with
446 (x
, y
)::unsplit_icomma xs
447 | _
-> failwith
"wrong ast_cocci in initializer"
450 failwith
("wrong ast_cocci in initializer, should have pair " ^
455 let resplit_initialiser ibs iicomma
=
456 match iicomma
, ibs
with
459 failwith
"should have a iicomma, do you generate fakeInfo in parser?"
461 failwith
"shouldn't have a iicomma"
462 | [iicomma
], x
::xs
->
463 let elems = List.map fst
(x
::xs
) in
464 let commas = List.map snd
(x
::xs
) +> List.flatten
in
465 let commas = commas @ [iicomma
] in
467 | _
-> raise Impossible
471 let rec split_icomma xs
=
474 | (x
,y
)::xs
-> x
::y
::split_icomma xs
476 let rec unsplit_initialiser ibs_unsplit
=
477 match ibs_unsplit
with
478 | [] -> [], [] (* empty iicomma *)
480 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
481 (x
, [])::xs
, lastcomma
483 and unsplit_initialiser_bis comma_before
= function
484 | [] -> [], [comma_before
]
486 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
487 (x
, [comma_before
])::xs
, lastcomma
492 (*---------------------------------------------------------------------------*)
493 (* coupling: same in type_annotater_c.ml *)
494 let structdef_to_struct_name ty
=
496 | qu
, (B.StructUnion
(su
, sopt
, fields
), iis) ->
498 | Some s
, [i1
;i2
;i3
;i4
] ->
499 qu
, (B.StructUnionName
(su
, s
), [i1
;i2
])
503 | x
-> raise Impossible
505 | _
-> raise Impossible
507 (*---------------------------------------------------------------------------*)
508 let one_initialisation_to_affectation x
=
509 let ({B.v_namei
= var
;
510 B.v_type
= returnType
;
511 B.v_type_bis
= tybis
;
512 B.v_storage
= storage
;
516 | Some
(name
, iniopt
) ->
518 | Some
(iini
, (B.InitExpr e
, ii_empty2
)) ->
521 Ast_c.NotLocalDecl
-> Ast_c.NotLocalVar
523 Ast_c.LocalVar
(Ast_c.info_of_type returnType
) in
525 (* old: Lib_parsing_c.al_type returnType
526 * but this type has not the typename completed so
527 * instead try to use tybis
530 | Some ty_with_typename_completed
-> ty_with_typename_completed
531 | None
-> raise Impossible
534 let typ = ref (Some
(typexp,local), Ast_c.NotTest
) in
536 let idexpr = Ast_c.mk_e_bis
(B.Ident
ident) typ Ast_c.noii
in
538 Ast_c.mk_e
(B.Assignment
(idexpr,B.SimpleAssign
, e
)) [iini
] in
543 let initialisation_to_affectation decl
=
545 | B.MacroDecl _
-> F.Decl decl
546 | B.DeclList
(xs
, iis) ->
548 (* todo?: should not do that if the variable is an array cos
549 * will have x[] = , mais de toute facon ca sera pas un InitExp
551 let possible_assignment =
555 match prev
,one_initialisation_to_affectation x
with
557 | None
,Some x
-> Some x
558 | Some prev
,Some x
->
559 (* [] is clearly an invalid ii value for a sequence.
560 hope that no one looks at it, since nothing will
561 match the sequence. Fortunately, SmPL doesn't
562 support , expressions. *)
563 Some
(Ast_c.mk_e
(Ast_c.Sequence
(prev
, x
)) []))
565 match possible_assignment with
566 Some x
-> F.DefineExpr x
567 | None
-> F.Decl decl
569 (*****************************************************************************)
570 (* Functor parameter combinators *)
571 (*****************************************************************************)
573 * src: papers on parser combinators in haskell (cf a pearl by meijer in ICFP)
575 * version0: was not tagging the SP, so just tag the C
577 * (tin -> 'c tout) -> ('c -> (tin -> 'b tout)) -> (tin -> 'b tout)
578 * val return : 'b -> tin -> 'b tout
579 * val fail : tin -> 'b tout
581 * version1: now also tag the SP so return a ('a * 'b)
584 type mode
= PatternMode
| TransformMode
592 type ('a
, 'b
) matcher
= 'a
-> 'b
-> tin
-> ('a
* 'b
) tout
597 (tin
-> ('a
* 'b
) tout
) ->
598 ('a
-> 'b
-> (tin
-> ('c
* 'd
) tout
)) ->
599 (tin
-> ('c
* 'd
) tout
)
601 val return
: ('a
* 'b
) -> tin
-> ('a
*'b
) tout
602 val fail
: tin
-> ('a
* 'b
) tout
614 val (>&&>) : (tin
-> bool) -> (tin
-> 'x tout
) -> (tin
-> 'x tout
)
616 val tokenf
: ('a
A.mcode
, B.info
) matcher
617 val tokenf_mck
: (A.mcodekind, B.info
) matcher
620 (A.meta_name
A.mcode
, B.expression
) matcher
622 (A.meta_name
A.mcode
, (Ast_c.argument
, Ast_c.il
) either list
) matcher
624 (A.meta_name
A.mcode
, Ast_c.fullType
) matcher
626 (A.meta_name
A.mcode
,
627 (Ast_c.parameterType
, Ast_c.il
) either list
) matcher
629 (A.meta_name
A.mcode
, Ast_c.parameterType
) matcher
631 (A.meta_name
A.mcode
, Ast_c.initialiser
) matcher
633 (A.meta_name
A.mcode
, (Ast_c.initialiser
, Ast_c.il
) either list
) matcher
635 (A.meta_name
A.mcode
, Ast_c.declaration
) matcher
637 (A.meta_name
A.mcode
, Ast_c.field
) matcher
639 (A.meta_name
A.mcode
, Control_flow_c.node
) matcher
641 val distrf_define_params
:
642 (A.meta_name
A.mcode
, (string Ast_c.wrap
, Ast_c.il
) either list
) matcher
644 val distrf_enum_fields
:
645 (A.meta_name
A.mcode
, (B.oneEnumType
, B.il
) either list
) matcher
647 val distrf_struct_fields
:
648 (A.meta_name
A.mcode
, B.field list
) matcher
651 (A.meta_name
A.mcode
, (B.constant
, string) either
B.wrap
) matcher
654 (A.expression
, B.expression
) matcher
-> (A.expression
, F.node
) matcher
657 (A.expression
, B.expression
) matcher
->
658 (A.expression
, B.expression
) matcher
661 (A.fullType
, B.fullType
) matcher
-> (A.fullType
, F.node
) matcher
664 (A.initialiser
, B.initialiser
) matcher
-> (A.initialiser
, F.node
) matcher
667 A.keep_binding
-> A.inherited
->
668 A.meta_name
A.mcode
* Ast_c.metavar_binding_kind
*
669 (unit -> Common.filename
* string * Ast_c.posl
* Ast_c.posl
) ->
670 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
672 val check_idconstraint
:
673 ('a
-> 'b
-> bool) -> 'a
-> 'b
->
674 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
676 val check_constraints_ne
:
677 ('a
, 'b
) matcher
-> 'a list
-> 'b
->
678 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
680 val all_bound
: A.meta_name list
-> (tin
-> bool)
682 val optional_storage_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
683 val optional_qualifier_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
684 val value_format_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
689 (*****************************************************************************)
690 (* Functor code, "Cocci vs C" *)
691 (*****************************************************************************)
694 functor (X
: PARAM
) ->
697 type ('a
, 'b
) matcher
= 'a
-> 'b
-> X.tin
-> ('a
* 'b
) X.tout
700 let return = X.return
703 let (>||>) = X.(>||>)
704 let (>|+|>) = X.(>|+|>)
705 let (>&&>) = X.(>&&>)
707 let tokenf = X.tokenf
709 (* should be raise Impossible when called from transformation.ml *)
712 | PatternMode
-> fail
713 | TransformMode
-> raise Impossible
716 let (option: ('a
,'b
) matcher
-> ('a
option,'b
option) matcher
)= fun f t1 t2
->
718 | (Some t1
, Some t2
) ->
719 f t1 t2
>>= (fun t1 t2
->
720 return (Some t1
, Some t2
)
722 | (None
, None
) -> return (None
, None
)
725 (* Dots are sometimes used as metavariables, since like metavariables they
726 can match other things. But they no longer have the same type. Perhaps these
727 functions could be avoided by introducing an appropriate level of polymorphism,
728 but I don't know how to declare polymorphism across functors *)
729 let dots2metavar (_
,info
,mcodekind,pos
) =
730 (("","..."),info
,mcodekind,pos
)
731 let metavar2dots (_
,info
,mcodekind,pos
) = ("...",info
,mcodekind,pos
)
733 let satisfies_regexpconstraint c id
: bool =
735 A.IdRegExp
(_
,recompiled
) -> Str.string_match recompiled id
0
736 | A.IdNotRegExp
(_
,recompiled
) -> not
(Str.string_match recompiled id
0)
738 let satisfies_iconstraint c id
: bool =
741 let satisfies_econstraint c exp
: bool =
742 let warning s
= pr2_once
("WARNING: "^s
); false in
743 match Ast_c.unwrap_expr exp
with
744 Ast_c.Ident
(name
) ->
746 Ast_c.RegularName rname
->
747 satisfies_regexpconstraint c
(Ast_c.unwrap_st rname
)
748 | Ast_c.CppConcatenatedName _
->
750 "Unable to apply a constraint on a CppConcatenatedName identifier!"
751 | Ast_c.CppVariadicName _
->
753 "Unable to apply a constraint on a CppVariadicName identifier!"
754 | Ast_c.CppIdentBuilder _
->
756 "Unable to apply a constraint on a CppIdentBuilder identifier!")
757 | Ast_c.Constant cst
->
759 | Ast_c.String
(str
, _
) -> satisfies_regexpconstraint c str
760 | Ast_c.MultiString strlist
->
761 warning "Unable to apply a constraint on an multistring constant!"
762 | Ast_c.Char
(char
, _
) -> satisfies_regexpconstraint c char
763 | Ast_c.Int
(int , _
) -> satisfies_regexpconstraint c
int
764 | Ast_c.Float
(float, _
) -> satisfies_regexpconstraint c
float)
765 | _
-> warning "Unable to apply a constraint on an expression!"
768 (* ------------------------------------------------------------------------- *)
769 (* This has to be up here to allow adequate polymorphism *)
771 let list_matcher match_dots rebuild_dots match_comma rebuild_comma
772 match_metalist rebuild_metalist mktermval special_cases
773 element distrf get_iis
= fun eas ebs
->
774 let rec loop = function
775 [], [] -> return ([], [])
776 | [], eb
::ebs
-> fail
778 X.all_bound
(A.get_inherited ea
) >&&>
780 (match match_dots ea
, ebs
with
781 Some
(mcode
, optexpr
), ys
->
782 (* todo: if optexpr, then a WHEN and so may have to filter yys *)
783 if optexpr
<> None
then failwith
"not handling when in a list";
785 (* '...' can take more or less the beginnings of the arguments *)
787 Common.zip
(Common.inits ys
) (Common.tails ys
) in
789 (startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
792 (* allow '...', and maybe its associated ',' to match nothing.
793 * for the associated ',' see below how we handle the EComma
798 if mcode_contain_plus (mcodekind mcode
)
801 "I have no token that I could accroche myself on"*)
802 else return (dots2metavar mcode
, [])
804 (* subtil: we dont want the '...' to match until the
805 * comma. cf -test pb_params_iso. We would get at
806 * "already tagged" error.
807 * this is because both f (... x, ...) and f (..., x, ...)
808 * would match a f(x,3) with our "optional-comma" strategy.
810 (match Common.last startxs
with
812 | Left _
-> distrf
(dots2metavar mcode
) startxs
))
814 >>= (fun mcode startxs
->
815 let mcode = metavar2dots mcode in
816 loop (eas
, endxs
) >>= (fun eas endxs
->
818 (rebuild_dots
(mcode, optexpr
) +> A.rewrap ea
) ::eas
,
826 (match match_comma ea
, ebs
with
827 | Some ia1
, Right ii
::ebs
->
829 (let ib1 = tuple_of_list1 ii
in
830 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
831 loop (eas
, ebs
) >>= (fun eas ebs
->
833 (rebuild_comma ia1
+> A.rewrap ea
)::eas
,
838 (* allow ',' to maching nothing. optional comma trick *)
840 (if mcode_contain_plus (mcodekind ia1
)
842 else loop (eas
, ebs
))
845 (match match_metalist ea
, ebs
with
846 Some
(ida
,leninfo
,keep
,inherited
), ys
->
848 Common.zip
(Common.inits ys
) (Common.tails ys
) in
850 (startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
855 if mcode_contain_plus (mcodekind ida
)
857 (* failwith "no token that I could accroche myself on" *)
860 (match Common.last startxs
with
867 let startxs'
= Ast_c.unsplit_comma
startxs in
868 let len = List.length
startxs'
in
871 | A.MetaListLen
(lenname
,lenkeep
,leninherited
) ->
872 let max_min _
= failwith
"no pos" in
873 X.envf lenkeep leninherited
874 (lenname
, Ast_c.MetaListlenVal
(len), max_min)
877 then (function f
-> f
())
878 else (function f
-> fail)
879 | A.AnyListLen
-> function f
-> f
()
883 Lib_parsing_c.lin_col_by_pos
(get_iis
startxs) in
884 X.envf keep inherited
885 (ida
, mktermval
startxs'
, max_min)
888 then return (ida
, [])
889 else distrf ida
(Ast_c.split_comma
startxs'
))
890 >>= (fun ida
startxs ->
891 loop (eas
, endxs
) >>= (fun eas endxs
->
893 (rebuild_metalist
(ida
,leninfo
,keep
,inherited
))
902 special_cases ea eas ebs
in
903 match try_matches with
908 element ea eb
>>= (fun ea eb
->
909 loop (eas
, ebs
) >>= (fun eas ebs
->
910 return (ea
::eas
, Left eb
::ebs
)))
911 | (Right y
)::ys
-> raise Impossible
915 (*---------------------------------------------------------------------------*)
927 (*---------------------------------------------------------------------------*)
928 let rec (expression
: (A.expression
, Ast_c.expression
) matcher
) =
930 if A.get_test_exp ea
&& not
(Ast_c.is_test eb
) then fail
932 X.all_bound
(A.get_inherited ea
) >&&>
933 let wa x
= A.rewrap ea x
in
934 match A.unwrap ea
, eb
with
936 (* general case: a MetaExpr can match everything *)
937 | A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
),
938 (((expr
, opttypb
), ii
) as expb
) ->
940 (* old: before have a MetaConst. Now we factorize and use 'form' to
941 * differentiate between different cases *)
942 let rec matches_id = function
943 B.Ident
(name
) -> true
944 | B.Cast
(ty
,e
) -> matches_id (B.unwrap_expr e
)
947 match (form
,expr
) with
950 let rec matches = function
951 B.Constant
(c
) -> true
952 | B.Ident
(nameidb
) ->
953 let s = Ast_c.str_of_name nameidb
in
954 if s =~
"^[A-Z_][A-Z_0-9]*$"
956 pr2_once
("warning: " ^
s ^
" treated as a constant");
960 | B.Cast
(ty
,e
) -> matches (B.unwrap_expr e
)
961 | B.Unary
(e
,B.UnMinus
) -> matches (B.unwrap_expr e
)
962 | B.SizeOfExpr
(exp
) -> true
963 | B.SizeOfType
(ty
) -> true
969 (Some
(_
,Ast_c.LocalVar _
),_
) -> true
971 | (A.ID
,e
) -> matches_id e
in
975 (let (opttypb
,_testb
) = !opttypb
in
976 match opttypa
, opttypb
with
977 | None
, _
-> return ((),())
979 pr2_once
("Missing type information. Certainly a pb in " ^
980 "annotate_typer.ml");
983 | Some tas
, Some tb
->
984 tas
+> List.fold_left
(fun acc ta
->
985 acc
>|+|> compatible_type ta tb
) fail
988 let meta_expr_val l x
= Ast_c.MetaExprVal
(x
,l
) in
989 match constraints
with
990 Ast_cocci.NoConstraint
-> return (meta_expr_val [],())
991 | Ast_cocci.NotIdCstrt cstrt
->
992 X.check_idconstraint
satisfies_econstraint cstrt eb
993 (fun () -> return (meta_expr_val [],()))
994 | Ast_cocci.NotExpCstrt cstrts
->
995 X.check_constraints_ne expression cstrts eb
996 (fun () -> return (meta_expr_val [],()))
997 | Ast_cocci.SubExpCstrt cstrts
->
998 return (meta_expr_val cstrts
,()))
1002 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_expr expb
) in
1003 X.envf keep inherited
(ida
, wrapper expb
, max_min)
1005 X.distrf_e ida expb
>>=
1008 A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
)+>
1016 * | A.MetaExpr(ida,false,opttypa,_inherited), expb ->
1017 * D.distribute_mck (mcodekind ida) D.distribute_mck_e expb binding
1019 * but bug! because if have not tagged SP, then transform without doing
1020 * any checks. Hopefully now have tagged SP technique.
1025 * | A.Edots _, _ -> raise Impossible.
1027 * In fact now can also have the Edots inside normal expression, not
1028 * just in arg lists. in 'x[...];' less: in if(<... x ... y ...>)
1030 | A.Edots
(mcode, None
), expb
->
1031 X.distrf_e
(dots2metavar mcode) expb
>>= (fun mcode expb
->
1033 A.Edots
(metavar2dots mcode, None
) +> A.rewrap ea
,
1038 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
1041 | A.Ident ida
, ((B.Ident
(nameidb
), typ),noii
) ->
1043 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1045 ((A.Ident ida
)) +> wa,
1046 ((B.Ident
(nameidb
), typ),Ast_c.noii
)
1052 | A.MetaErr _
, _
-> failwith
"not handling MetaErr"
1054 (* todo?: handle some isomorphisms in int/float ? can have different
1055 * format : 1l can match a 1.
1057 * todo: normally string can contain some metavar too, so should
1058 * recurse on the string
1060 | A.Constant
(ia1
), ((B.Constant
(ib
) , typ),ii
) ->
1061 (* for everything except the String case where can have multi elems *)
1063 let ib1 = tuple_of_list1 ii
in
1064 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1066 ((A.Constant ia1
)) +> wa,
1067 ((B.Constant
(ib
), typ),[ib1])
1070 (match term ia1
, ib
with
1071 | A.Int x
, B.Int
(y
,_
) ->
1072 X.value_format_flag
(fun use_value_equivalence
->
1073 if use_value_equivalence
1083 | A.Char x
, B.Char
(y
,_
) when x
=$
= y
(* todo: use kind ? *)
1085 | A.Float x
, B.Float
(y
,_
) when x
=$
= y
(* todo: use floatType ? *)
1088 | A.String sa
, B.String
(sb
,_kind
) when sa
=$
= sb
->
1091 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1093 ((A.Constant ia1
)) +> wa,
1094 ((B.Constant
(ib
), typ),[ib1])
1096 | _
-> fail (* multi string, not handled *)
1099 | _
, B.MultiString _
-> (* todo cocci? *) fail
1100 | _
, (B.String _
| B.Float _
| B.Char _
| B.Int _
) -> fail
1104 | A.FunCall
(ea
, ia1
, eas
, ia2
), ((B.FunCall
(eb
, ebs
), typ),ii
) ->
1105 (* todo: do special case to allow IdMetaFunc, cos doing the
1106 * recursive call will be too late, match_ident will not have the
1107 * info whether it was a function. todo: but how detect when do
1108 * x.field = f; how know that f is a Func ? By having computed
1109 * some information before the matching!
1111 * Allow match with FunCall containing types. Now ast_cocci allow
1112 * type in parameter, and morover ast_cocci allow f(...) and those
1113 * ... could match type.
1115 let (ib1, ib2
) = tuple_of_list2 ii
in
1116 expression ea eb
>>= (fun ea eb
->
1117 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1118 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1119 arguments
(seqstyle eas
) (A.undots eas
) ebs
>>= (fun easundots ebs
->
1120 let eas = redots
eas easundots
in
1122 ((A.FunCall
(ea
, ia1
, eas, ia2
)) +> wa,
1123 ((B.FunCall
(eb
, ebs
),typ), [ib1;ib2
])
1129 | A.Assignment
(ea1
, opa
, ea2
, simple
),
1130 ((B.Assignment
(eb1
, opb
, eb2
), typ),ii
) ->
1131 let (opbi
) = tuple_of_list1 ii
in
1132 if equal_assignOp (term opa
) opb
1134 expression ea1 eb1
>>= (fun ea1 eb1
->
1135 expression ea2 eb2
>>= (fun ea2 eb2
->
1136 tokenf opa opbi
>>= (fun opa opbi
->
1138 (A.Assignment
(ea1
, opa
, ea2
, simple
)) +> wa,
1139 ((B.Assignment
(eb1
, opb
, eb2
), typ), [opbi
])
1143 | A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
),((B.CondExpr
(eb1
,eb2opt
,eb3
),typ),ii
) ->
1144 let (ib1, ib2
) = tuple_of_list2 ii
in
1145 expression ea1 eb1
>>= (fun ea1 eb1
->
1146 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
1147 expression ea3 eb3
>>= (fun ea3 eb3
->
1148 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1149 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1151 ((A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
))) +> wa,
1152 ((B.CondExpr
(eb1
, eb2opt
, eb3
),typ), [ib1;ib2
])
1155 (* todo?: handle some isomorphisms here ? *)
1156 | A.Postfix
(ea
, opa
), ((B.Postfix
(eb
, opb
), typ),ii
) ->
1157 let opbi = tuple_of_list1 ii
in
1158 if equal_fixOp (term opa
) opb
1160 expression ea eb
>>= (fun ea eb
->
1161 tokenf opa
opbi >>= (fun opa
opbi ->
1163 ((A.Postfix
(ea
, opa
))) +> wa,
1164 ((B.Postfix
(eb
, opb
), typ),[opbi])
1169 | A.Infix
(ea
, opa
), ((B.Infix
(eb
, opb
), typ),ii
) ->
1170 let opbi = tuple_of_list1 ii
in
1171 if equal_fixOp (term opa
) opb
1173 expression ea eb
>>= (fun ea eb
->
1174 tokenf opa
opbi >>= (fun opa
opbi ->
1176 ((A.Infix
(ea
, opa
))) +> wa,
1177 ((B.Infix
(eb
, opb
), typ),[opbi])
1181 | A.Unary
(ea
, opa
), ((B.Unary
(eb
, opb
), typ),ii
) ->
1182 let opbi = tuple_of_list1 ii
in
1183 if equal_unaryOp (term opa
) opb
1185 expression ea eb
>>= (fun ea eb
->
1186 tokenf opa
opbi >>= (fun opa
opbi ->
1188 ((A.Unary
(ea
, opa
))) +> wa,
1189 ((B.Unary
(eb
, opb
), typ),[opbi])
1193 | A.Binary
(ea1
, opa
, ea2
), ((B.Binary
(eb1
, opb
, eb2
), typ),ii
) ->
1194 let opbi = tuple_of_list1 ii
in
1195 if equal_binaryOp (term opa
) opb
1197 expression ea1 eb1
>>= (fun ea1 eb1
->
1198 expression ea2 eb2
>>= (fun ea2 eb2
->
1199 tokenf opa
opbi >>= (fun opa
opbi ->
1201 ((A.Binary
(ea1
, opa
, ea2
))) +> wa,
1202 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1206 | A.Nested
(ea1
, opa
, ea2
), eb
->
1208 expression ea1 eb
>|+|>
1210 ((B.Binary
(eb1
, opb
, eb2
), typ),ii
)
1211 when equal_binaryOp (term opa
) opb
->
1212 let opbi = tuple_of_list1 ii
in
1214 (expression ea1 eb1
>>= (fun ea1 eb1
->
1215 expression ea2 eb2
>>= (fun ea2 eb2
->
1216 tokenf opa
opbi >>= (fun opa
opbi ->
1218 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1219 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1222 (expression ea2 eb1
>>= (fun ea2 eb1
->
1223 expression ea1 eb2
>>= (fun ea1 eb2
->
1224 tokenf opa
opbi >>= (fun opa
opbi ->
1226 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1227 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1230 (loop eb1
>>= (fun ea1 eb1
->
1231 expression ea2 eb2
>>= (fun ea2 eb2
->
1232 tokenf opa
opbi >>= (fun opa
opbi ->
1234 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1235 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1238 (expression ea2 eb1
>>= (fun ea2 eb1
->
1239 loop eb2
>>= (fun ea1 eb2
->
1240 tokenf opa
opbi >>= (fun opa
opbi ->
1242 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1243 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1245 left_to_right >|+|> right_to_left >|+|> in_left >|+|> in_right
1249 (* todo?: handle some isomorphisms here ? (with pointers = Unary Deref) *)
1250 | A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
),((B.ArrayAccess
(eb1
, eb2
), typ),ii
) ->
1251 let (ib1, ib2
) = tuple_of_list2 ii
in
1252 expression ea1 eb1
>>= (fun ea1 eb1
->
1253 expression ea2 eb2
>>= (fun ea2 eb2
->
1254 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1255 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1257 ((A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
))) +> wa,
1258 ((B.ArrayAccess
(eb1
, eb2
),typ), [ib1;ib2
])
1261 (* todo?: handle some isomorphisms here ? *)
1262 | A.RecordAccess
(ea
, ia1
, ida
), ((B.RecordAccess
(eb
, idb
), typ),ii
) ->
1263 let (ib1) = tuple_of_list1 ii
in
1264 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
1265 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1266 expression ea eb
>>= (fun ea eb
->
1268 ((A.RecordAccess
(ea
, ia1
, ida
))) +> wa,
1269 ((B.RecordAccess
(eb
, idb
), typ), [ib1])
1274 | A.RecordPtAccess
(ea
,ia1
,ida
),((B.RecordPtAccess
(eb
, idb
), typ), ii
) ->
1275 let (ib1) = tuple_of_list1 ii
in
1276 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
1277 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1278 expression ea eb
>>= (fun ea eb
->
1280 ((A.RecordPtAccess
(ea
, ia1
, ida
))) +> wa,
1281 ((B.RecordPtAccess
(eb
, idb
), typ), [ib1])
1285 (* todo?: handle some isomorphisms here ?
1286 * todo?: do some iso-by-absence on cast ?
1287 * by trying | ea, B.Case (typb, eb) -> match_e_e ea eb ?
1290 | A.Cast
(ia1
, typa
, ia2
, ea
), ((B.Cast
(typb
, eb
), typ),ii
) ->
1291 let (ib1, ib2
) = tuple_of_list2 ii
in
1292 fullType typa typb
>>= (fun typa typb
->
1293 expression ea eb
>>= (fun ea eb
->
1294 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1295 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1297 ((A.Cast
(ia1
, typa
, ia2
, ea
))) +> wa,
1298 ((B.Cast
(typb
, eb
),typ),[ib1;ib2
])
1301 | A.SizeOfExpr
(ia1
, ea
), ((B.SizeOfExpr
(eb
), typ),ii
) ->
1302 let ib1 = tuple_of_list1 ii
in
1303 expression ea eb
>>= (fun ea eb
->
1304 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1306 ((A.SizeOfExpr
(ia1
, ea
))) +> wa,
1307 ((B.SizeOfExpr
(eb
), typ),[ib1])
1310 | A.SizeOfType
(ia1
, ia2
, typa
, ia3
), ((B.SizeOfType typb
, typ),ii
) ->
1311 let (ib1,ib2
,ib3
) = tuple_of_list3 ii
in
1312 fullType typa typb
>>= (fun typa typb
->
1313 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1314 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1315 tokenf ia3 ib3
>>= (fun ia3 ib3
->
1317 ((A.SizeOfType
(ia1
, ia2
, typa
, ia3
))) +> wa,
1318 ((B.SizeOfType
(typb
),typ),[ib1;ib2
;ib3
])
1322 (* todo? iso ? allow all the combinations ? *)
1323 | A.Paren
(ia1
, ea
, ia2
), ((B.ParenExpr
(eb
), typ),ii
) ->
1324 let (ib1, ib2
) = tuple_of_list2 ii
in
1325 expression ea eb
>>= (fun ea eb
->
1326 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1327 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1329 ((A.Paren
(ia1
, ea
, ia2
))) +> wa,
1330 ((B.ParenExpr
(eb
), typ), [ib1;ib2
])
1333 | A.NestExpr
(starter
,exps
,ender
,None
,true), eb
->
1334 (match A.get_mcodekind starter
with
1335 A.MINUS _
-> failwith
"TODO: only context nests supported"
1337 (match A.unwrap exps
with
1339 X.cocciExpExp expression exp eb
>>= (fun exp eb
->
1342 (starter
,A.rewrap exps
(A.DOTS
[exp
]),ender
,None
,true)) +> wa,
1348 "for nestexpr, only handling the case with dots and only one exp")
1350 | A.NestExpr _
, _
->
1351 failwith
"only handling multi and no when code in a nest expr"
1353 (* only in arg lists or in define body *)
1354 | A.TypeExp _
, _
-> fail
1356 (* only in arg lists *)
1357 | A.MetaExprList _
, _
1364 | A.DisjExpr
eas, eb
->
1365 eas +> List.fold_left
(fun acc ea
-> acc
>|+|> (expression ea eb
)) fail
1367 | A.UniqueExp _
,_
| A.OptExp _
,_
->
1368 failwith
"not handling Opt/Unique/Multi on expr"
1370 (* Because of Exp cant put a raise Impossible; have to put a fail *)
1372 (* have not a counter part in coccinelle, for the moment *)
1373 | _
, ((B.Sequence _
,_
),_
)
1374 | _
, ((B.StatementExpr _
,_
),_
)
1375 | _
, ((B.Constructor _
,_
),_
)
1380 (((B.Cast
(_
, _
)|B.ParenExpr _
|B.SizeOfType _
|B.SizeOfExpr _
|
1381 B.RecordPtAccess
(_
, _
)|
1382 B.RecordAccess
(_
, _
)|B.ArrayAccess
(_
, _
)|
1383 B.Binary
(_
, _
, _
)|B.Unary
(_
, _
)|
1384 B.Infix
(_
, _
)|B.Postfix
(_
, _
)|
1385 B.Assignment
(_
, _
, _
)|B.CondExpr
(_
, _
, _
)|
1386 B.FunCall
(_
, _
)|B.Constant _
|B.Ident _
),
1394 (* ------------------------------------------------------------------------- *)
1395 and (ident_cpp
: info_ident
-> (A.ident, B.name
) matcher
) =
1396 fun infoidb ida idb
->
1398 | B.RegularName
(s, iis) ->
1399 let iis = tuple_of_list1
iis in
1400 ident infoidb ida
(s, iis) >>= (fun ida
(s,iis) ->
1403 (B.RegularName
(s, [iis]))
1405 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
1407 (* This should be moved to the Id case of ident. Metavariables
1408 should be allowed to be bound to such variables. But doing so
1409 would require implementing an appropriate distr function *)
1412 and (ident: info_ident
-> (A.ident, string * Ast_c.info
) matcher
) =
1413 fun infoidb ida
((idb
, iib
)) -> (* (idb, iib) as ib *)
1414 let check_constraints constraints idb
=
1415 let meta_id_val l x
= Ast_c.MetaIdVal
(x
,l
) in
1416 match constraints
with
1417 A.IdNoConstraint
-> return (meta_id_val [],())
1418 | A.IdNegIdSet
(str
,meta
) ->
1419 X.check_idconstraint
satisfies_iconstraint str idb
1420 (fun () -> return (meta_id_val meta
,()))
1421 | A.IdRegExpConstraint re
->
1422 X.check_idconstraint
satisfies_regexpconstraint re idb
1423 (fun () -> return (meta_id_val [],())) in
1424 X.all_bound
(A.get_inherited ida
) >&&>
1425 match A.unwrap ida
with
1427 if (term sa
) =$
= idb
then
1428 tokenf sa iib
>>= (fun sa iib
->
1430 ((A.Id sa
)) +> A.rewrap ida
,
1435 | A.MetaId
(mida
,constraints
,keep
,inherited
) ->
1436 check_constraints constraints idb
>>=
1438 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1439 (* use drop_pos for ids so that the pos is not added a second time in
1440 the call to tokenf *)
1441 X.envf keep inherited
(A.drop_pos mida
, wrapper idb
, max_min)
1443 tokenf mida iib
>>= (fun mida iib
->
1445 ((A.MetaId
(mida
, constraints
, keep
, inherited
)) +> A.rewrap ida
,
1450 | A.MetaFunc
(mida
,constraints
,keep
,inherited
) ->
1452 check_constraints constraints idb
>>=
1454 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1455 X.envf keep inherited
(A.drop_pos mida
,Ast_c.MetaFuncVal idb
,max_min)
1457 tokenf mida iib
>>= (fun mida iib
->
1459 ((A.MetaFunc
(mida
,constraints
,keep
,inherited
)))+>A.rewrap ida
,
1464 | LocalFunction
| Function
-> is_function()
1466 failwith
"MetaFunc, need more semantic info about id"
1467 (* the following implementation could possibly be useful, if one
1468 follows the convention that a macro is always in capital letters
1469 and that a macro is not a function.
1470 (if idb =~ "^[A-Z_][A-Z_0-9]*$" then fail else is_function())*)
1473 | A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
) ->
1476 check_constraints constraints idb
>>=
1478 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1479 X.envf keep inherited
1480 (A.drop_pos mida
,Ast_c.MetaLocalFuncVal idb
, max_min)
1482 tokenf mida iib
>>= (fun mida iib
->
1484 ((A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
)))
1490 | DontKnow
-> failwith
"MetaLocalFunc, need more semantic info about id"
1493 | A.OptIdent _
| A.UniqueIdent _
->
1494 failwith
"not handling Opt/Unique for ident"
1496 (* ------------------------------------------------------------------------- *)
1497 and (arguments
: sequence
->
1498 (A.expression list
, Ast_c.argument
Ast_c.wrap2 list
) matcher
) =
1499 fun seqstyle eas ebs
->
1501 | Unordered
-> failwith
"not handling ooo"
1503 arguments_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1504 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1506 (* because '...' can match nothing, need to take care when have
1507 * ', ...' or '...,' as in f(..., X, Y, ...). It must match
1508 * f(1,2) for instance.
1509 * So I have added special cases such as (if startxs = []) and code
1510 * in the Ecomma matching rule.
1512 * old: Must do some try, for instance when f(...,X,Y,...) have to
1513 * test the transfo for all the combinaitions and if multiple transfo
1514 * possible ? pb ? => the type is to return a expression option ? use
1515 * some combinators to help ?
1516 * update: with the tag-SP approach, no more a problem.
1519 and arguments_bis
= fun eas ebs
->
1521 match A.unwrap ea
with
1522 A.Edots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
1524 let build_dots (mcode, optexpr
) = A.Edots
(mcode, optexpr
) in
1525 let match_comma ea
=
1526 match A.unwrap ea
with
1527 A.EComma ia1
-> Some ia1
1529 let build_comma ia1
= A.EComma ia1
in
1530 let match_metalist ea
=
1531 match A.unwrap ea
with
1532 A.MetaExprList
(ida
,leninfo
,keep
,inherited
) ->
1533 Some
(ida
,leninfo
,keep
,inherited
)
1535 let build_metalist (ida
,leninfo
,keep
,inherited
) =
1536 A.MetaExprList
(ida
,leninfo
,keep
,inherited
) in
1537 let mktermval v
= Ast_c.MetaExprListVal v
in
1538 let special_cases ea
eas ebs
= None
in
1539 list_matcher match_dots build_dots match_comma build_comma
1540 match_metalist build_metalist mktermval
1541 special_cases argument
X.distrf_args
1542 Lib_parsing_c.ii_of_args
eas ebs
1544 and argument arga argb
=
1545 X.all_bound
(A.get_inherited arga
) >&&>
1546 match A.unwrap arga
, argb
with
1548 Right
(B.ArgType
{B.p_register
=b
,iib
; p_namei
=sopt
;p_type
=tyb
}) ->
1549 if b
|| sopt
<> None
1551 (* failwith "the argument have a storage and ast_cocci does not have"*)
1554 (* b = false and sopt = None *)
1555 fullType tya tyb
>>= (fun tya tyb
->
1557 (A.TypeExp tya
) +> A.rewrap arga
,
1558 (Right
(B.ArgType
{B.p_register
=(b
,iib
);
1563 | A.TypeExp tya
, _
-> fail
1564 | _
, Right
(B.ArgType _
) -> fail
1566 expression arga argb
>>= (fun arga argb
->
1567 return (arga
, Left argb
)
1569 | _
, Right
(B.ArgAction y
) -> fail
1572 (* ------------------------------------------------------------------------- *)
1573 (* todo? facto code with argument ? *)
1574 and (parameters
: sequence
->
1575 (A.parameterTypeDef list
, Ast_c.parameterType
Ast_c.wrap2 list
)
1577 fun seqstyle eas ebs
->
1579 | Unordered
-> failwith
"not handling ooo"
1581 parameters_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1582 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1586 and parameters_bis
eas ebs
=
1588 match A.unwrap ea
with
1589 A.Pdots
(mcode) -> Some
(mcode, None
)
1591 let build_dots (mcode, _optexpr
) = A.Pdots
(mcode) in
1592 let match_comma ea
=
1593 match A.unwrap ea
with
1594 A.PComma ia1
-> Some ia1
1596 let build_comma ia1
= A.PComma ia1
in
1597 let match_metalist ea
=
1598 match A.unwrap ea
with
1599 A.MetaParamList
(ida
,leninfo
,keep
,inherited
) ->
1600 Some
(ida
,leninfo
,keep
,inherited
)
1602 let build_metalist (ida
,leninfo
,keep
,inherited
) =
1603 A.MetaParamList
(ida
,leninfo
,keep
,inherited
) in
1604 let mktermval v
= Ast_c.MetaParamListVal v
in
1605 let special_cases ea
eas ebs
=
1606 (* a case where one smpl parameter matches a list of C parameters *)
1607 match A.unwrap ea
,ebs
with
1608 A.VoidParam ta
, ys
->
1610 (match eas, ebs
with
1612 let {B.p_register
=(hasreg
,iihasreg
);
1614 p_type
=tb
; } = eb
in
1616 if idbopt
=*= None
&& not hasreg
1619 | (qub
, (B.BaseType
B.Void
,_
)) ->
1620 fullType ta tb
>>= (fun ta tb
->
1622 [(A.VoidParam ta
) +> A.rewrap ea
],
1623 [Left
{B.p_register
=(hasreg
, iihasreg
);
1631 list_matcher match_dots build_dots match_comma build_comma
1632 match_metalist build_metalist mktermval
1633 special_cases parameter
X.distrf_params
1634 Lib_parsing_c.ii_of_params
eas ebs
1637 let split_register_param = fun (hasreg, idb, ii_b_s) ->
1638 match hasreg, idb, ii_b_s with
1639 | false, Some s, [i1] -> Left (s, [], i1)
1640 | true, Some s, [i1;i2] -> Left (s, [i1], i2)
1641 | _, None, ii -> Right ii
1642 | _ -> raise Impossible
1646 and parameter
= fun parama paramb
->
1647 match A.unwrap parama
, paramb
with
1648 A.MetaParam
(ida
,keep
,inherited
), eb
->
1649 (* todo: use quaopt, hasreg ? *)
1651 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_param eb
) in
1652 X.envf keep inherited
(ida
,Ast_c.MetaParamVal eb
,max_min) (fun () ->
1653 X.distrf_param ida eb
1654 ) >>= (fun ida eb
->
1655 return (A.MetaParam
(ida
,keep
,inherited
)+> A.rewrap parama
,eb
))
1656 | A.Param
(typa
, idaopt
), eb
->
1657 let {B.p_register
= (hasreg
,iihasreg
);
1658 p_namei
= nameidbopt
;
1659 p_type
= typb
;} = paramb
in
1661 fullType typa typb
>>= (fun typa typb
->
1662 match idaopt
, nameidbopt
with
1663 | Some ida
, Some nameidb
->
1664 (* todo: if minus on ida, should also minus the iihasreg ? *)
1665 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1667 A.Param
(typa
, Some ida
)+> A.rewrap parama
,
1668 {B.p_register
= (hasreg
, iihasreg
);
1669 p_namei
= Some
(nameidb
);
1675 A.Param
(typa
, None
)+> A.rewrap parama
,
1676 {B.p_register
=(hasreg
,iihasreg
);
1680 (* why handle this case ? because of transform_proto ? we may not
1681 * have an ident in the proto.
1682 * If have some plus on ida ? do nothing about ida ?
1684 (* not anymore !!! now that julia is handling the proto.
1685 | _, Right iihasreg ->
1688 ((hasreg, None, typb), iihasreg)
1692 | Some _
, None
-> fail
1693 | None
, Some _
-> fail)
1694 | (A.OptParam _
| A.UniqueParam _
), _
->
1695 failwith
"not handling Opt/Unique for Param"
1696 | A.Pcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
1699 (* ------------------------------------------------------------------------- *)
1700 and (declaration
: (A.mcodekind * bool * A.declaration
,B.declaration
) matcher
) =
1701 fun (mckstart
, allminus
, decla
) declb
->
1702 X.all_bound
(A.get_inherited decla
) >&&>
1703 match A.unwrap decla
, declb
with
1705 (* Un MetaDecl est introduit dans l'asttoctl pour sauter au dessus
1706 * de toutes les declarations qui sont au debut d'un fonction et
1707 * commencer le reste du match au premier statement. Alors, ca matche
1708 * n'importe quelle declaration. On n'a pas besoin d'ajouter
1709 * quoi que ce soit dans l'environnement. C'est une sorte de DDots.
1711 * When the SP want to remove the whole function, the minus is not
1712 * on the MetaDecl but on the MetaRuleElem. So there should
1713 * be no transform of MetaDecl, just matching are allowed.
1716 | A.MetaDecl
(ida
,keep
,inherited
), _
->
1718 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_decl declb
) in
1719 X.envf keep inherited
(ida
, Ast_c.MetaDeclVal declb
, max_min) (fun () ->
1720 X.distrf_decl ida declb
1721 ) >>= (fun ida declb
->
1722 return ((mckstart
, allminus
,
1723 (A.MetaDecl
(ida
, keep
, inherited
))+> A.rewrap decla
),
1725 | _
, (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
)) ->
1726 onedecl allminus decla
(var
,iiptvirgb
,iisto
) >>=
1727 (fun decla
(var
,iiptvirgb
,iisto
)->
1728 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1730 (mckstart
, allminus
, decla
),
1731 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1734 | _
, (B.DeclList
(xs
, iiptvirgb
::iifakestart
::iisto
)) ->
1735 if X.mode
=*= PatternMode
1737 xs
+> List.fold_left
(fun acc var
->
1739 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1740 onedecl allminus decla
(var
, iiptvirgb
, iisto
) >>=
1741 (fun decla
(var
, iiptvirgb
, iisto
) ->
1743 (mckstart
, allminus
, decla
),
1744 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1748 failwith
"More that one variable in decl. Have to split to transform."
1750 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
), B.MacroDecl
((sb
,ebs
),ii
) ->
1751 let (iisb
, lpb
, rpb
, iiendb
, iifakestart
, iistob
) =
1753 | iisb
::lpb
::rpb
::iiendb
::iifakestart
::iisto
->
1754 (iisb
,lpb
,rpb
,iiendb
, iifakestart
,iisto
)
1755 | _
-> raise Impossible
1758 then minusize_list iistob
1759 else return ((), iistob
)
1760 ) >>= (fun () iistob
->
1762 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1763 ident DontKnow sa
(sb
, iisb
) >>= (fun sa
(sb
, iisb
) ->
1764 tokenf lpa lpb
>>= (fun lpa lpb
->
1765 tokenf rpa rpb
>>= (fun rpa rpb
->
1766 tokenf enda iiendb
>>= (fun enda iiendb
->
1767 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
1768 let eas = redots
eas easundots
in
1771 (mckstart
, allminus
,
1772 (A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
)) +> A.rewrap decla
),
1773 (B.MacroDecl
((sb
,ebs
),
1774 [iisb
;lpb
;rpb
;iiendb
;iifakestart
] ++ iistob
))
1777 | _
, (B.MacroDecl _
|B.DeclList _
) -> fail
1780 and onedecl
= fun allminus decla
(declb
, iiptvirgb
, iistob
) ->
1781 X.all_bound
(A.get_inherited decla
) >&&>
1782 match A.unwrap decla
, declb
with
1784 (* kind of typedef iso, we must unfold, it's for the case
1785 * T { }; that we want to match against typedef struct { } xx_t;
1788 | A.TyDecl
(tya0
, ptvirga
),
1789 ({B.v_namei
= Some
(nameidb
, None
);
1791 B.v_storage
= (B.StoTypedef
, inl
);
1794 B.v_type_bis
= typb0bis
;
1797 (match A.unwrap tya0
, typb0
with
1798 | A.Type
(cv1
,tya1
), ((qu
,il
),typb1
) ->
1800 (match A.unwrap tya1
, typb1
with
1801 | A.StructUnionDef
(tya2
, lba
, declsa
, rba
),
1802 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
1804 let (iisub
, iisbopt
, lbb
, rbb
) =
1807 let (iisub
, lbb
, rbb
) = tuple_of_list3 ii
in
1808 (iisub
, [], lbb
, rbb
)
1811 "warning: both a typedef (%s) and struct name introduction (%s)"
1812 (Ast_c.str_of_name nameidb
) s
1814 pr2 "warning: I will consider only the typedef";
1815 let (iisub
, iisb
, lbb
, rbb
) = tuple_of_list4 ii
in
1816 (iisub
, [iisb
], lbb
, rbb
)
1819 structdef_to_struct_name
1820 (Ast_c.nQ
, (B.StructUnion
(sub
, sbopt
, declsb
), ii
))
1823 Ast_c.nQ
,((B.TypeName
(nameidb
, Some
1824 (Lib_parsing_c.al_type
structnameb))), [])
1827 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1828 tokenf lba lbb
>>= (fun lba lbb
->
1829 tokenf rba rbb
>>= (fun rba rbb
->
1830 struct_fields
(A.undots declsa
) declsb
>>=(fun undeclsa declsb
->
1831 let declsa = redots
declsa undeclsa
in
1833 (match A.unwrap tya2
with
1834 | A.Type
(cv3
, tya3
) ->
1835 (match A.unwrap tya3
with
1836 | A.MetaType
(ida
,keep
, inherited
) ->
1838 fullType tya2
fake_typeb >>= (fun tya2
fake_typeb ->
1840 A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1 in
1841 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1844 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1845 [iisub
] @ iisbopt
@ [lbb
;rbb
] in
1846 let typb0 = ((qu
, il
), typb1) in
1848 match fake_typeb with
1849 | _nQ
, ((B.TypeName
(nameidb
, _typ
)),[]) ->
1852 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1853 (({B.v_namei
= Some
(nameidb
, None
);
1855 B.v_storage
= (B.StoTypedef
, inl
);
1858 B.v_type_bis
= typb0bis
;
1860 iivirg
),iiptvirgb
,iistob
)
1862 | _
-> raise Impossible
1865 (* do we need EnumName here too? *)
1866 | A.StructUnionName
(sua
, sa
) ->
1867 fullType tya2
structnameb >>= (fun tya2
structnameb ->
1869 let tya1 = A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1
1871 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1873 match structnameb with
1874 | _nQ
, (B.StructUnionName
(sub
, s), [iisub
;iisbopt
]) ->
1876 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1877 [iisub
;iisbopt
;lbb
;rbb
] in
1878 let typb0 = ((qu
, il
), typb1) in
1881 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1882 (({B.v_namei
= Some
(nameidb
, None
);
1884 B.v_storage
= (B.StoTypedef
, inl
);
1887 B.v_type_bis
= typb0bis
;
1889 iivirg
),iiptvirgb
,iistob
)
1891 | _
-> raise Impossible
1893 | _
-> raise Impossible
1902 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1903 ({B.v_namei
= Some
(nameidb
, _
);B.v_storage
= (B.StoTypedef
,_
);}, iivirg
)
1906 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1907 ({B.v_namei
=Some
(nameidb
, _
);B.v_storage
=(B.StoTypedef
,_
);}, iivirg
)
1912 (* could handle iso here but handled in standard.iso *)
1913 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1914 ({B.v_namei
= Some
(nameidb
, None
);
1919 B.v_type_bis
= typbbis
;
1922 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1923 fullType typa typb
>>= (fun typa typb
->
1924 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1925 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1926 (fun stoa
(stob
, iistob
) ->
1928 (A.UnInit
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
1929 (({B.v_namei
= Some
(nameidb
, None
);
1934 B.v_type_bis
= typbbis
;
1939 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1940 ({B.v_namei
= Some
(nameidb
, Some
(iieqb
, inib
));
1945 B.v_type_bis
= typbbis
;
1948 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1949 tokenf eqa iieqb
>>= (fun eqa iieqb
->
1950 fullType typa typb
>>= (fun typa typb
->
1951 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1952 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1953 (fun stoa
(stob
, iistob
) ->
1954 initialiser inia inib
>>= (fun inia inib
->
1956 (A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
)) +> A.rewrap decla
,
1957 (({B.v_namei
= Some
(nameidb
, Some
(iieqb
, inib
));
1962 B.v_type_bis
= typbbis
;
1967 (* do iso-by-absence here ? allow typedecl and var ? *)
1968 | A.TyDecl
(typa
, ptvirga
),
1969 ({B.v_namei
= None
; B.v_type
= typb
;
1973 B.v_type_bis
= typbbis
;
1976 if stob
=*= (B.NoSto
, false)
1978 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1979 fullType typa typb
>>= (fun typa typb
->
1981 (A.TyDecl
(typa
, ptvirga
)) +> A.rewrap decla
,
1982 (({B.v_namei
= None
;
1987 B.v_type_bis
= typbbis
;
1988 }, iivirg
), iiptvirgb
, iistob
)
1993 | A.Typedef
(stoa
, typa
, ida
, ptvirga
),
1994 ({B.v_namei
= Some
(nameidb
, None
);
1996 B.v_storage
= (B.StoTypedef
,inline
);
1999 B.v_type_bis
= typbbis
;
2002 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2003 fullType typa typb
>>= (fun typa typb
->
2006 tokenf stoa iitypedef
>>= (fun stoa iitypedef
->
2007 return (stoa
, [iitypedef
])
2009 | _
-> failwith
"weird, have both typedef and inline or nothing";
2010 ) >>= (fun stoa iistob
->
2011 (match A.unwrap ida
with
2012 | A.MetaType
(_
,_
,_
) ->
2015 Ast_c.nQ
, ((B.TypeName
(nameidb
, Ast_c.noTypedefDef
())), [])
2017 fullTypebis ida
fake_typeb >>= (fun ida
fake_typeb ->
2018 match fake_typeb with
2019 | _nQ
, ((B.TypeName
(nameidb
, _typ
)), []) ->
2020 return (ida
, nameidb
)
2021 | _
-> raise Impossible
2026 | B.RegularName
(sb
, iidb
) ->
2027 let iidb1 = tuple_of_list1 iidb
in
2031 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
2033 (A.TypeName sa
) +> A.rewrap ida
,
2034 B.RegularName
(sb
, [iidb1])
2038 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
2042 | _
-> raise Impossible
2044 ) >>= (fun ida nameidb
->
2046 (A.Typedef
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
2047 (({B.v_namei
= Some
(nameidb
, None
);
2049 B.v_storage
= (B.StoTypedef
,inline
);
2052 B.v_type_bis
= typbbis
;
2060 | _
, ({B.v_namei
= None
;}, _
) ->
2061 (* old: failwith "no variable in this declaration, weird" *)
2066 | A.DisjDecl declas
, declb
->
2067 declas
+> List.fold_left
(fun acc decla
->
2069 (* (declaration (mckstart, allminus, decla) declb) *)
2070 (onedecl allminus decla
(declb
,iiptvirgb
, iistob
))
2075 (* only in struct type decls *)
2076 | A.Ddots
(dots
,whencode
), _
->
2079 | A.OptDecl _
, _
| A.UniqueDecl _
, _
->
2080 failwith
"not handling Opt/Unique Decl"
2082 | _
, ({B.v_namei
=Some _
}, _
) ->
2088 (* ------------------------------------------------------------------------- *)
2090 and (initialiser
: (A.initialiser
, Ast_c.initialiser
) matcher
) = fun ia ib
->
2091 X.all_bound
(A.get_inherited ia
) >&&>
2092 match (A.unwrap ia
,ib
) with
2094 | (A.MetaInit
(ida
,keep
,inherited
), ib
) ->
2096 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_ini ib
) in
2097 X.envf keep inherited
(ida
, Ast_c.MetaInitVal ib
, max_min)
2099 X.distrf_ini ida ib
>>= (fun ida ib
->
2101 A.MetaInit
(ida
,keep
,inherited
) +> A.rewrap ia
,
2106 | (A.InitExpr expa
, ib
) ->
2107 (match A.unwrap expa
, ib
with
2108 | A.Edots
(mcode, None
), ib
->
2109 X.distrf_ini
(dots2metavar mcode) ib
>>= (fun mcode ib
->
2112 (A.Edots
(metavar2dots mcode, None
) +> A.rewrap expa
)
2117 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
2119 | _
, (B.InitExpr expb
, ii
) ->
2121 expression expa expb
>>= (fun expa expb
->
2123 (A.InitExpr expa
) +> A.rewrap ia
,
2124 (B.InitExpr expb
, ii
)
2129 | (A.ArInitList
(ia1
, ias
, ia2
), (B.InitList ibs
, ii
)) ->
2131 | ib1::ib2
::iicommaopt
->
2132 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2133 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2134 ar_initialisers
(A.undots ias
) (ibs
, iicommaopt
) >>=
2135 (fun iasundots
(ibs
,iicommaopt
) ->
2137 (A.ArInitList
(ia1
, redots ias iasundots
, ia2
)) +> A.rewrap ia
,
2138 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2141 | _
-> raise Impossible
2144 | (A.StrInitList
(allminus
, ia1
, ias
, ia2
, []), (B.InitList ibs
, ii
)) ->
2146 | ib1::ib2
::iicommaopt
->
2147 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2148 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2149 str_initialisers allminus ias
(ibs
, iicommaopt
) >>=
2150 (fun ias
(ibs
,iicommaopt
) ->
2152 (A.StrInitList
(allminus
, ia1
, ias
, ia2
, [])) +> A.rewrap ia
,
2153 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2156 | _
-> raise Impossible
2159 | (A.StrInitList
(allminus
, i1
, ias
, i2
, whencode
),
2160 (B.InitList ibs
, _ii
)) ->
2161 failwith
"TODO: not handling whencode in initialisers"
2164 | (A.InitGccExt
(designatorsa
, ia2
, inia
),
2165 (B.InitDesignators
(designatorsb
, inib
), ii2
))->
2167 let iieq = tuple_of_list1 ii2
in
2169 tokenf ia2
iieq >>= (fun ia2
iieq ->
2170 designators designatorsa designatorsb
>>=
2171 (fun designatorsa designatorsb
->
2172 initialiser inia inib
>>= (fun inia inib
->
2174 (A.InitGccExt
(designatorsa
, ia2
, inia
)) +> A.rewrap ia
,
2175 (B.InitDesignators
(designatorsb
, inib
), [iieq])
2181 | (A.InitGccName
(ida
, ia1
, inia
), (B.InitFieldOld
(idb
, inib
), ii
)) ->
2184 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2185 initialiser inia inib
>>= (fun inia inib
->
2186 tokenf ia1 iicolon
>>= (fun ia1 iicolon
->
2188 (A.InitGccName
(ida
, ia1
, inia
)) +> A.rewrap ia
,
2189 (B.InitFieldOld
(idb
, inib
), [iidb
;iicolon
])
2196 | A.IComma
(comma
), _
->
2199 | A.UniqueIni _
,_
| A.OptIni _
,_
->
2200 failwith
"not handling Opt/Unique on initialisers"
2202 | _
, (B.InitIndexOld
(_
, _
), _
) -> fail
2203 | _
, (B.InitFieldOld
(_
, _
), _
) -> fail
2205 | _
, ((B.InitDesignators
(_
, _
)|B.InitList _
|B.InitExpr _
), _
)
2208 and designators dla dlb
=
2209 match (dla
,dlb
) with
2210 ([],[]) -> return ([], [])
2211 | ([],_
) | (_
,[]) -> fail
2212 | (da
::dla
,db
::dlb
) ->
2213 designator da db
>>= (fun da db
->
2214 designators dla dlb
>>= (fun dla dlb
->
2215 return (da
::dla
, db
::dlb
)))
2217 and designator da db
=
2219 (A.DesignatorField
(ia1
, ida
), (B.DesignatorField idb
,ii1
)) ->
2221 let (iidot
, iidb
) = tuple_of_list2 ii1
in
2222 tokenf ia1 iidot
>>= (fun ia1 iidot
->
2223 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2225 A.DesignatorField
(ia1
, ida
),
2226 (B.DesignatorField idb
, [iidot
;iidb
])
2229 | (A.DesignatorIndex
(ia1
,ea
,ia2
), (B.DesignatorIndex eb
, ii1
)) ->
2231 let (ib1, ib2
) = tuple_of_list2 ii1
in
2232 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2233 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2234 expression ea eb
>>= (fun ea eb
->
2236 A.DesignatorIndex
(ia1
,ea
,ia2
),
2237 (B.DesignatorIndex eb
, [ib1;ib2
])
2240 | (A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2241 (B.DesignatorRange
(e1b
, e2b
), ii1
)) ->
2243 let (ib1, ib2
, ib3
) = tuple_of_list3 ii1
in
2244 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2245 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2246 tokenf ia3 ib3
>>= (fun ia3 ib3
->
2247 expression e1a e1b
>>= (fun e1a e1b
->
2248 expression e2a e2b
>>= (fun e2a e2b
->
2250 A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2251 (B.DesignatorRange
(e1b
, e2b
), [ib1;ib2
;ib3
])
2253 | (_
, ((B.DesignatorField _
|B.DesignatorIndex _
|B.DesignatorRange _
), _
)) ->
2256 and str_initialisers
= fun allminus ias
(ibs
, iicomma
) ->
2257 let ias_unsplit = unsplit_icomma ias
in
2258 let ibs_split = resplit_initialiser ibs iicomma
in
2260 if need_unordered_initialisers ibs
2261 then initialisers_unordered2 allminus
ias_unsplit ibs_split >>=
2262 (fun ias_unsplit ibs_split ->
2264 split_icomma ias_unsplit,
2265 unsplit_initialiser ibs_split))
2268 and ar_initialisers
= fun ias
(ibs
, iicomma
) ->
2269 (* this doesn't check need_unordered_initialisers because ... can be
2270 implemented as ordered, even if it matches unordered initializers *)
2271 let ibs = resplit_initialiser ibs iicomma
in
2274 (List.map
(function (elem
,comma
) -> [Left elem
; Right
[comma
]]) ibs) in
2275 initialisers_ordered2 ias
ibs >>=
2276 (fun ias
ibs_split ->
2278 match List.rev
ibs_split with
2279 (Right comma
)::rest
-> (Ast_c.unsplit_comma
(List.rev rest
),comma
)
2280 | (Left _
)::_
-> (Ast_c.unsplit_comma
ibs_split,[]) (* possible *)
2282 return (ias
, (ibs,iicomma
)))
2284 and initialisers_ordered2
= fun ias
ibs ->
2286 match A.unwrap ea
with
2287 A.Idots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2289 let build_dots (mcode, optexpr
) = A.Idots
(mcode, optexpr
) in
2290 let match_comma ea
=
2291 match A.unwrap ea
with
2292 A.IComma ia1
-> Some ia1
2294 let build_comma ia1
= A.IComma ia1
in
2295 let match_metalist ea
= None
in
2296 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
2297 let mktermval v
= failwith
"not possible" in
2298 let special_cases ea
eas ebs
= None
in
2299 let no_ii x
= failwith
"not possible" in
2300 list_matcher match_dots build_dots match_comma build_comma
2301 match_metalist build_metalist mktermval
2302 special_cases initialiser
X.distrf_inis
no_ii ias
ibs
2305 and initialisers_unordered2
= fun allminus ias
ibs ->
2310 let rec loop = function
2311 [] -> return ([],[])
2312 | (ib
,comma
)::ibs ->
2313 X.distrf_ini
minusizer ib
>>= (fun _ ib
->
2314 tokenf minusizer comma
>>= (fun _ comma
->
2315 loop ibs >>= (fun l
ibs ->
2316 return(l
,(ib
,comma
)::ibs)))) in
2318 else return ([], ys
)
2320 let permut = Common.uncons_permut_lazy ys
in
2321 permut +> List.fold_left
(fun acc
((e
, pos
), rest
) ->
2323 (initialiser_comma x e
2325 let rest = Lazy.force
rest in
2326 initialisers_unordered2 allminus xs
rest >>= (fun xs
rest ->
2329 Common.insert_elem_pos
(e
, pos
) rest
2333 and initialiser_comma
(x
,xcomma
) (y
, commay
) =
2334 match A.unwrap xcomma
with
2336 tokenf commax commay
>>= (fun commax commay
->
2337 initialiser x y
>>= (fun x y
->
2339 (x
, (A.IComma commax
) +> A.rewrap xcomma
),
2341 | _
-> raise Impossible
(* unsplit_iicomma wrong *)
2343 (* ------------------------------------------------------------------------- *)
2344 and (struct_fields
: (A.declaration list
, B.field list
) matcher
) =
2347 match A.unwrap ea
with
2348 A.Ddots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2350 let build_dots (mcode, optexpr
) = A.Ddots
(mcode, optexpr
) in
2351 let match_comma ea
= None
in
2352 let build_comma ia1
= failwith
"not possible" in
2353 let match_metalist ea
= None
in
2354 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
2355 let mktermval v
= failwith
"not possible" in
2356 let special_cases ea
eas ebs
= None
in
2357 let no_ii x
= failwith
"not possible" in
2358 let make_ebs ebs
= List.map
(function x
-> Left x
) ebs
in
2359 let unmake_ebs ebs
=
2360 List.map
(function Left x
-> x
| Right x
-> failwith
"no right") ebs
in
2361 let distrf mcode startxs =
2362 let startxs = unmake_ebs startxs in
2363 X.distrf_struct_fields
mcode startxs >>=
2364 (fun mcode startxs -> return (mcode,make_ebs startxs)) in
2365 list_matcher match_dots build_dots match_comma build_comma
2366 match_metalist build_metalist mktermval
2367 special_cases struct_field
distrf no_ii eas (make_ebs ebs
) >>=
2368 (fun eas ebs
-> return (eas,unmake_ebs ebs
))
2370 and (struct_field
: (A.declaration
, B.field
) matcher
) = fun fa fb
->
2372 match A.unwrap fa
,fb
with
2373 | A.MetaField
(ida
,keep
,inherited
), _
->
2375 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_field fb
) in
2376 X.envf keep inherited
(ida
, Ast_c.MetaFieldVal fb
, max_min) (fun () ->
2377 X.distrf_field ida fb
2378 ) >>= (fun ida fb
->
2379 return ((A.MetaField
(ida
, keep
, inherited
))+> A.rewrap fa
,
2381 | _
,B.DeclarationField
(B.FieldDeclList
(onefield_multivars
,iiptvirg
)) ->
2383 let iiptvirgb = tuple_of_list1 iiptvirg
in
2385 (match onefield_multivars
with
2386 | [] -> raise Impossible
2387 | [onevar
,iivirg
] ->
2388 assert (null iivirg
);
2390 | B.BitField
(sopt
, typb
, _
, expr
) ->
2391 pr2_once
"warning: bitfield not handled by ast_cocci";
2393 | B.Simple
(None
, typb
) ->
2394 pr2_once
"warning: unamed struct field not handled by ast_cocci";
2396 | B.Simple
(Some nameidb
, typb
) ->
2398 (* build a declaration from a struct field *)
2399 let allminus = false in
2401 let stob = B.NoSto
, false in
2403 ({B.v_namei
= Some
(nameidb
, None
);
2406 B.v_local
= Ast_c.NotLocalDecl
;
2407 B.v_attr
= Ast_c.noattr
;
2408 B.v_type_bis
= ref None
;
2409 (* the struct field should also get expanded ? no it's not
2410 * important here, we will rematch very soon *)
2414 onedecl
allminus fa
(fake_var,iiptvirgb,iisto) >>=
2415 (fun fa
(var
,iiptvirgb,iisto) ->
2418 | ({B.v_namei
= Some
(nameidb
, None
);
2423 let onevar = B.Simple
(Some nameidb
, typb
) in
2427 ((B.DeclarationField
2428 (B.FieldDeclList
([onevar, iivirg
], [iiptvirgb])))
2431 | _
-> raise Impossible
2436 pr2_once
"PB: More that one variable in decl. Have to split";
2439 | _
,B.EmptyField _iifield
->
2442 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
),B.MacroDeclField
((sb
,ebs
),ii
) ->
2444 | _
,B.MacroDeclField
((sb
,ebs
),ii
) -> fail
2446 | _
,B.CppDirectiveStruct directive
-> fail
2447 | _
,B.IfdefStruct directive
-> fail
2450 and enum_fields
= fun eas ebs
->
2452 match A.unwrap ea
with
2453 A.Edots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2455 let build_dots (mcode, optexpr
) = A.Edots
(mcode, optexpr
) in
2456 let match_comma ea
=
2457 match A.unwrap ea
with
2458 A.EComma ia1
-> Some ia1
2460 let build_comma ia1
= A.EComma ia1
in
2461 let match_metalist ea
= None
in
2462 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
2463 let mktermval v
= failwith
"not possible" in
2464 let special_cases ea
eas ebs
= None
in
2465 list_matcher match_dots build_dots match_comma build_comma
2466 match_metalist build_metalist mktermval
2467 special_cases enum_field
X.distrf_enum_fields
2468 Lib_parsing_c.ii_of_enum_fields
eas ebs
2470 and enum_field ida idb
=
2471 X.all_bound
(A.get_inherited ida
) >&&>
2472 match A.unwrap ida
, idb
with
2473 A.Ident
(id
),(nameidb
,None
) ->
2474 ident_cpp DontKnow id nameidb
>>= (fun id nameidb
->
2475 return ((A.Ident id
) +> A.rewrap ida
, (nameidb
,None
)))
2476 | A.Assignment
(ea1
,opa
,ea2
,init
),(nameidb
,Some
(opbi,eb2
)) ->
2477 (match A.unwrap ea1
with
2479 ident_cpp DontKnow id nameidb
>>= (fun id nameidb
->
2480 expression ea2 eb2
>>= (fun ea2 eb2
->
2481 tokenf opa
opbi >>= (fun opa
opbi -> (* only one kind of assignop *)
2483 (A.Assignment
((A.Ident
(id
))+>A.rewrap ea1
,opa
,ea2
,init
)) +>
2485 (nameidb
,Some
(opbi,eb2
))))))
2486 | _
-> failwith
"not possible")
2487 | _
-> failwith
"not possible"
2489 (* ------------------------------------------------------------------------- *)
2490 and (fullType
: (A.fullType
, Ast_c.fullType
) matcher
) =
2492 X.optional_qualifier_flag
(fun optional_qualifier
->
2493 X.all_bound
(A.get_inherited typa
) >&&>
2494 match A.unwrap typa
, typb
with
2495 | A.Type
(cv
,ty1
), ((qu
,il
),ty2
) ->
2497 if qu
.B.const
&& qu
.B.volatile
2500 ("warning: the type is both const & volatile but cocci " ^
2501 "does not handle that");
2503 (* Drop out the const/volatile part that has been matched.
2504 * This is because a SP can contain const T v; in which case
2505 * later in match_t_t when we encounter a T, we must not add in
2506 * the environment the whole type.
2511 (* "iso-by-absence" *)
2514 fullTypebis ty1
((qu
,il
), ty2
) >>= (fun ty1 fullty2
->
2516 (A.Type
(None
, ty1
)) +> A.rewrap typa
,
2520 (match optional_qualifier
, qu
.B.const
|| qu
.B.volatile
with
2521 | false, false -> do_stuff ()
2522 | false, true -> fail
2523 | true, false -> do_stuff ()
2526 then pr2_once
"USING optional_qualifier builtin isomorphism";
2532 (* todo: can be __const__ ? can be const & volatile so
2533 * should filter instead ?
2535 (match term x
, il
with
2536 | A.Const
, [i1
] when qu
.B.const
->
2538 tokenf x i1
>>= (fun x i1
->
2539 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2541 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2545 | A.Volatile
, [i1
] when qu
.B.volatile
->
2546 tokenf x i1
>>= (fun x i1
->
2547 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2549 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2557 | A.DisjType typas
, typb
->
2559 List.fold_left
(fun acc typa
-> acc
>|+|> (fullType typa typb
)) fail
2561 | A.OptType
(_
), _
| A.UniqueType
(_
), _
2562 -> failwith
"not handling Opt/Unique on type"
2567 * Why not (A.typeC, Ast_c.typeC) matcher ?
2568 * because when there is MetaType, we want that T record the whole type,
2569 * including the qualifier, and so this type (and the new_il function in
2570 * preceding function).
2573 and (fullTypebis
: (A.typeC
, Ast_c.fullType
) matcher
) =
2575 X.all_bound
(A.get_inherited ta
) >&&>
2576 match A.unwrap ta
, tb
with
2579 | A.MetaType
(ida
,keep
, inherited
), typb
->
2581 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
2582 X.envf keep inherited
(ida
, B.MetaTypeVal typb
, max_min) (fun () ->
2583 X.distrf_type ida typb
>>= (fun ida typb
->
2585 A.MetaType
(ida
,keep
, inherited
) +> A.rewrap ta
,
2589 | unwrap
, (qub
, typb
) ->
2590 typeC ta typb
>>= (fun ta typb
->
2591 return (ta
, (qub
, typb
))
2594 and simulate_signed ta basea stringsa signaopt tb baseb ii rebuilda
=
2595 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2596 * And even if in baseb we have a Signed Int, that does not mean
2597 * that ii is of length 2, cos Signed is the default, so if in signa
2598 * we have Signed explicitely ? we cant "accrocher" this mcode to
2599 * something :( So for the moment when there is signed in cocci,
2600 * we force that there is a signed in c too (done in pattern.ml).
2602 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2605 (* handle some iso on type ? (cf complex C rule for possible implicit
2607 match basea
, baseb
with
2608 | A.VoidType
, B.Void
2609 | A.FloatType
, B.FloatType
(B.CFloat
)
2610 | A.DoubleType
, B.FloatType
(B.CDouble
) ->
2611 assert (signaopt
=*= None
);
2612 let stringa = tuple_of_list1 stringsa
in
2613 let (ibaseb
) = tuple_of_list1 ii
in
2614 tokenf stringa ibaseb
>>= (fun stringa ibaseb
->
2616 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2617 (B.BaseType baseb
, [ibaseb
])
2620 | A.CharType
, B.IntType
B.CChar
when signaopt
=*= None
->
2621 let stringa = tuple_of_list1 stringsa
in
2622 let ibaseb = tuple_of_list1 ii
in
2623 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2625 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2626 (B.BaseType
(B.IntType
B.CChar
), [ibaseb])
2629 | A.CharType
,B.IntType
(B.Si
(_sign
, B.CChar2
)) when signaopt
<> None
->
2630 let stringa = tuple_of_list1 stringsa
in
2631 let ibaseb = tuple_of_list1 iibaseb
in
2632 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2633 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2635 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2636 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2639 | A.ShortType
, B.IntType
(B.Si
(_
, B.CShort
))
2640 | A.IntType
, B.IntType
(B.Si
(_
, B.CInt
))
2641 | A.LongType
, B.IntType
(B.Si
(_
, B.CLong
)) ->
2642 let stringa = tuple_of_list1 stringsa
in
2645 (* iso-by-presence ? *)
2646 (* when unsigned int in SP, allow have just unsigned in C ? *)
2647 if mcode_contain_plus (mcodekind stringa)
2651 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2653 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2654 (B.BaseType
(baseb
), iisignbopt
++ [])
2660 "warning: long int or short int not handled by ast_cocci";
2664 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2665 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2667 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2668 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2670 | _
-> raise Impossible
2675 | A.LongLongType
, B.IntType
(B.Si
(_
, B.CLongLong
)) ->
2676 let (string1a
,string2a
) = tuple_of_list2 stringsa
in
2678 [ibase1b
;ibase2b
] ->
2679 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2680 tokenf string1a ibase1b
>>= (fun base1a ibase1b
->
2681 tokenf string2a ibase2b
>>= (fun base2a ibase2b
->
2683 (rebuilda
([base1a
;base2a
], signaopt
)) +> A.rewrap ta
,
2684 (B.BaseType
(baseb
), iisignbopt
++ [ibase1b
;ibase2b
])
2686 | [] -> fail (* should something be done in this case? *)
2687 | _
-> raise Impossible
)
2690 | _
, B.FloatType
B.CLongDouble
2693 "warning: long double not handled by ast_cocci";
2696 | _
, (B.Void
|B.FloatType _
|B.IntType _
) -> fail
2698 and simulate_signed_meta ta basea signaopt tb baseb ii rebuilda
=
2699 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2700 * And even if in baseb we have a Signed Int, that does not mean
2701 * that ii is of length 2, cos Signed is the default, so if in signa
2702 * we have Signed explicitely ? we cant "accrocher" this mcode to
2703 * something :( So for the moment when there is signed in cocci,
2704 * we force that there is a signed in c too (done in pattern.ml).
2706 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2708 let match_to_type rebaseb
=
2709 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2710 let fta = A.rewrap basea
(A.Type
(None
,basea
)) in
2711 let ftb = Ast_c.nQ
,(B.BaseType
(rebaseb
), iibaseb
) in
2712 fullType
fta ftb >>= (fun fta (_
,tb
) ->
2713 (match A.unwrap
fta,tb
with
2714 A.Type
(_
,basea
), (B.BaseType baseb
, ii
) ->
2716 (rebuilda
(basea
, signaopt
)) +> A.rewrap ta
,
2717 (B.BaseType
(baseb
), iisignbopt
++ ii
)
2719 | _
-> failwith
"not possible"))) in
2721 (* handle some iso on type ? (cf complex C rule for possible implicit
2724 | B.IntType
(B.Si
(_sign
, B.CChar2
)) ->
2725 match_to_type (B.IntType
B.CChar
)
2727 | B.IntType
(B.Si
(_
, ty
)) ->
2729 | [] -> fail (* metavariable has to match something *)
2731 | _
-> match_to_type (B.IntType
(B.Si
(B.Signed
, ty
)))
2735 | (B.Void
|B.FloatType _
|B.IntType _
) -> fail
2737 and (typeC
: (A.typeC
, Ast_c.typeC
) matcher
) =
2739 match A.unwrap ta
, tb
with
2740 | A.BaseType
(basea
,stringsa
), (B.BaseType baseb
, ii
) ->
2741 simulate_signed ta basea stringsa None tb baseb ii
2742 (function (stringsa
, signaopt
) -> A.BaseType
(basea
,stringsa
))
2743 | A.SignedT
(signaopt
, Some basea
), (B.BaseType baseb
, ii
) ->
2744 (match A.unwrap basea
with
2745 A.BaseType
(basea1
,strings1
) ->
2746 simulate_signed ta basea1 strings1
(Some signaopt
) tb baseb ii
2747 (function (strings1
, Some signaopt
) ->
2750 Some
(A.rewrap basea
(A.BaseType
(basea1
,strings1
))))
2751 | _
-> failwith
"not possible")
2752 | A.MetaType
(ida
,keep
,inherited
) ->
2753 simulate_signed_meta ta basea
(Some signaopt
) tb baseb ii
2754 (function (basea
, Some signaopt
) ->
2755 A.SignedT
(signaopt
,Some basea
)
2756 | _
-> failwith
"not possible")
2757 | _
-> failwith
"not possible")
2758 | A.SignedT
(signa
,None
), (B.BaseType baseb
, ii
) ->
2759 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2760 (match iibaseb
, baseb
with
2761 | [], B.IntType
(B.Si
(_sign
, B.CInt
)) ->
2762 sign
(Some signa
) signbopt >>= (fun signaopt iisignbopt
->
2764 | None
-> raise Impossible
2767 (A.SignedT
(signa
,None
)) +> A.rewrap ta
,
2768 (B.BaseType baseb
, iisignbopt
)
2776 (* todo? iso with array *)
2777 | A.Pointer
(typa
, iamult
), (B.Pointer typb
, ii
) ->
2778 let (ibmult
) = tuple_of_list1 ii
in
2779 fullType typa typb
>>= (fun typa typb
->
2780 tokenf iamult ibmult
>>= (fun iamult ibmult
->
2782 (A.Pointer
(typa
, iamult
)) +> A.rewrap ta
,
2783 (B.Pointer typb
, [ibmult
])
2786 | A.FunctionType
(allminus,tyaopt
,lpa
,paramsa
,rpa
),
2787 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
) ->
2789 let (lpb
, rpb
) = tuple_of_list2 ii
in
2793 ("Not handling well variable length arguments func. "^
2794 "You have been warned");
2795 tokenf lpa lpb
>>= (fun lpa lpb
->
2796 tokenf rpa rpb
>>= (fun rpa rpb
->
2797 fullType_optional_allminus
allminus tyaopt tyb
>>= (fun tyaopt tyb
->
2798 parameters
(seqstyle paramsa
) (A.undots paramsa
) paramsb
>>=
2799 (fun paramsaundots paramsb
->
2800 let paramsa = redots
paramsa paramsaundots
in
2802 (A.FunctionType
(allminus,tyaopt
,lpa
,paramsa,rpa
) +> A.rewrap ta
,
2803 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), [lpb
;rpb
])
2811 | A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
),
2812 (B.ParenType t1
, ii
) ->
2813 let (lp1b
, rp1b
) = tuple_of_list2 ii
in
2814 let (qu1b
, t1b
) = t1
in
2816 | B.Pointer t2
, ii
->
2817 let (starb
) = tuple_of_list1 ii
in
2818 let (qu2b
, t2b
) = t2
in
2820 | B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
->
2821 let (lp2b
, rp2b
) = tuple_of_list2 ii
in
2826 ("Not handling well variable length arguments func. "^
2827 "You have been warned");
2829 fullType tya tyb
>>= (fun tya tyb
->
2830 tokenf lp1a lp1b
>>= (fun lp1a lp1b
->
2831 tokenf rp1a rp1b
>>= (fun rp1a rp1b
->
2832 tokenf lp2a lp2b
>>= (fun lp2a lp2b
->
2833 tokenf rp2a rp2b
>>= (fun rp2a rp2b
->
2834 tokenf stara starb
>>= (fun stara starb
->
2835 parameters
(seqstyle paramsa) (A.undots
paramsa) paramsb
>>=
2836 (fun paramsaundots paramsb
->
2837 let paramsa = redots
paramsa paramsaundots
in
2841 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))),
2846 (B.Pointer
t2, [starb
]))
2850 (A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
))
2852 (B.ParenType
t1, [lp1b
;rp1b
])
2865 (* todo: handle the iso on optionnal size specifification ? *)
2866 | A.Array
(typa
, ia1
, eaopt
, ia2
), (B.Array
(ebopt
, typb
), ii
) ->
2867 let (ib1, ib2
) = tuple_of_list2 ii
in
2868 fullType typa typb
>>= (fun typa typb
->
2869 option expression eaopt ebopt
>>= (fun eaopt ebopt
->
2870 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2871 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2873 (A.Array
(typa
, ia1
, eaopt
, ia2
)) +> A.rewrap ta
,
2874 (B.Array
(ebopt
, typb
), [ib1;ib2
])
2878 (* todo: could also match a Struct that has provided a name *)
2879 (* This is for the case where the SmPL code contains "struct x", without
2880 a definition. In this case, the name field is always present.
2881 This case is also called from the case for A.StructUnionDef when
2882 a name is present in the C code. *)
2883 | A.StructUnionName
(sua
, Some sa
), (B.StructUnionName
(sub
, sb
), ii
) ->
2884 (* sa is now an ident, not an mcode, old: ... && (term sa) =$= sb *)
2885 let (ib1, ib2
) = tuple_of_list2 ii
in
2886 if equal_structUnion (term sua
) sub
2888 ident DontKnow sa
(sb
, ib2
) >>= (fun sa
(sb
, ib2
) ->
2889 tokenf sua
ib1 >>= (fun sua
ib1 ->
2891 (A.StructUnionName
(sua
, Some sa
)) +> A.rewrap ta
,
2892 (B.StructUnionName
(sub
, sb
), [ib1;ib2
])
2897 | A.StructUnionDef
(ty
, lba
, declsa, rba
),
2898 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
2900 let (ii_sub_sb
, lbb
, rbb
) =
2902 [iisub
; lbb
; rbb
] -> (Common.Left iisub
,lbb
,rbb
)
2903 | [iisub
; iisb
; lbb
; rbb
] -> (Common.Right
(iisub
,iisb
),lbb
,rbb
)
2904 | _
-> failwith
"list of length 3 or 4 expected" in
2907 match (sbopt
,ii_sub_sb
) with
2908 (None
,Common.Left iisub
) ->
2909 (* the following doesn't reconstruct the complete SP code, just
2910 the part that matched *)
2912 match A.unwrap
s with
2914 (match A.unwrap ty
with
2915 A.StructUnionName
(sua
, None
) ->
2916 (match (term sua
, sub
) with
2918 | (A.Union
,B.Union
) -> return ((),())
2921 tokenf sua iisub
>>= (fun sua iisub
->
2924 A.StructUnionName
(sua
, None
) +> A.rewrap
ty)
2926 return (ty,[iisub
])))
2928 | A.DisjType
(disjs
) ->
2930 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
2934 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
2936 (* build a StructUnionName from a StructUnion *)
2937 let fake_su = B.nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) in
2939 fullType
ty fake_su >>= (fun ty fake_su ->
2941 | _nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) ->
2942 return (ty, [iisub
; iisb
])
2943 | _
-> raise Impossible
)
2947 >>= (fun ty ii_sub_sb
->
2949 tokenf lba lbb
>>= (fun lba lbb
->
2950 tokenf rba rbb
>>= (fun rba rbb
->
2951 struct_fields
(A.undots
declsa) declsb
>>=(fun undeclsa declsb
->
2952 let declsa = redots
declsa undeclsa
in
2955 (A.StructUnionDef
(ty, lba
, declsa, rba
)) +> A.rewrap ta
,
2956 (B.StructUnion
(sub
, sbopt
, declsb
),ii_sub_sb
@[lbb
;rbb
])
2960 (* todo? handle isomorphisms ? because Unsigned Int can be match on a
2961 * uint in the C code. But some CEs consists in renaming some types,
2962 * so we don't want apply isomorphisms every time.
2964 | A.TypeName sa
, (B.TypeName
(nameb
, typb
), noii
) ->
2968 | B.RegularName
(sb
, iidb
) ->
2969 let iidb1 = tuple_of_list1 iidb
in
2973 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
2975 (A.TypeName sa
) +> A.rewrap ta
,
2976 (B.TypeName
(B.RegularName
(sb
, [iidb1]), typb
), noii
)
2980 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
2985 | _
, (B.TypeOfExpr e
, ii
) -> fail
2986 | _
, (B.TypeOfType e
, ii
) -> fail
2988 | _
, (B.ParenType e
, ii
) -> fail (* todo ?*)
2989 | A.EnumName
(en
,Some namea
), (B.EnumName nameb
, ii
) ->
2990 let (ib1,ib2
) = tuple_of_list2 ii
in
2991 ident DontKnow namea
(nameb
, ib2
) >>= (fun namea
(nameb
, ib2
) ->
2992 tokenf en
ib1 >>= (fun en
ib1 ->
2994 (A.EnumName
(en
, Some namea
)) +> A.rewrap ta
,
2995 (B.EnumName nameb
, [ib1;ib2
])
2998 | A.EnumDef
(ty, lba
, idsa
, rba
),
2999 (B.Enum
(sbopt
, idsb
), ii
) ->
3001 let (ii_sub_sb
, lbb
, rbb
, comma_opt
) =
3003 [iisub
; lbb
; rbb
; comma_opt
] ->
3004 (Common.Left iisub
,lbb
,rbb
,comma_opt
)
3005 | [iisub
; iisb
; lbb
; rbb
; comma_opt
] ->
3006 (Common.Right
(iisub
,iisb
),lbb
,rbb
,comma_opt
)
3007 | _
-> failwith
"list of length 4 or 5 expected" in
3010 match (sbopt
,ii_sub_sb
) with
3011 (None
,Common.Left iisub
) ->
3012 (* the following doesn't reconstruct the complete SP code, just
3013 the part that matched *)
3015 match A.unwrap
s with
3017 (match A.unwrap
ty with
3018 A.EnumName
(sua
, None
) ->
3019 tokenf sua iisub
>>= (fun sua iisub
->
3021 A.Type
(None
,A.EnumName
(sua
, None
) +> A.rewrap
ty)
3023 return (ty,[iisub
]))
3025 | A.DisjType
(disjs
) ->
3027 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
3031 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
3033 (* build an EnumName from an Enum *)
3034 let fake_su = B.nQ
, (B.EnumName sb
, [iisub
;iisb
]) in
3036 fullType
ty fake_su >>= (fun ty fake_su ->
3038 | _nQ
, (B.EnumName sb
, [iisub
;iisb
]) ->
3039 return (ty, [iisub
; iisb
])
3040 | _
-> raise Impossible
)
3044 >>= (fun ty ii_sub_sb
->
3046 tokenf lba lbb
>>= (fun lba lbb
->
3047 tokenf rba rbb
>>= (fun rba rbb
->
3048 let idsb = resplit_initialiser idsb [comma_opt
] in
3052 (function (elem
,comma
) -> [Left elem
; Right
[comma
]])
3054 enum_fields
(A.undots idsa
) idsb >>= (fun unidsa
idsb ->
3055 let idsa = redots
idsa unidsa
in
3057 match List.rev
idsb with
3058 (Right comma
)::rest ->
3059 (Ast_c.unsplit_comma
(List.rev
rest),comma
)
3060 | (Left _
)::_
-> (Ast_c.unsplit_comma
idsb,[]) (* possible *)
3063 (A.EnumDef
(ty, lba
, idsa, rba
)) +> A.rewrap ta
,
3064 (B.Enum
(sbopt
, idsb),ii_sub_sb
@[lbb
;rbb
]@iicomma
)
3068 | _
, (B.Enum _
, _
) -> fail (* todo cocci ?*)
3071 ((B.TypeName _
| B.StructUnionName
(_
, _
) | B.EnumName _
|
3072 B.StructUnion
(_
, _
, _
) |
3073 B.FunctionType _
| B.Array
(_
, _
) | B.Pointer _
|
3079 (* todo: iso on sign, if not mentioned then free. tochange?
3080 * but that require to know if signed int because explicit
3081 * signed int, or because implicit signed int.
3084 and sign signa signb
=
3085 match signa
, signb
with
3086 | None
, None
-> return (None
, [])
3087 | Some signa
, Some
(signb
, ib
) ->
3088 if equal_sign (term signa
) signb
3089 then tokenf signa ib
>>= (fun signa ib
->
3090 return (Some signa
, [ib
])
3096 and minusize_list iixs
=
3097 iixs
+> List.fold_left
(fun acc ii
->
3098 acc
>>= (fun xs ys
->
3099 tokenf minusizer ii
>>= (fun minus ii
->
3100 return (minus
::xs
, ii
::ys
)
3101 ))) (return ([],[]))
3102 >>= (fun _xsminys ys
->
3103 return ((), List.rev ys
)
3106 and storage_optional_allminus
allminus stoa
(stob, iistob
) =
3107 (* "iso-by-absence" for storage, and return type. *)
3108 X.optional_storage_flag
(fun optional_storage
->
3109 match stoa
, stob with
3110 | None
, (stobis
, inline
) ->
3114 minusize_list iistob
>>= (fun () iistob
->
3115 return (None
, (stob, iistob
))
3117 else return (None
, (stob, iistob
))
3120 (match optional_storage
, stobis
with
3121 | false, B.NoSto
-> do_minus ()
3123 | true, B.NoSto
-> do_minus ()
3126 then pr2_once
"USING optional_storage builtin isomorphism";
3130 | Some x
, ((stobis
, inline
)) ->
3131 if equal_storage (term x
) stobis
3133 let rec loop acc
= function
3136 let str = B.str_of_info i1
in
3138 "static" | "extern" | "auto" | "register" ->
3139 (* not very elegant, but tokenf doesn't know what token to
3141 tokenf x i1
>>= (fun x i1
->
3142 let rebuilt = (List.rev acc
) @ i1
:: iistob
in
3143 return (Some x
, ((stobis
, inline
), rebuilt)))
3144 | _
-> loop (i1
::acc
) iistob
) in
3149 and inline_optional_allminus
allminus inla
(stob, iistob
) =
3150 (* "iso-by-absence" for storage, and return type. *)
3151 X.optional_storage_flag
(fun optional_storage
->
3152 match inla
, stob with
3153 | None
, (stobis
, inline
) ->
3157 minusize_list iistob
>>= (fun () iistob
->
3158 return (None
, (stob, iistob
))
3160 else return (None
, (stob, iistob
))
3169 then pr2_once
"USING optional_storage builtin isomorphism";
3172 else fail (* inline not in SP and present in C code *)
3175 | Some x
, ((stobis
, inline
)) ->
3178 let rec loop acc
= function
3181 let str = B.str_of_info i1
in
3184 (* not very elegant, but tokenf doesn't know what token to
3186 tokenf x i1
>>= (fun x i1
->
3187 let rebuilt = (List.rev acc
) @ i1
:: iistob
in
3188 return (Some x
, ((stobis
, inline
), rebuilt)))
3189 | _
-> loop (i1
::acc
) iistob
) in
3191 else fail (* SP has inline, but the C code does not *)
3194 and fullType_optional_allminus
allminus tya retb
=
3199 X.distrf_type
minusizer retb
>>= (fun _x retb
->
3203 else return (None
, retb
)
3205 fullType tya retb
>>= (fun tya retb
->
3206 return (Some tya
, retb
)
3211 (*---------------------------------------------------------------------------*)
3213 and compatible_base_type a signa b
=
3214 let ok = return ((),()) in
3217 | Type_cocci.VoidType
, B.Void
->
3218 assert (signa
=*= None
);
3220 | Type_cocci.CharType
, B.IntType
B.CChar
when signa
=*= None
->
3222 | Type_cocci.CharType
, B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3223 compatible_sign signa signb
3224 | Type_cocci.ShortType
, B.IntType
(B.Si
(signb
, B.CShort
)) ->
3225 compatible_sign signa signb
3226 | Type_cocci.IntType
, B.IntType
(B.Si
(signb
, B.CInt
)) ->
3227 compatible_sign signa signb
3228 | Type_cocci.LongType
, B.IntType
(B.Si
(signb
, B.CLong
)) ->
3229 compatible_sign signa signb
3230 | _
, B.IntType
(B.Si
(signb
, B.CLongLong
)) ->
3231 pr2_once
"no longlong in cocci";
3233 | Type_cocci.FloatType
, B.FloatType
B.CFloat
->
3234 assert (signa
=*= None
);
3236 | Type_cocci.DoubleType
, B.FloatType
B.CDouble
->
3237 assert (signa
=*= None
);
3239 | _
, B.FloatType
B.CLongDouble
->
3240 pr2_once
"no longdouble in cocci";
3242 | Type_cocci.BoolType
, _
-> failwith
"no booltype in C"
3244 | _
, (B.Void
|B.FloatType _
|B.IntType _
) -> fail
3246 and compatible_base_type_meta a signa qua b ii
local =
3248 | Type_cocci.MetaType
(ida
,keep
,inherited
),
3249 B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3250 compatible_sign signa signb
>>= fun _ _
->
3251 let newb = ((qua
, (B.BaseType
(B.IntType
B.CChar
),ii
)),local) in
3252 compatible_type a
newb
3253 | Type_cocci.MetaType
(ida
,keep
,inherited
), B.IntType
(B.Si
(signb
, ty)) ->
3254 compatible_sign signa signb
>>= fun _ _
->
3256 ((qua
, (B.BaseType
(B.IntType
(B.Si
(B.Signed
, ty))),ii
)),local) in
3257 compatible_type a
newb
3258 | _
, B.FloatType
B.CLongDouble
->
3259 pr2_once
"no longdouble in cocci";
3262 | _
, (B.Void
|B.FloatType _
|B.IntType _
) -> fail
3265 and compatible_type a
(b
,local) =
3266 let ok = return ((),()) in
3268 let rec loop = function
3269 | Type_cocci.BaseType a
, (qua
, (B.BaseType b
,ii
)) ->
3270 compatible_base_type a None b
3272 | Type_cocci.SignedT
(signa
,None
), (qua
, (B.BaseType b
,ii
)) ->
3273 compatible_base_type
Type_cocci.IntType
(Some signa
) b
3275 | Type_cocci.SignedT
(signa
,Some
ty), (qua
, (B.BaseType b
,ii
)) ->
3277 Type_cocci.BaseType
ty ->
3278 compatible_base_type
ty (Some signa
) b
3279 | Type_cocci.MetaType
(ida
,keep
,inherited
) ->
3280 compatible_base_type_meta
ty (Some signa
) qua b ii
local
3281 | _
-> failwith
"not possible")
3283 | Type_cocci.Pointer a
, (qub
, (B.Pointer b
, ii
)) ->
3285 | Type_cocci.FunctionPointer a
, _
->
3287 "TODO: function pointer type doesn't store enough information to determine compatability"
3288 | Type_cocci.Array a
, (qub
, (B.Array
(eopt
, b
),ii
)) ->
3289 (* no size info for cocci *)
3291 | Type_cocci.StructUnionName
(sua
, name
),
3292 (qub
, (B.StructUnionName
(sub
, sb
),ii
)) ->
3293 if equal_structUnion_type_cocci sua sub
3294 then structure_type_name name sb ii
3296 | Type_cocci.EnumName
(name
),
3297 (qub
, (B.EnumName
(sb
),ii
)) -> structure_type_name name sb ii
3298 | Type_cocci.TypeName sa
, (qub
, (B.TypeName
(namesb
, _typb
),noii
)) ->
3299 let sb = Ast_c.str_of_name namesb
in
3304 | Type_cocci.ConstVol
(qua
, a
), (qub
, b
) ->
3305 if (fst qub
).B.const
&& (fst qub
).B.volatile
3308 pr2_once
("warning: the type is both const & volatile but cocci " ^
3309 "does not handle that");
3315 | Type_cocci.Const
-> (fst qub
).B.const
3316 | Type_cocci.Volatile
-> (fst qub
).B.volatile
3318 then loop (a
,(Ast_c.nQ
, b
))
3321 | Type_cocci.MetaType
(ida
,keep
,inherited
), typb
->
3323 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
3324 X.envf keep inherited
(A.make_mcode ida
, B.MetaTypeVal typb
, max_min)
3328 (* subtil: must be after the MetaType case *)
3329 | a
, (qub
, (B.TypeName
(_namesb
, Some b
), noii
)) ->
3330 (* kind of typedef iso *)
3333 (* for metavariables of type expression *^* *)
3334 | Type_cocci.Unknown
, _
-> ok
3339 B.TypeOfType _
|B.TypeOfExpr _
|B.ParenType _
|
3340 B.EnumName _
|B.StructUnion
(_
, _
, _
)|B.Enum
(_
, _
)
3347 B.StructUnionName
(_
, _
)|
3349 B.Array
(_
, _
)|B.Pointer _
|B.TypeName _
|
3354 and structure_type_name nm
sb ii
=
3356 Type_cocci.NoName
-> ok
3357 | Type_cocci.Name sa
->
3361 | Type_cocci.MV
(ida
,keep
,inherited
) ->
3362 (* degenerate version of MetaId, no transformation possible *)
3363 let (ib1, ib2
) = tuple_of_list2 ii
in
3364 let max_min _
= Lib_parsing_c.lin_col_by_pos
[ib2
] in
3365 let mida = A.make_mcode ida
in
3366 X.envf keep inherited
(mida, B.MetaIdVal
(sb,[]), max_min)
3372 and compatible_sign signa signb
=
3373 let ok = return ((),()) in
3374 match signa
, signb
with
3376 | Some
Type_cocci.Signed
, B.Signed
3377 | Some
Type_cocci.Unsigned
, B.UnSigned
3382 and equal_structUnion_type_cocci a b
=
3384 | Type_cocci.Struct
, B.Struct
-> true
3385 | Type_cocci.Union
, B.Union
-> true
3386 | _
, (B.Struct
| B.Union
) -> false
3390 (*---------------------------------------------------------------------------*)
3391 and inc_file
(a
, before_after
) (b
, h_rel_pos
) =
3393 let rec aux_inc (ass
, bss
) passed
=
3397 let passed = List.rev
passed in
3399 (match before_after
, !h_rel_pos
with
3400 | IncludeNothing
, _
-> true
3401 | IncludeMcodeBefore
, Some x
->
3402 List.mem
passed (x
.Ast_c.first_of
)
3404 | IncludeMcodeAfter
, Some x
->
3405 List.mem
passed (x
.Ast_c.last_of
)
3407 (* no info, maybe cos of a #include <xx.h> that was already in a .h *)
3411 | (A.IncPath x
)::xs
, y
::ys
-> x
=$
= y
&& aux_inc (xs
, ys
) (x
::passed)
3412 | _
-> failwith
"IncDots not in last place or other pb"
3417 | A.Local ass
, B.Local bss
->
3418 aux_inc (ass
, bss
) []
3419 | A.NonLocal ass
, B.NonLocal bss
->
3420 aux_inc (ass
, bss
) []
3425 (*---------------------------------------------------------------------------*)
3427 and (define_params
: sequence
->
3428 (A.define_param list
, (string B.wrap
) B.wrap2 list
) matcher
) =
3429 fun seqstyle eas ebs
->
3431 | Unordered
-> failwith
"not handling ooo"
3433 define_paramsbis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
3434 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
3437 (* todo? facto code with argument and parameters ? *)
3438 and define_paramsbis
= fun eas ebs
->
3440 match A.unwrap ea
with
3441 A.DPdots
(mcode) -> Some
(mcode, None
)
3443 let build_dots (mcode, _optexpr
) = A.DPdots
(mcode) in
3444 let match_comma ea
=
3445 match A.unwrap ea
with
3446 A.DPComma ia1
-> Some ia1
3448 let build_comma ia1
= A.DPComma ia1
in
3449 let match_metalist ea
= None
in
3450 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
3451 let mktermval v
= failwith
"not possible" in
3452 let special_cases ea
eas ebs
= None
in
3453 let no_ii x
= failwith
"not possible" in
3454 list_matcher match_dots build_dots match_comma build_comma
3455 match_metalist build_metalist mktermval
3456 special_cases define_parameter
X.distrf_define_params
no_ii eas ebs
3458 and define_parameter
= fun parama paramb
->
3459 match A.unwrap parama
, paramb
with
3460 A.DParam ida
, (idb
, ii
) ->
3461 let ib1 = tuple_of_list1 ii
in
3462 ident DontKnow ida
(idb
, ib1) >>= (fun ida
(idb
, ib1) ->
3463 return ((A.DParam ida
)+> A.rewrap parama
,(idb
, [ib1])))
3464 | (A.OptDParam _
| A.UniqueDParam _
), _
->
3465 failwith
"handling Opt/Unique for define parameters"
3466 | A.DPcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
3469 (*****************************************************************************)
3471 (*****************************************************************************)
3473 (* no global solution for positions here, because for a statement metavariable
3474 we want a MetaStmtVal, and for the others, it's not clear what we want *)
3476 let rec (rule_elem_node
: (A.rule_elem
, Control_flow_c.node
) matcher
) =
3479 x
>>= (fun a b
-> return (A.rewrap re a
, F.rewrap node b
))
3481 X.all_bound
(A.get_inherited re
) >&&>
3484 match A.unwrap re
, F.unwrap node
with
3486 (* note: the order of the clauses is important. *)
3488 | _
, F.Enter
| _
, F.Exit
| _
, F.ErrorExit
-> fail2()
3490 (* the metaRuleElem contains just '-' information. We dont need to add
3491 * stuff in the environment. If we need stuff in environment, because
3492 * there is a + S somewhere, then this will be done via MetaStmt, not
3494 * Can match TrueNode/FalseNode/... so must be placed before those cases.
3497 | A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
->
3498 let default = A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
in
3499 (match unwrap_node
with
3501 | F.TrueNode
| F.FalseNode
| F.AfterNode
3502 | F.LoopFallThroughNode
| F.FallThroughNode
3504 if X.mode
=*= PatternMode
3507 if mcode_contain_plus (mcodekind mcode)
3508 then failwith
"try add stuff on fake node"
3509 (* minusize or contextize a fake node is ok *)
3512 | F.EndStatement None
->
3513 if X.mode
=*= PatternMode
then return default
3515 (* DEAD CODE NOW ? only useful in -no_cocci_vs_c_3 ?
3516 if mcode_contain_plus (mcodekind mcode)
3518 let fake_info = Ast_c.fakeInfo() in
3519 distrf distrf_node (mcodekind mcode)
3520 (F.EndStatement (Some fake_info))
3521 else return unwrap_node
3525 | F.EndStatement
(Some i1
) ->
3526 tokenf mcode i1
>>= (fun mcode i1
->
3528 A.MetaRuleElem
(mcode,keep
, inherited
),
3529 F.EndStatement
(Some i1
)
3533 if X.mode
=*= PatternMode
then return default
3534 else failwith
"a MetaRuleElem can't transform a headfunc"
3536 if X.mode
=*= PatternMode
then return default
3538 X.distrf_node
(generalize_mcode mcode) node
>>= (fun mcode node
->
3540 A.MetaRuleElem
(mcode,keep
, inherited
),
3546 (* rene cant have found that a state containing a fake/exit/... should be
3548 * TODO: and F.Fake ?
3550 | _
, F.EndStatement _
| _
, F.CaseNode _
3551 | _
, F.TrueNode
| _
, F.FalseNode
| _
, F.AfterNode
3552 | _
, F.FallThroughNode
| _
, F.LoopFallThroughNode
3556 (* really ? diff between pattern.ml and transformation.ml *)
3557 | _
, F.Fake
-> fail2()
3560 (* cas general: a Meta can match everything. It matches only
3561 * "header"-statement. We transform only MetaRuleElem, not MetaStmt.
3562 * So can't have been called in transform.
3564 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), F.Decl
(_
) -> fail
3566 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), unwrap_node
->
3567 (* todo: should not happen in transform mode *)
3569 (match Control_flow_c.extract_fullstatement node
with
3572 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_stmt stb
) in
3573 X.envf keep inherited
(ida
, Ast_c.MetaStmtVal stb
, max_min)
3575 (* no need tag ida, we can't be called in transform-mode *)
3577 A.MetaStmt
(ida
, keep
, metainfoMaybeTodo
, inherited
),
3585 | A.MetaStmtList _
, _
->
3586 failwith
"not handling MetaStmtList"
3588 | A.TopExp ea
, F.DefineExpr eb
->
3589 expression ea eb
>>= (fun ea eb
->
3595 | A.TopExp ea
, F.DefineType eb
->
3596 (match A.unwrap ea
with
3598 fullType ft eb
>>= (fun ft eb
->
3600 A.TopExp
(A.rewrap ea
(A.TypeExp
(ft
))),
3607 (* It is important to put this case before the one that fails because
3608 * of the lack of the counter part of a C construct in SmPL (for instance
3609 * there is not yet a CaseRange in SmPL). Even if SmPL don't handle
3610 * yet certain constructs, those constructs may contain expression
3611 * that we still want and can transform.
3614 | A.Exp exp
, nodeb
->
3616 (* kind of iso, initialisation vs affectation *)
3618 match A.unwrap exp
, nodeb
with
3619 | A.Assignment
(ea
, op
, eb
, true), F.Decl decl
->
3620 initialisation_to_affectation decl
+> F.rewrap node
3625 (* Now keep fullstatement inside the control flow node,
3626 * so that can then get in a MetaStmtVar the fullstatement to later
3627 * pp back when the S is in a +. But that means that
3628 * Exp will match an Ifnode even if there is no such exp
3629 * inside the condition of the Ifnode (because the exp may
3630 * be deeper, in the then branch). So have to not visit
3631 * all inside a node anymore.
3633 * update: j'ai choisi d'accrocher au noeud du CFG Ã la
3634 * fois le fullstatement et le partialstatement et appeler le
3635 * visiteur que sur le partialstatement.
3638 match Ast_cocci.get_pos re
with
3639 | None
-> expression
3643 Lib_parsing_c.max_min_by_pos
(Lib_parsing_c.ii_of_expr eb
) in
3644 let keep = Type_cocci.Unitary
in
3645 let inherited = false in
3646 let max_min _
= failwith
"no pos" in
3647 X.envf
keep inherited (pos
, B.MetaPosVal
(min
,max
), max_min)
3653 X.cocciExp
expfn exp
node >>= (fun exp
node ->
3661 X.cocciTy fullType
ty node >>= (fun ty node ->
3668 | A.TopInit init
, nodeb
->
3669 X.cocciInit initialiser init
node >>= (fun init
node ->
3677 | A.FunHeader
(mckstart
, allminus, fninfoa
, ida
, oparen
, paramsa, cparen
),
3678 F.FunHeader
({B.f_name
= nameidb
;
3679 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3683 f_old_c_style
= oldstyle
;
3688 then pr2 "OLD STYLE DECL NOT WELL SUPPORTED";
3691 (* fninfoa records the order in which the SP specified the various
3692 information, but this isn't taken into account in the matching.
3693 Could this be a problem for transformation? *)
3696 List.filter
(function A.FStorage
(s) -> true | _
-> false) fninfoa
3697 with [A.FStorage
(s)] -> Some
s | _
-> None
in
3699 match List.filter
(function A.FType
(s) -> true | _
-> false) fninfoa
3700 with [A.FType
(t
)] -> Some t
| _
-> None
in
3703 match List.filter
(function A.FInline
(i
) -> true | _
-> false) fninfoa
3704 with [A.FInline
(i
)] -> Some i
| _
-> None
in
3706 (match List.filter
(function A.FAttr
(a
) -> true | _
-> false) fninfoa
3707 with [A.FAttr
(a
)] -> failwith
"not checking attributes" | _
-> ());
3710 | ioparenb
::icparenb
::iifakestart
::iistob
->
3712 (* maybe important to put ident as the first tokens to transform.
3713 * It's related to transform_proto. So don't change order
3716 ident_cpp LocalFunction ida nameidb
>>= (fun ida nameidb
->
3717 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
3718 tokenf oparen ioparenb
>>= (fun oparen ioparenb
->
3719 tokenf cparen icparenb
>>= (fun cparen icparenb
->
3720 parameters
(seqstyle paramsa)
3721 (A.undots
paramsa) paramsb
>>=
3722 (fun paramsaundots paramsb
->
3723 let paramsa = redots
paramsa paramsaundots
in
3724 inline_optional_allminus
allminus
3725 inla (stob, iistob
) >>= (fun inla (stob, iistob
) ->
3726 storage_optional_allminus
allminus
3727 stoa (stob, iistob
) >>= (fun stoa (stob, iistob
) ->
3732 ("Not handling well variable length arguments func. "^
3733 "You have been warned");
3735 then minusize_list iidotsb
3736 else return ((),iidotsb
)
3737 ) >>= (fun () iidotsb
->
3739 fullType_optional_allminus
allminus tya retb
>>= (fun tya retb
->
3742 (match stoa with Some st
-> [A.FStorage st
] | None
-> []) ++
3743 (match inla with Some i
-> [A.FInline i
] | None
-> []) ++
3744 (match tya with Some t
-> [A.FType t
] | None
-> [])
3749 A.FunHeader
(mckstart
,allminus,fninfoa,ida
,oparen
,
3751 F.FunHeader
({B.f_name
= nameidb
;
3752 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3756 f_old_c_style
= oldstyle
; (* TODO *)
3758 ioparenb
::icparenb
::iifakestart
::iistob
)
3761 | _
-> raise Impossible
3769 | A.Decl
(mckstart
,allminus,decla
), F.Decl declb
->
3770 declaration
(mckstart
,allminus,decla
) declb
>>=
3771 (fun (mckstart
,allminus,decla
) declb
->
3773 A.Decl
(mckstart
,allminus,decla
),
3778 | A.SeqStart
mcode, F.SeqStart
(st
, level
, i1
) ->
3779 tokenf mcode i1
>>= (fun mcode i1
->
3782 F.SeqStart
(st
, level
, i1
)
3785 | A.SeqEnd
mcode, F.SeqEnd
(level
, i1
) ->
3786 tokenf mcode i1
>>= (fun mcode i1
->
3789 F.SeqEnd
(level
, i1
)
3792 | A.ExprStatement
(ea
, ia1
), F.ExprStatement
(st
, (Some eb
, ii
)) ->
3793 let ib1 = tuple_of_list1 ii
in
3794 expression ea eb
>>= (fun ea eb
->
3795 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3797 A.ExprStatement
(ea
, ia1
),
3798 F.ExprStatement
(st
, (Some eb
, [ib1]))
3803 | A.IfHeader
(ia1
,ia2
, ea
, ia3
), F.IfHeader
(st
, (eb
,ii
)) ->
3804 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3805 expression ea eb
>>= (fun ea eb
->
3806 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3807 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3808 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3810 A.IfHeader
(ia1
, ia2
, ea
, ia3
),
3811 F.IfHeader
(st
, (eb
,[ib1;ib2
;ib3
]))
3814 | A.Else ia
, F.Else ib
->
3815 tokenf ia ib
>>= (fun ia ib
->
3816 return (A.Else ia
, F.Else ib
)
3819 | A.WhileHeader
(ia1
, ia2
, ea
, ia3
), F.WhileHeader
(st
, (eb
, ii
)) ->
3820 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3821 expression ea eb
>>= (fun ea eb
->
3822 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3823 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3824 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3826 A.WhileHeader
(ia1
, ia2
, ea
, ia3
),
3827 F.WhileHeader
(st
, (eb
, [ib1;ib2
;ib3
]))
3830 | A.DoHeader ia
, F.DoHeader
(st
, ib
) ->
3831 tokenf ia ib
>>= (fun ia ib
->
3836 | A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
), F.DoWhileTail
(eb
, ii
) ->
3837 let (ib1, ib2
, ib3
, ib4
) = tuple_of_list4 ii
in
3838 expression ea eb
>>= (fun ea eb
->
3839 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3840 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3841 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3842 tokenf ia4 ib4
>>= (fun ia4 ib4
->
3844 A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
),
3845 F.DoWhileTail
(eb
, [ib1;ib2
;ib3
;ib4
])
3847 | A.IteratorHeader
(ia1
, ia2
, eas, ia3
), F.MacroIterHeader
(st
, ((s,ebs
),ii
))
3849 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3851 ident DontKnow ia1
(s, ib1) >>= (fun ia1
(s, ib1) ->
3852 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3853 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3854 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
3855 let eas = redots
eas easundots
in
3857 A.IteratorHeader
(ia1
, ia2
, eas, ia3
),
3858 F.MacroIterHeader
(st
, ((s,ebs
), [ib1;ib2
;ib3
]))
3863 | A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3864 F.ForHeader
(st
, (((eb1opt
,ib3s
), (eb2opt
,ib4s
), (eb3opt
,ib4vide
)), ii
))
3866 assert (null ib4vide
);
3867 let (ib1, ib2
, ib5
) = tuple_of_list3 ii
in
3868 let ib3 = tuple_of_list1 ib3s
in
3869 let ib4 = tuple_of_list1 ib4s
in
3871 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3872 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3873 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3874 tokenf ia4
ib4 >>= (fun ia4
ib4 ->
3875 tokenf ia5 ib5
>>= (fun ia5 ib5
->
3876 option expression ea1opt eb1opt
>>= (fun ea1opt eb1opt
->
3877 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
3878 option expression ea3opt eb3opt
>>= (fun ea3opt eb3opt
->
3880 A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3881 F.ForHeader
(st
, (((eb1opt
,[ib3]), (eb2opt
,[ib4]), (eb3opt
,[])),
3887 | A.SwitchHeader
(ia1
,ia2
,ea
,ia3
), F.SwitchHeader
(st
, (eb
,ii
)) ->
3888 let (ib1, ib2
, ib3) = tuple_of_list3 ii
in
3889 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3890 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3891 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3892 expression ea eb
>>= (fun ea eb
->
3894 A.SwitchHeader
(ia1
,ia2
,ea
,ia3
),
3895 F.SwitchHeader
(st
, (eb
,[ib1;ib2
;ib3]))
3898 | A.Break
(ia1
, ia2
), F.Break
(st
, ((),ii
)) ->
3899 let (ib1, ib2
) = tuple_of_list2 ii
in
3900 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3901 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3904 F.Break
(st
, ((),[ib1;ib2
]))
3907 | A.Continue
(ia1
, ia2
), F.Continue
(st
, ((),ii
)) ->
3908 let (ib1, ib2
) = tuple_of_list2 ii
in
3909 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3910 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3912 A.Continue
(ia1
, ia2
),
3913 F.Continue
(st
, ((),[ib1;ib2
]))
3916 | A.Return
(ia1
, ia2
), F.Return
(st
, ((),ii
)) ->
3917 let (ib1, ib2
) = tuple_of_list2 ii
in
3918 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3919 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3921 A.Return
(ia1
, ia2
),
3922 F.Return
(st
, ((),[ib1;ib2
]))
3925 | A.ReturnExpr
(ia1
, ea
, ia2
), F.ReturnExpr
(st
, (eb
, ii
)) ->
3926 let (ib1, ib2
) = tuple_of_list2 ii
in
3927 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3928 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3929 expression ea eb
>>= (fun ea eb
->
3931 A.ReturnExpr
(ia1
, ea
, ia2
),
3932 F.ReturnExpr
(st
, (eb
, [ib1;ib2
]))
3937 | A.Include
(incla
,filea
),
3938 F.Include
{B.i_include
= (fileb
, ii
);
3939 B.i_rel_pos
= h_rel_pos
;
3940 B.i_is_in_ifdef
= inifdef
;
3943 assert (copt
=*= None
);
3945 let include_requirment =
3946 match mcodekind incla
, mcodekind filea
with
3947 | A.CONTEXT
(_
, A.BEFORE _
), _
->
3949 | _
, A.CONTEXT
(_
, A.AFTER _
) ->
3955 let (inclb
, iifileb
) = tuple_of_list2 ii
in
3956 if inc_file
(term filea
, include_requirment) (fileb
, h_rel_pos
)
3958 tokenf incla inclb
>>= (fun incla inclb
->
3959 tokenf filea iifileb
>>= (fun filea iifileb
->
3961 A.Include
(incla
, filea
),
3962 F.Include
{B.i_include
= (fileb
, [inclb
;iifileb
]);
3963 B.i_rel_pos
= h_rel_pos
;
3964 B.i_is_in_ifdef
= inifdef
;
3972 | A.DefineHeader
(definea
,ida
,params
), F.DefineHeader
((idb
, ii
), defkind
) ->
3973 let (defineb
, iidb
, ieol
) = tuple_of_list3 ii
in
3974 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
3975 tokenf definea defineb
>>= (fun definea defineb
->
3976 (match A.unwrap params
, defkind
with
3977 | A.NoParams
, B.DefineVar
->
3979 A.NoParams
+> A.rewrap params
,
3982 | A.DParams
(lpa
,eas,rpa
), (B.DefineFunc
(ebs
, ii
)) ->
3983 let (lpb
, rpb
) = tuple_of_list2 ii
in
3984 tokenf lpa lpb
>>= (fun lpa lpb
->
3985 tokenf rpa rpb
>>= (fun rpa rpb
->
3987 define_params
(seqstyle eas) (A.undots
eas) ebs
>>=
3988 (fun easundots ebs
->
3989 let eas = redots
eas easundots
in
3991 A.DParams
(lpa
,eas,rpa
) +> A.rewrap params
,
3992 B.DefineFunc
(ebs
,[lpb
;rpb
])
3996 ) >>= (fun params defkind
->
3998 A.DefineHeader
(definea
, ida
, params
),
3999 F.DefineHeader
((idb
,[defineb
;iidb
;ieol
]),defkind
)
4004 | A.Default
(def
,colon
), F.Default
(st
, ((),ii
)) ->
4005 let (ib1, ib2
) = tuple_of_list2 ii
in
4006 tokenf def
ib1 >>= (fun def
ib1 ->
4007 tokenf colon ib2
>>= (fun colon ib2
->
4009 A.Default
(def
,colon
),
4010 F.Default
(st
, ((),[ib1;ib2
]))
4015 | A.Case
(case
,ea
,colon
), F.Case
(st
, (eb
,ii
)) ->
4016 let (ib1, ib2
) = tuple_of_list2 ii
in
4017 tokenf case
ib1 >>= (fun case
ib1 ->
4018 expression ea eb
>>= (fun ea eb
->
4019 tokenf colon ib2
>>= (fun colon ib2
->
4021 A.Case
(case
,ea
,colon
),
4022 F.Case
(st
, (eb
,[ib1;ib2
]))
4025 (* only occurs in the predicates generated by asttomember *)
4026 | A.DisjRuleElem
eas, _
->
4028 List.fold_left
(fun acc ea
-> acc
>|+|> (rule_elem_node ea
node)) fail)
4029 >>= (fun ea eb
-> return (A.unwrap ea
,F.unwrap eb
))
4031 | _
, F.ExprStatement
(_
, (None
, ii
)) -> fail (* happen ? *)
4033 | A.Label
(id
,dd
), F.Label
(st
, nameb
, ((),ii
)) ->
4034 let (ib2
) = tuple_of_list1 ii
in
4035 ident_cpp DontKnow id nameb
>>= (fun ida nameb
->
4036 tokenf dd ib2
>>= (fun dd ib2
->
4039 F.Label
(st
,nameb
, ((),[ib2
]))
4042 | A.Goto
(goto
,id
,sem
), F.Goto
(st
,nameb
, ((),ii
)) ->
4043 let (ib1,ib3) = tuple_of_list2 ii
in
4044 tokenf goto
ib1 >>= (fun goto
ib1 ->
4045 ident_cpp DontKnow id nameb
>>= (fun id nameb
->
4046 tokenf sem
ib3 >>= (fun sem
ib3 ->
4048 A.Goto
(goto
,id
,sem
),
4049 F.Goto
(st
,nameb
, ((),[ib1;ib3]))
4052 (* have not a counter part in coccinelle, for the moment *)
4053 (* todo?: print a warning at least ? *)
4059 | _
, (F.IfdefEndif _
|F.IfdefElse _
|F.IfdefHeader _
)
4063 (F.MacroStmt
(_
, _
)| F.DefineDoWhileZeroHeader _
| F.EndNode
|F.TopNode
)
4066 (F.Label
(_
, _
, _
)|F.Break
(_
, _
)|F.Continue
(_
, _
)|F.Default
(_
, _
)|
4067 F.Case
(_
, _
)|F.Include _
|F.Goto _
|F.ExprStatement _
|
4068 F.DefineType _
|F.DefineExpr _
|F.DefineTodo
|
4069 F.DefineHeader
(_
, _
)|F.ReturnExpr
(_
, _
)|F.Return
(_
, _
)|F.MacroIterHeader
(_
, _
)|
4070 F.SwitchHeader
(_
, _
)|F.ForHeader
(_
, _
)|F.DoWhileTail _
|F.DoHeader
(_
, _
)|
4071 F.WhileHeader
(_
, _
)|F.Else _
|F.IfHeader
(_
, _
)|
4072 F.SeqEnd
(_
, _
)|F.SeqStart
(_
, _
, _
)|
4073 F.Decl _
|F.FunHeader _
)