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
436 | B.SizeType
, ["size_t",i1
] -> None
, [i1
]
437 | B.SSizeType
, ["ssize_t",i1
] -> None
, [i1
]
438 | B.PtrDiffType
, ["ptrdiff_t",i1
] -> None
, [i1
]
440 | _
-> failwith
("strange type2, maybe because of weird order: "^
441 (String.concat
" " (List.map fst
iis)))
443 (*---------------------------------------------------------------------------*)
445 let rec unsplit_icomma xs
=
449 (match A.unwrap y
with
451 (x
, y
)::unsplit_icomma xs
452 | _
-> failwith
"wrong ast_cocci in initializer"
455 failwith
("wrong ast_cocci in initializer, should have pair " ^
460 let resplit_initialiser ibs iicomma
=
461 match iicomma
, ibs
with
464 failwith
"should have a iicomma, do you generate fakeInfo in parser?"
466 failwith
"shouldn't have a iicomma"
467 | [iicomma
], x
::xs
->
468 let elems = List.map fst
(x
::xs
) in
469 let commas = List.map snd
(x
::xs
) +> List.flatten
in
470 let commas = commas @ [iicomma
] in
472 | _
-> raise Impossible
476 let rec split_icomma xs
=
479 | (x
,y
)::xs
-> x
::y
::split_icomma xs
481 let rec unsplit_initialiser ibs_unsplit
=
482 match ibs_unsplit
with
483 | [] -> [], [] (* empty iicomma *)
485 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
486 (x
, [])::xs
, lastcomma
488 and unsplit_initialiser_bis comma_before
= function
489 | [] -> [], [comma_before
]
491 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
492 (x
, [comma_before
])::xs
, lastcomma
497 (*---------------------------------------------------------------------------*)
498 (* coupling: same in type_annotater_c.ml *)
499 let structdef_to_struct_name ty
=
501 | qu
, (B.StructUnion
(su
, sopt
, fields
), iis) ->
503 | Some s
, [i1
;i2
;i3
;i4
] ->
504 qu
, (B.StructUnionName
(su
, s
), [i1
;i2
])
508 | x
-> raise Impossible
510 | _
-> raise Impossible
512 (*---------------------------------------------------------------------------*)
513 let one_initialisation_to_affectation x
=
514 let ({B.v_namei
= var
;
515 B.v_type
= returnType
;
516 B.v_type_bis
= tybis
;
517 B.v_storage
= storage
;
521 | Some
(name
, iniopt
) ->
523 | Some
(iini
, (B.InitExpr e
, ii_empty2
)) ->
526 Ast_c.NotLocalDecl
-> Ast_c.NotLocalVar
528 Ast_c.LocalVar
(Ast_c.info_of_type returnType
) in
530 (* old: Lib_parsing_c.al_type returnType
531 * but this type has not the typename completed so
532 * instead try to use tybis
535 | Some ty_with_typename_completed
-> ty_with_typename_completed
536 | None
-> raise Impossible
539 let typ = ref (Some
(typexp,local), Ast_c.NotTest
) in
541 let idexpr = Ast_c.mk_e_bis
(B.Ident
ident) typ Ast_c.noii
in
543 Ast_c.mk_e
(B.Assignment
(idexpr,B.SimpleAssign
, e
)) [iini
] in
548 let initialisation_to_affectation decl
=
550 | B.MacroDecl _
-> F.Decl decl
551 | B.DeclList
(xs
, iis) ->
553 (* todo?: should not do that if the variable is an array cos
554 * will have x[] = , mais de toute facon ca sera pas un InitExp
556 let possible_assignment =
560 match prev
,one_initialisation_to_affectation x
with
562 | None
,Some x
-> Some x
563 | Some prev
,Some x
->
564 (* [] is clearly an invalid ii value for a sequence.
565 hope that no one looks at it, since nothing will
566 match the sequence. Fortunately, SmPL doesn't
567 support , expressions. *)
568 Some
(Ast_c.mk_e
(Ast_c.Sequence
(prev
, x
)) []))
570 match possible_assignment with
571 Some x
-> F.DefineExpr x
572 | None
-> F.Decl decl
574 (*****************************************************************************)
575 (* Functor parameter combinators *)
576 (*****************************************************************************)
578 * src: papers on parser combinators in haskell (cf a pearl by meijer in ICFP)
580 * version0: was not tagging the SP, so just tag the C
582 * (tin -> 'c tout) -> ('c -> (tin -> 'b tout)) -> (tin -> 'b tout)
583 * val return : 'b -> tin -> 'b tout
584 * val fail : tin -> 'b tout
586 * version1: now also tag the SP so return a ('a * 'b)
589 type mode
= PatternMode
| TransformMode
597 type ('a
, 'b
) matcher
= 'a
-> 'b
-> tin
-> ('a
* 'b
) tout
602 (tin
-> ('a
* 'b
) tout
) ->
603 ('a
-> 'b
-> (tin
-> ('c
* 'd
) tout
)) ->
604 (tin
-> ('c
* 'd
) tout
)
606 val return
: ('a
* 'b
) -> tin
-> ('a
*'b
) tout
607 val fail
: tin
-> ('a
* 'b
) tout
619 val (>&&>) : (tin
-> bool) -> (tin
-> 'x tout
) -> (tin
-> 'x tout
)
621 val tokenf
: ('a
A.mcode
, B.info
) matcher
622 val tokenf_mck
: (A.mcodekind, B.info
) matcher
625 (A.meta_name
A.mcode
, B.expression
) matcher
627 (A.meta_name
A.mcode
, (Ast_c.argument
, Ast_c.il
) either list
) matcher
629 (A.meta_name
A.mcode
, Ast_c.fullType
) matcher
631 (A.meta_name
A.mcode
,
632 (Ast_c.parameterType
, Ast_c.il
) either list
) matcher
634 (A.meta_name
A.mcode
, Ast_c.parameterType
) matcher
636 (A.meta_name
A.mcode
, Ast_c.initialiser
) matcher
638 (A.meta_name
A.mcode
, (Ast_c.initialiser
, Ast_c.il
) either list
) matcher
640 (A.meta_name
A.mcode
, Ast_c.declaration
) matcher
642 (A.meta_name
A.mcode
, Ast_c.field
) matcher
644 (A.meta_name
A.mcode
, Control_flow_c.node
) matcher
646 val distrf_define_params
:
647 (A.meta_name
A.mcode
, (string Ast_c.wrap
, Ast_c.il
) either list
) matcher
649 val distrf_enum_fields
:
650 (A.meta_name
A.mcode
, (B.oneEnumType
, B.il
) either list
) matcher
652 val distrf_struct_fields
:
653 (A.meta_name
A.mcode
, B.field list
) matcher
656 (A.meta_name
A.mcode
, (B.constant
, string) either
B.wrap
) matcher
659 (A.expression
, B.expression
) matcher
-> (A.expression
, F.node
) matcher
662 (A.expression
, B.expression
) matcher
->
663 (A.expression
, B.expression
) matcher
666 (A.fullType
, B.fullType
) matcher
-> (A.fullType
, F.node
) matcher
669 (A.initialiser
, B.initialiser
) matcher
-> (A.initialiser
, F.node
) matcher
672 A.keep_binding
-> A.inherited
->
673 A.meta_name
A.mcode
* Ast_c.metavar_binding_kind
*
674 (unit -> Common.filename
* string * Ast_c.posl
* Ast_c.posl
) ->
675 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
677 val check_idconstraint
:
678 ('a
-> 'b
-> bool) -> 'a
-> 'b
->
679 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
681 val check_constraints_ne
:
682 ('a
, 'b
) matcher
-> 'a list
-> 'b
->
683 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
685 val all_bound
: A.meta_name list
-> (tin
-> bool)
687 val optional_storage_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
688 val optional_qualifier_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
689 val value_format_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
694 (*****************************************************************************)
695 (* Functor code, "Cocci vs C" *)
696 (*****************************************************************************)
699 functor (X
: PARAM
) ->
702 type ('a
, 'b
) matcher
= 'a
-> 'b
-> X.tin
-> ('a
* 'b
) X.tout
705 let return = X.return
708 let (>||>) = X.(>||>)
709 let (>|+|>) = X.(>|+|>)
710 let (>&&>) = X.(>&&>)
712 let tokenf = X.tokenf
714 (* should be raise Impossible when called from transformation.ml *)
717 | PatternMode
-> fail
718 | TransformMode
-> raise Impossible
721 let (option: ('a
,'b
) matcher
-> ('a
option,'b
option) matcher
)= fun f t1 t2
->
723 | (Some t1
, Some t2
) ->
724 f t1 t2
>>= (fun t1 t2
->
725 return (Some t1
, Some t2
)
727 | (None
, None
) -> return (None
, None
)
730 (* Dots are sometimes used as metavariables, since like metavariables they
731 can match other things. But they no longer have the same type. Perhaps these
732 functions could be avoided by introducing an appropriate level of polymorphism,
733 but I don't know how to declare polymorphism across functors *)
734 let dots2metavar (_
,info
,mcodekind,pos
) =
735 (("","..."),info
,mcodekind,pos
)
736 let metavar2dots (_
,info
,mcodekind,pos
) = ("...",info
,mcodekind,pos
)
738 let satisfies_regexpconstraint c id
: bool =
740 A.IdRegExp
(_
,recompiled
) -> Str.string_match recompiled id
0
741 | A.IdNotRegExp
(_
,recompiled
) -> not
(Str.string_match recompiled id
0)
743 let satisfies_iconstraint c id
: bool =
746 let satisfies_econstraint c exp
: bool =
747 let warning s
= pr2_once
("WARNING: "^s
); false in
748 match Ast_c.unwrap_expr exp
with
749 Ast_c.Ident
(name
) ->
751 Ast_c.RegularName rname
->
752 satisfies_regexpconstraint c
(Ast_c.unwrap_st rname
)
753 | Ast_c.CppConcatenatedName _
->
755 "Unable to apply a constraint on a CppConcatenatedName identifier!"
756 | Ast_c.CppVariadicName _
->
758 "Unable to apply a constraint on a CppVariadicName identifier!"
759 | Ast_c.CppIdentBuilder _
->
761 "Unable to apply a constraint on a CppIdentBuilder identifier!")
762 | Ast_c.Constant cst
->
764 | Ast_c.String
(str
, _
) -> satisfies_regexpconstraint c str
765 | Ast_c.MultiString strlist
->
766 warning "Unable to apply a constraint on an multistring constant!"
767 | Ast_c.Char
(char
, _
) -> satisfies_regexpconstraint c char
768 | Ast_c.Int
(int , _
) -> satisfies_regexpconstraint c
int
769 | Ast_c.Float
(float, _
) -> satisfies_regexpconstraint c
float)
770 | _
-> warning "Unable to apply a constraint on an expression!"
773 (* ------------------------------------------------------------------------- *)
774 (* This has to be up here to allow adequate polymorphism *)
776 let list_matcher match_dots rebuild_dots match_comma rebuild_comma
777 match_metalist rebuild_metalist mktermval special_cases
778 element distrf get_iis
= fun eas ebs
->
779 let rec loop = function
780 [], [] -> return ([], [])
781 | [], eb
::ebs
-> fail
783 X.all_bound
(A.get_inherited ea
) >&&>
785 (match match_dots ea
, ebs
with
786 Some
(mcode
, optexpr
), ys
->
787 (* todo: if optexpr, then a WHEN and so may have to filter yys *)
788 if optexpr
<> None
then failwith
"not handling when in a list";
790 (* '...' can take more or less the beginnings of the arguments *)
792 Common.zip
(Common.inits ys
) (Common.tails ys
) in
794 (startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
797 (* allow '...', and maybe its associated ',' to match nothing.
798 * for the associated ',' see below how we handle the EComma
803 if mcode_contain_plus (mcodekind mcode
)
806 "I have no token that I could accroche myself on"*)
807 else return (dots2metavar mcode
, [])
809 (* subtil: we dont want the '...' to match until the
810 * comma. cf -test pb_params_iso. We would get at
811 * "already tagged" error.
812 * this is because both f (... x, ...) and f (..., x, ...)
813 * would match a f(x,3) with our "optional-comma" strategy.
815 (match Common.last startxs
with
817 | Left _
-> distrf
(dots2metavar mcode
) startxs
))
819 >>= (fun mcode startxs
->
820 let mcode = metavar2dots mcode in
821 loop (eas
, endxs
) >>= (fun eas endxs
->
823 (rebuild_dots
(mcode, optexpr
) +> A.rewrap ea
) ::eas
,
831 (match match_comma ea
, ebs
with
832 | Some ia1
, Right ii
::ebs
->
834 (let ib1 = tuple_of_list1 ii
in
835 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
836 loop (eas
, ebs
) >>= (fun eas ebs
->
838 (rebuild_comma ia1
+> A.rewrap ea
)::eas
,
843 (* allow ',' to maching nothing. optional comma trick *)
845 (if mcode_contain_plus (mcodekind ia1
)
847 else loop (eas
, ebs
))
850 (match match_metalist ea
, ebs
with
851 Some
(ida
,leninfo
,keep
,inherited
), ys
->
853 Common.zip
(Common.inits ys
) (Common.tails ys
) in
855 (startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
860 if mcode_contain_plus (mcodekind ida
)
862 (* failwith "no token that I could accroche myself on" *)
865 (match Common.last startxs
with
872 let startxs'
= Ast_c.unsplit_comma
startxs in
873 let len = List.length
startxs'
in
876 | A.MetaListLen
(lenname
,lenkeep
,leninherited
) ->
877 let max_min _
= failwith
"no pos" in
878 X.envf lenkeep leninherited
879 (lenname
, Ast_c.MetaListlenVal
(len), max_min)
882 then (function f
-> f
())
883 else (function f
-> fail)
884 | A.AnyListLen
-> function f
-> f
()
888 Lib_parsing_c.lin_col_by_pos
(get_iis
startxs) in
889 X.envf keep inherited
890 (ida
, mktermval
startxs'
, max_min)
893 then return (ida
, [])
894 else distrf ida
(Ast_c.split_comma
startxs'
))
895 >>= (fun ida
startxs ->
896 loop (eas
, endxs
) >>= (fun eas endxs
->
898 (rebuild_metalist
(ida
,leninfo
,keep
,inherited
))
907 special_cases ea eas ebs
in
908 match try_matches with
913 element ea eb
>>= (fun ea eb
->
914 loop (eas
, ebs
) >>= (fun eas ebs
->
915 return (ea
::eas
, Left eb
::ebs
)))
916 | (Right y
)::ys
-> raise Impossible
920 (*---------------------------------------------------------------------------*)
932 (*---------------------------------------------------------------------------*)
933 let rec (expression
: (A.expression
, Ast_c.expression
) matcher
) =
935 if A.get_test_exp ea
&& not
(Ast_c.is_test eb
) then fail
937 X.all_bound
(A.get_inherited ea
) >&&>
938 let wa x
= A.rewrap ea x
in
939 match A.unwrap ea
, eb
with
941 (* general case: a MetaExpr can match everything *)
942 | A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
),
943 (((expr
, opttypb
), ii
) as expb
) ->
945 (* old: before have a MetaConst. Now we factorize and use 'form' to
946 * differentiate between different cases *)
947 let rec matches_id = function
948 B.Ident
(name
) -> true
949 | B.Cast
(ty
,e
) -> matches_id (B.unwrap_expr e
)
952 match (form
,expr
) with
955 let rec matches = function
956 B.Constant
(c
) -> true
957 | B.Ident
(nameidb
) ->
958 let s = Ast_c.str_of_name nameidb
in
959 if s =~
"^[A-Z_][A-Z_0-9]*$"
961 pr2_once
("warning: " ^
s ^
" treated as a constant");
965 | B.Cast
(ty
,e
) -> matches (B.unwrap_expr e
)
966 | B.Unary
(e
,B.UnMinus
) -> matches (B.unwrap_expr e
)
967 | B.SizeOfExpr
(exp
) -> true
968 | B.SizeOfType
(ty
) -> true
974 (Some
(_
,Ast_c.LocalVar _
),_
) -> true
976 | (A.ID
,e
) -> matches_id e
in
980 (let (opttypb
,_testb
) = !opttypb
in
981 match opttypa
, opttypb
with
982 | None
, _
-> return ((),())
984 pr2_once
("Missing type information. Certainly a pb in " ^
985 "annotate_typer.ml");
988 | Some tas
, Some tb
->
989 tas
+> List.fold_left
(fun acc ta
->
990 acc
>|+|> compatible_type ta tb
) fail
993 let meta_expr_val l x
= Ast_c.MetaExprVal
(x
,l
) in
994 match constraints
with
995 Ast_cocci.NoConstraint
-> return (meta_expr_val [],())
996 | Ast_cocci.NotIdCstrt cstrt
->
997 X.check_idconstraint
satisfies_econstraint cstrt eb
998 (fun () -> return (meta_expr_val [],()))
999 | Ast_cocci.NotExpCstrt cstrts
->
1000 X.check_constraints_ne expression cstrts eb
1001 (fun () -> return (meta_expr_val [],()))
1002 | Ast_cocci.SubExpCstrt cstrts
->
1003 return (meta_expr_val cstrts
,()))
1007 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_expr expb
) in
1008 X.envf keep inherited
(ida
, wrapper expb
, max_min)
1010 X.distrf_e ida expb
>>=
1013 A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
)+>
1021 * | A.MetaExpr(ida,false,opttypa,_inherited), expb ->
1022 * D.distribute_mck (mcodekind ida) D.distribute_mck_e expb binding
1024 * but bug! because if have not tagged SP, then transform without doing
1025 * any checks. Hopefully now have tagged SP technique.
1030 * | A.Edots _, _ -> raise Impossible.
1032 * In fact now can also have the Edots inside normal expression, not
1033 * just in arg lists. in 'x[...];' less: in if(<... x ... y ...>)
1035 | A.Edots
(mcode, None
), expb
->
1036 X.distrf_e
(dots2metavar mcode) expb
>>= (fun mcode expb
->
1038 A.Edots
(metavar2dots mcode, None
) +> A.rewrap ea
,
1043 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
1046 | A.Ident ida
, ((B.Ident
(nameidb
), typ),noii
) ->
1048 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1050 ((A.Ident ida
)) +> wa,
1051 ((B.Ident
(nameidb
), typ),Ast_c.noii
)
1057 | A.MetaErr _
, _
-> failwith
"not handling MetaErr"
1059 (* todo?: handle some isomorphisms in int/float ? can have different
1060 * format : 1l can match a 1.
1062 * todo: normally string can contain some metavar too, so should
1063 * recurse on the string
1065 | A.Constant
(ia1
), ((B.Constant
(ib
) , typ),ii
) ->
1066 (* for everything except the String case where can have multi elems *)
1068 let ib1 = tuple_of_list1 ii
in
1069 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1071 ((A.Constant ia1
)) +> wa,
1072 ((B.Constant
(ib
), typ),[ib1])
1075 (match term ia1
, ib
with
1076 | A.Int x
, B.Int
(y
,_
) ->
1077 X.value_format_flag
(fun use_value_equivalence
->
1078 if use_value_equivalence
1088 | A.Char x
, B.Char
(y
,_
) when x
=$
= y
(* todo: use kind ? *)
1090 | A.Float x
, B.Float
(y
,_
) when x
=$
= y
(* todo: use floatType ? *)
1093 | A.String sa
, B.String
(sb
,_kind
) when sa
=$
= sb
->
1096 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1098 ((A.Constant ia1
)) +> wa,
1099 ((B.Constant
(ib
), typ),[ib1])
1101 | _
-> fail (* multi string, not handled *)
1104 | _
, B.MultiString _
-> (* todo cocci? *) fail
1105 | _
, (B.String _
| B.Float _
| B.Char _
| B.Int _
) -> fail
1109 | A.FunCall
(ea
, ia1
, eas
, ia2
), ((B.FunCall
(eb
, ebs
), typ),ii
) ->
1110 (* todo: do special case to allow IdMetaFunc, cos doing the
1111 * recursive call will be too late, match_ident will not have the
1112 * info whether it was a function. todo: but how detect when do
1113 * x.field = f; how know that f is a Func ? By having computed
1114 * some information before the matching!
1116 * Allow match with FunCall containing types. Now ast_cocci allow
1117 * type in parameter, and morover ast_cocci allow f(...) and those
1118 * ... could match type.
1120 let (ib1, ib2
) = tuple_of_list2 ii
in
1121 expression ea eb
>>= (fun ea eb
->
1122 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1123 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1124 arguments
(seqstyle eas
) (A.undots eas
) ebs
>>= (fun easundots ebs
->
1125 let eas = redots
eas easundots
in
1127 ((A.FunCall
(ea
, ia1
, eas, ia2
)) +> wa,
1128 ((B.FunCall
(eb
, ebs
),typ), [ib1;ib2
])
1134 | A.Assignment
(ea1
, opa
, ea2
, simple
),
1135 ((B.Assignment
(eb1
, opb
, eb2
), typ),ii
) ->
1136 let (opbi
) = tuple_of_list1 ii
in
1137 if equal_assignOp (term opa
) opb
1139 expression ea1 eb1
>>= (fun ea1 eb1
->
1140 expression ea2 eb2
>>= (fun ea2 eb2
->
1141 tokenf opa opbi
>>= (fun opa opbi
->
1143 (A.Assignment
(ea1
, opa
, ea2
, simple
)) +> wa,
1144 ((B.Assignment
(eb1
, opb
, eb2
), typ), [opbi
])
1148 | A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
),((B.CondExpr
(eb1
,eb2opt
,eb3
),typ),ii
) ->
1149 let (ib1, ib2
) = tuple_of_list2 ii
in
1150 expression ea1 eb1
>>= (fun ea1 eb1
->
1151 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
1152 expression ea3 eb3
>>= (fun ea3 eb3
->
1153 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1154 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1156 ((A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
))) +> wa,
1157 ((B.CondExpr
(eb1
, eb2opt
, eb3
),typ), [ib1;ib2
])
1160 (* todo?: handle some isomorphisms here ? *)
1161 | A.Postfix
(ea
, opa
), ((B.Postfix
(eb
, opb
), typ),ii
) ->
1162 let opbi = tuple_of_list1 ii
in
1163 if equal_fixOp (term opa
) opb
1165 expression ea eb
>>= (fun ea eb
->
1166 tokenf opa
opbi >>= (fun opa
opbi ->
1168 ((A.Postfix
(ea
, opa
))) +> wa,
1169 ((B.Postfix
(eb
, opb
), typ),[opbi])
1174 | A.Infix
(ea
, opa
), ((B.Infix
(eb
, opb
), typ),ii
) ->
1175 let opbi = tuple_of_list1 ii
in
1176 if equal_fixOp (term opa
) opb
1178 expression ea eb
>>= (fun ea eb
->
1179 tokenf opa
opbi >>= (fun opa
opbi ->
1181 ((A.Infix
(ea
, opa
))) +> wa,
1182 ((B.Infix
(eb
, opb
), typ),[opbi])
1186 | A.Unary
(ea
, opa
), ((B.Unary
(eb
, opb
), typ),ii
) ->
1187 let opbi = tuple_of_list1 ii
in
1188 if equal_unaryOp (term opa
) opb
1190 expression ea eb
>>= (fun ea eb
->
1191 tokenf opa
opbi >>= (fun opa
opbi ->
1193 ((A.Unary
(ea
, opa
))) +> wa,
1194 ((B.Unary
(eb
, opb
), typ),[opbi])
1198 | A.Binary
(ea1
, opa
, ea2
), ((B.Binary
(eb1
, opb
, eb2
), typ),ii
) ->
1199 let opbi = tuple_of_list1 ii
in
1200 if equal_binaryOp (term opa
) opb
1202 expression ea1 eb1
>>= (fun ea1 eb1
->
1203 expression ea2 eb2
>>= (fun ea2 eb2
->
1204 tokenf opa
opbi >>= (fun opa
opbi ->
1206 ((A.Binary
(ea1
, opa
, ea2
))) +> wa,
1207 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1211 | A.Nested
(ea1
, opa
, ea2
), eb
->
1213 expression ea1 eb
>|+|>
1215 ((B.Binary
(eb1
, opb
, eb2
), typ),ii
)
1216 when equal_binaryOp (term opa
) opb
->
1217 let opbi = tuple_of_list1 ii
in
1219 (expression ea1 eb1
>>= (fun ea1 eb1
->
1220 expression ea2 eb2
>>= (fun ea2 eb2
->
1221 tokenf opa
opbi >>= (fun opa
opbi ->
1223 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1224 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1227 (expression ea2 eb1
>>= (fun ea2 eb1
->
1228 expression ea1 eb2
>>= (fun ea1 eb2
->
1229 tokenf opa
opbi >>= (fun opa
opbi ->
1231 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1232 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1235 (loop eb1
>>= (fun ea1 eb1
->
1236 expression ea2 eb2
>>= (fun ea2 eb2
->
1237 tokenf opa
opbi >>= (fun opa
opbi ->
1239 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1240 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1243 (expression ea2 eb1
>>= (fun ea2 eb1
->
1244 loop eb2
>>= (fun ea1 eb2
->
1245 tokenf opa
opbi >>= (fun opa
opbi ->
1247 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1248 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1250 left_to_right >|+|> right_to_left >|+|> in_left >|+|> in_right
1254 (* todo?: handle some isomorphisms here ? (with pointers = Unary Deref) *)
1255 | A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
),((B.ArrayAccess
(eb1
, eb2
), typ),ii
) ->
1256 let (ib1, ib2
) = tuple_of_list2 ii
in
1257 expression ea1 eb1
>>= (fun ea1 eb1
->
1258 expression ea2 eb2
>>= (fun ea2 eb2
->
1259 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1260 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1262 ((A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
))) +> wa,
1263 ((B.ArrayAccess
(eb1
, eb2
),typ), [ib1;ib2
])
1266 (* todo?: handle some isomorphisms here ? *)
1267 | A.RecordAccess
(ea
, ia1
, ida
), ((B.RecordAccess
(eb
, idb
), typ),ii
) ->
1268 let (ib1) = tuple_of_list1 ii
in
1269 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
1270 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1271 expression ea eb
>>= (fun ea eb
->
1273 ((A.RecordAccess
(ea
, ia1
, ida
))) +> wa,
1274 ((B.RecordAccess
(eb
, idb
), typ), [ib1])
1279 | A.RecordPtAccess
(ea
,ia1
,ida
),((B.RecordPtAccess
(eb
, idb
), typ), ii
) ->
1280 let (ib1) = tuple_of_list1 ii
in
1281 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
1282 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1283 expression ea eb
>>= (fun ea eb
->
1285 ((A.RecordPtAccess
(ea
, ia1
, ida
))) +> wa,
1286 ((B.RecordPtAccess
(eb
, idb
), typ), [ib1])
1290 (* todo?: handle some isomorphisms here ?
1291 * todo?: do some iso-by-absence on cast ?
1292 * by trying | ea, B.Case (typb, eb) -> match_e_e ea eb ?
1295 | A.Cast
(ia1
, typa
, ia2
, ea
), ((B.Cast
(typb
, eb
), typ),ii
) ->
1296 let (ib1, ib2
) = tuple_of_list2 ii
in
1297 fullType typa typb
>>= (fun typa typb
->
1298 expression ea eb
>>= (fun ea eb
->
1299 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1300 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1302 ((A.Cast
(ia1
, typa
, ia2
, ea
))) +> wa,
1303 ((B.Cast
(typb
, eb
),typ),[ib1;ib2
])
1306 | A.SizeOfExpr
(ia1
, ea
), ((B.SizeOfExpr
(eb
), typ),ii
) ->
1307 let ib1 = tuple_of_list1 ii
in
1308 expression ea eb
>>= (fun ea eb
->
1309 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1311 ((A.SizeOfExpr
(ia1
, ea
))) +> wa,
1312 ((B.SizeOfExpr
(eb
), typ),[ib1])
1315 | A.SizeOfType
(ia1
, ia2
, typa
, ia3
), ((B.SizeOfType typb
, typ),ii
) ->
1316 let (ib1,ib2
,ib3
) = tuple_of_list3 ii
in
1317 fullType typa typb
>>= (fun typa typb
->
1318 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1319 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1320 tokenf ia3 ib3
>>= (fun ia3 ib3
->
1322 ((A.SizeOfType
(ia1
, ia2
, typa
, ia3
))) +> wa,
1323 ((B.SizeOfType
(typb
),typ),[ib1;ib2
;ib3
])
1327 (* todo? iso ? allow all the combinations ? *)
1328 | A.Paren
(ia1
, ea
, ia2
), ((B.ParenExpr
(eb
), typ),ii
) ->
1329 let (ib1, ib2
) = tuple_of_list2 ii
in
1330 expression ea eb
>>= (fun ea eb
->
1331 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1332 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1334 ((A.Paren
(ia1
, ea
, ia2
))) +> wa,
1335 ((B.ParenExpr
(eb
), typ), [ib1;ib2
])
1338 | A.NestExpr
(starter
,exps
,ender
,None
,true), eb
->
1339 (match A.get_mcodekind starter
with
1340 A.MINUS _
-> failwith
"TODO: only context nests supported"
1342 (match A.unwrap exps
with
1344 X.cocciExpExp expression exp eb
>>= (fun exp eb
->
1347 (starter
,A.rewrap exps
(A.DOTS
[exp
]),ender
,None
,true)) +> wa,
1353 "for nestexpr, only handling the case with dots and only one exp")
1355 | A.NestExpr _
, _
->
1356 failwith
"only handling multi and no when code in a nest expr"
1358 (* only in arg lists or in define body *)
1359 | A.TypeExp _
, _
-> fail
1361 (* only in arg lists *)
1362 | A.MetaExprList _
, _
1369 | A.DisjExpr
eas, eb
->
1370 eas +> List.fold_left
(fun acc ea
-> acc
>|+|> (expression ea eb
)) fail
1372 | A.UniqueExp _
,_
| A.OptExp _
,_
->
1373 failwith
"not handling Opt/Unique/Multi on expr"
1375 (* Because of Exp cant put a raise Impossible; have to put a fail *)
1377 (* have not a counter part in coccinelle, for the moment *)
1378 | _
, ((B.Sequence _
,_
),_
)
1379 | _
, ((B.StatementExpr _
,_
),_
)
1380 | _
, ((B.Constructor _
,_
),_
)
1385 (((B.Cast
(_
, _
)|B.ParenExpr _
|B.SizeOfType _
|B.SizeOfExpr _
|
1386 B.RecordPtAccess
(_
, _
)|
1387 B.RecordAccess
(_
, _
)|B.ArrayAccess
(_
, _
)|
1388 B.Binary
(_
, _
, _
)|B.Unary
(_
, _
)|
1389 B.Infix
(_
, _
)|B.Postfix
(_
, _
)|
1390 B.Assignment
(_
, _
, _
)|B.CondExpr
(_
, _
, _
)|
1391 B.FunCall
(_
, _
)|B.Constant _
|B.Ident _
),
1399 (* ------------------------------------------------------------------------- *)
1400 and (ident_cpp
: info_ident
-> (A.ident, B.name
) matcher
) =
1401 fun infoidb ida idb
->
1403 | B.RegularName
(s, iis) ->
1404 let iis = tuple_of_list1
iis in
1405 ident infoidb ida
(s, iis) >>= (fun ida
(s,iis) ->
1408 (B.RegularName
(s, [iis]))
1410 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
1412 (* This should be moved to the Id case of ident. Metavariables
1413 should be allowed to be bound to such variables. But doing so
1414 would require implementing an appropriate distr function *)
1417 and (ident: info_ident
-> (A.ident, string * Ast_c.info
) matcher
) =
1418 fun infoidb ida
((idb
, iib
)) -> (* (idb, iib) as ib *)
1419 let check_constraints constraints idb
=
1420 let meta_id_val l x
= Ast_c.MetaIdVal
(x
,l
) in
1421 match constraints
with
1422 A.IdNoConstraint
-> return (meta_id_val [],())
1423 | A.IdNegIdSet
(str
,meta
) ->
1424 X.check_idconstraint
satisfies_iconstraint str idb
1425 (fun () -> return (meta_id_val meta
,()))
1426 | A.IdRegExpConstraint re
->
1427 X.check_idconstraint
satisfies_regexpconstraint re idb
1428 (fun () -> return (meta_id_val [],())) in
1429 X.all_bound
(A.get_inherited ida
) >&&>
1430 match A.unwrap ida
with
1432 if (term sa
) =$
= idb
then
1433 tokenf sa iib
>>= (fun sa iib
->
1435 ((A.Id sa
)) +> A.rewrap ida
,
1440 | A.MetaId
(mida
,constraints
,keep
,inherited
) ->
1441 check_constraints constraints idb
>>=
1443 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1444 (* use drop_pos for ids so that the pos is not added a second time in
1445 the call to tokenf *)
1446 X.envf keep inherited
(A.drop_pos mida
, wrapper idb
, max_min)
1448 tokenf mida iib
>>= (fun mida iib
->
1450 ((A.MetaId
(mida
, constraints
, keep
, inherited
)) +> A.rewrap ida
,
1455 | A.MetaFunc
(mida
,constraints
,keep
,inherited
) ->
1457 check_constraints constraints idb
>>=
1459 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1460 X.envf keep inherited
(A.drop_pos mida
,Ast_c.MetaFuncVal idb
,max_min)
1462 tokenf mida iib
>>= (fun mida iib
->
1464 ((A.MetaFunc
(mida
,constraints
,keep
,inherited
)))+>A.rewrap ida
,
1469 | LocalFunction
| Function
-> is_function()
1471 failwith
"MetaFunc, need more semantic info about id"
1472 (* the following implementation could possibly be useful, if one
1473 follows the convention that a macro is always in capital letters
1474 and that a macro is not a function.
1475 (if idb =~ "^[A-Z_][A-Z_0-9]*$" then fail else is_function())*)
1478 | A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
) ->
1481 check_constraints constraints idb
>>=
1483 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1484 X.envf keep inherited
1485 (A.drop_pos mida
,Ast_c.MetaLocalFuncVal idb
, max_min)
1487 tokenf mida iib
>>= (fun mida iib
->
1489 ((A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
)))
1495 | DontKnow
-> failwith
"MetaLocalFunc, need more semantic info about id"
1498 | A.OptIdent _
| A.UniqueIdent _
->
1499 failwith
"not handling Opt/Unique for ident"
1501 (* ------------------------------------------------------------------------- *)
1502 and (arguments
: sequence
->
1503 (A.expression list
, Ast_c.argument
Ast_c.wrap2 list
) matcher
) =
1504 fun seqstyle eas ebs
->
1506 | Unordered
-> failwith
"not handling ooo"
1508 arguments_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1509 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1511 (* because '...' can match nothing, need to take care when have
1512 * ', ...' or '...,' as in f(..., X, Y, ...). It must match
1513 * f(1,2) for instance.
1514 * So I have added special cases such as (if startxs = []) and code
1515 * in the Ecomma matching rule.
1517 * old: Must do some try, for instance when f(...,X,Y,...) have to
1518 * test the transfo for all the combinaitions and if multiple transfo
1519 * possible ? pb ? => the type is to return a expression option ? use
1520 * some combinators to help ?
1521 * update: with the tag-SP approach, no more a problem.
1524 and arguments_bis
= fun eas ebs
->
1526 match A.unwrap ea
with
1527 A.Edots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
1529 let build_dots (mcode, optexpr
) = A.Edots
(mcode, optexpr
) in
1530 let match_comma ea
=
1531 match A.unwrap ea
with
1532 A.EComma ia1
-> Some ia1
1534 let build_comma ia1
= A.EComma ia1
in
1535 let match_metalist ea
=
1536 match A.unwrap ea
with
1537 A.MetaExprList
(ida
,leninfo
,keep
,inherited
) ->
1538 Some
(ida
,leninfo
,keep
,inherited
)
1540 let build_metalist (ida
,leninfo
,keep
,inherited
) =
1541 A.MetaExprList
(ida
,leninfo
,keep
,inherited
) in
1542 let mktermval v
= Ast_c.MetaExprListVal v
in
1543 let special_cases ea
eas ebs
= None
in
1544 list_matcher match_dots build_dots match_comma build_comma
1545 match_metalist build_metalist mktermval
1546 special_cases argument
X.distrf_args
1547 Lib_parsing_c.ii_of_args
eas ebs
1549 and argument arga argb
=
1550 X.all_bound
(A.get_inherited arga
) >&&>
1551 match A.unwrap arga
, argb
with
1553 Right
(B.ArgType
{B.p_register
=b
,iib
; p_namei
=sopt
;p_type
=tyb
}) ->
1554 if b
|| sopt
<> None
1556 (* failwith "the argument have a storage and ast_cocci does not have"*)
1559 (* b = false and sopt = None *)
1560 fullType tya tyb
>>= (fun tya tyb
->
1562 (A.TypeExp tya
) +> A.rewrap arga
,
1563 (Right
(B.ArgType
{B.p_register
=(b
,iib
);
1568 | A.TypeExp tya
, _
-> fail
1569 | _
, Right
(B.ArgType _
) -> fail
1571 expression arga argb
>>= (fun arga argb
->
1572 return (arga
, Left argb
)
1574 | _
, Right
(B.ArgAction y
) -> fail
1577 (* ------------------------------------------------------------------------- *)
1578 (* todo? facto code with argument ? *)
1579 and (parameters
: sequence
->
1580 (A.parameterTypeDef list
, Ast_c.parameterType
Ast_c.wrap2 list
)
1582 fun seqstyle eas ebs
->
1584 | Unordered
-> failwith
"not handling ooo"
1586 parameters_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1587 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1591 and parameters_bis
eas ebs
=
1593 match A.unwrap ea
with
1594 A.Pdots
(mcode) -> Some
(mcode, None
)
1596 let build_dots (mcode, _optexpr
) = A.Pdots
(mcode) in
1597 let match_comma ea
=
1598 match A.unwrap ea
with
1599 A.PComma ia1
-> Some ia1
1601 let build_comma ia1
= A.PComma ia1
in
1602 let match_metalist ea
=
1603 match A.unwrap ea
with
1604 A.MetaParamList
(ida
,leninfo
,keep
,inherited
) ->
1605 Some
(ida
,leninfo
,keep
,inherited
)
1607 let build_metalist (ida
,leninfo
,keep
,inherited
) =
1608 A.MetaParamList
(ida
,leninfo
,keep
,inherited
) in
1609 let mktermval v
= Ast_c.MetaParamListVal v
in
1610 let special_cases ea
eas ebs
=
1611 (* a case where one smpl parameter matches a list of C parameters *)
1612 match A.unwrap ea
,ebs
with
1613 A.VoidParam ta
, ys
->
1615 (match eas, ebs
with
1617 let {B.p_register
=(hasreg
,iihasreg
);
1619 p_type
=tb
; } = eb
in
1621 if idbopt
=*= None
&& not hasreg
1624 | (qub
, (B.BaseType
B.Void
,_
)) ->
1625 fullType ta tb
>>= (fun ta tb
->
1627 [(A.VoidParam ta
) +> A.rewrap ea
],
1628 [Left
{B.p_register
=(hasreg
, iihasreg
);
1636 list_matcher match_dots build_dots match_comma build_comma
1637 match_metalist build_metalist mktermval
1638 special_cases parameter
X.distrf_params
1639 Lib_parsing_c.ii_of_params
eas ebs
1642 let split_register_param = fun (hasreg, idb, ii_b_s) ->
1643 match hasreg, idb, ii_b_s with
1644 | false, Some s, [i1] -> Left (s, [], i1)
1645 | true, Some s, [i1;i2] -> Left (s, [i1], i2)
1646 | _, None, ii -> Right ii
1647 | _ -> raise Impossible
1651 and parameter
= fun parama paramb
->
1652 match A.unwrap parama
, paramb
with
1653 A.MetaParam
(ida
,keep
,inherited
), eb
->
1654 (* todo: use quaopt, hasreg ? *)
1656 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_param eb
) in
1657 X.envf keep inherited
(ida
,Ast_c.MetaParamVal eb
,max_min) (fun () ->
1658 X.distrf_param ida eb
1659 ) >>= (fun ida eb
->
1660 return (A.MetaParam
(ida
,keep
,inherited
)+> A.rewrap parama
,eb
))
1661 | A.Param
(typa
, idaopt
), eb
->
1662 let {B.p_register
= (hasreg
,iihasreg
);
1663 p_namei
= nameidbopt
;
1664 p_type
= typb
;} = paramb
in
1666 fullType typa typb
>>= (fun typa typb
->
1667 match idaopt
, nameidbopt
with
1668 | Some ida
, Some nameidb
->
1669 (* todo: if minus on ida, should also minus the iihasreg ? *)
1670 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1672 A.Param
(typa
, Some ida
)+> A.rewrap parama
,
1673 {B.p_register
= (hasreg
, iihasreg
);
1674 p_namei
= Some
(nameidb
);
1680 A.Param
(typa
, None
)+> A.rewrap parama
,
1681 {B.p_register
=(hasreg
,iihasreg
);
1685 (* why handle this case ? because of transform_proto ? we may not
1686 * have an ident in the proto.
1687 * If have some plus on ida ? do nothing about ida ?
1689 (* not anymore !!! now that julia is handling the proto.
1690 | _, Right iihasreg ->
1693 ((hasreg, None, typb), iihasreg)
1697 | Some _
, None
-> fail
1698 | None
, Some _
-> fail)
1699 | (A.OptParam _
| A.UniqueParam _
), _
->
1700 failwith
"not handling Opt/Unique for Param"
1701 | A.Pcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
1704 (* ------------------------------------------------------------------------- *)
1705 and (declaration
: (A.mcodekind * bool * A.declaration
,B.declaration
) matcher
) =
1706 fun (mckstart
, allminus
, decla
) declb
->
1707 X.all_bound
(A.get_inherited decla
) >&&>
1708 match A.unwrap decla
, declb
with
1710 (* Un MetaDecl est introduit dans l'asttoctl pour sauter au dessus
1711 * de toutes les declarations qui sont au debut d'un fonction et
1712 * commencer le reste du match au premier statement. Alors, ca matche
1713 * n'importe quelle declaration. On n'a pas besoin d'ajouter
1714 * quoi que ce soit dans l'environnement. C'est une sorte de DDots.
1716 * When the SP want to remove the whole function, the minus is not
1717 * on the MetaDecl but on the MetaRuleElem. So there should
1718 * be no transform of MetaDecl, just matching are allowed.
1721 | A.MetaDecl
(ida
,keep
,inherited
), _
->
1723 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_decl declb
) in
1724 X.envf keep inherited
(ida
, Ast_c.MetaDeclVal declb
, max_min) (fun () ->
1725 X.distrf_decl ida declb
1726 ) >>= (fun ida declb
->
1727 return ((mckstart
, allminus
,
1728 (A.MetaDecl
(ida
, keep
, inherited
))+> A.rewrap decla
),
1730 | _
, (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
)) ->
1731 onedecl allminus decla
(var
,iiptvirgb
,iisto
) >>=
1732 (fun decla
(var
,iiptvirgb
,iisto
)->
1733 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1735 (mckstart
, allminus
, decla
),
1736 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1739 | _
, (B.DeclList
(xs
, iiptvirgb
::iifakestart
::iisto
)) ->
1740 if X.mode
=*= PatternMode
1742 xs
+> List.fold_left
(fun acc var
->
1744 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1745 onedecl allminus decla
(var
, iiptvirgb
, iisto
) >>=
1746 (fun decla
(var
, iiptvirgb
, iisto
) ->
1748 (mckstart
, allminus
, decla
),
1749 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1753 failwith
"More that one variable in decl. Have to split to transform."
1755 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
), B.MacroDecl
((sb
,ebs
),ii
) ->
1756 let (iisb
, lpb
, rpb
, iiendb
, iifakestart
, iistob
) =
1758 | iisb
::lpb
::rpb
::iiendb
::iifakestart
::iisto
->
1759 (iisb
,lpb
,rpb
,iiendb
, iifakestart
,iisto
)
1760 | _
-> raise Impossible
1763 then minusize_list iistob
1764 else return ((), iistob
)
1765 ) >>= (fun () iistob
->
1767 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1768 ident DontKnow sa
(sb
, iisb
) >>= (fun sa
(sb
, iisb
) ->
1769 tokenf lpa lpb
>>= (fun lpa lpb
->
1770 tokenf rpa rpb
>>= (fun rpa rpb
->
1771 tokenf enda iiendb
>>= (fun enda iiendb
->
1772 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
1773 let eas = redots
eas easundots
in
1776 (mckstart
, allminus
,
1777 (A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
)) +> A.rewrap decla
),
1778 (B.MacroDecl
((sb
,ebs
),
1779 [iisb
;lpb
;rpb
;iiendb
;iifakestart
] ++ iistob
))
1782 | _
, (B.MacroDecl _
|B.DeclList _
) -> fail
1785 and onedecl
= fun allminus decla
(declb
, iiptvirgb
, iistob
) ->
1786 X.all_bound
(A.get_inherited decla
) >&&>
1787 match A.unwrap decla
, declb
with
1789 (* kind of typedef iso, we must unfold, it's for the case
1790 * T { }; that we want to match against typedef struct { } xx_t;
1793 | A.TyDecl
(tya0
, ptvirga
),
1794 ({B.v_namei
= Some
(nameidb
, None
);
1796 B.v_storage
= (B.StoTypedef
, inl
);
1799 B.v_type_bis
= typb0bis
;
1802 (match A.unwrap tya0
, typb0
with
1803 | A.Type
(cv1
,tya1
), ((qu
,il
),typb1
) ->
1805 (match A.unwrap tya1
, typb1
with
1806 | A.StructUnionDef
(tya2
, lba
, declsa
, rba
),
1807 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
1809 let (iisub
, iisbopt
, lbb
, rbb
) =
1812 let (iisub
, lbb
, rbb
) = tuple_of_list3 ii
in
1813 (iisub
, [], lbb
, rbb
)
1816 "warning: both a typedef (%s) and struct name introduction (%s)"
1817 (Ast_c.str_of_name nameidb
) s
1819 pr2 "warning: I will consider only the typedef";
1820 let (iisub
, iisb
, lbb
, rbb
) = tuple_of_list4 ii
in
1821 (iisub
, [iisb
], lbb
, rbb
)
1824 structdef_to_struct_name
1825 (Ast_c.nQ
, (B.StructUnion
(sub
, sbopt
, declsb
), ii
))
1828 Ast_c.nQ
,((B.TypeName
(nameidb
, Some
1829 (Lib_parsing_c.al_type
structnameb))), [])
1832 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1833 tokenf lba lbb
>>= (fun lba lbb
->
1834 tokenf rba rbb
>>= (fun rba rbb
->
1835 struct_fields
(A.undots declsa
) declsb
>>=(fun undeclsa declsb
->
1836 let declsa = redots
declsa undeclsa
in
1838 (match A.unwrap tya2
with
1839 | A.Type
(cv3
, tya3
) ->
1840 (match A.unwrap tya3
with
1841 | A.MetaType
(ida
,keep
, inherited
) ->
1843 fullType tya2
fake_typeb >>= (fun tya2
fake_typeb ->
1845 A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1 in
1846 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1849 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1850 [iisub
] @ iisbopt
@ [lbb
;rbb
] in
1851 let typb0 = ((qu
, il
), typb1) in
1853 match fake_typeb with
1854 | _nQ
, ((B.TypeName
(nameidb
, _typ
)),[]) ->
1857 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1858 (({B.v_namei
= Some
(nameidb
, None
);
1860 B.v_storage
= (B.StoTypedef
, inl
);
1863 B.v_type_bis
= typb0bis
;
1865 iivirg
),iiptvirgb
,iistob
)
1867 | _
-> raise Impossible
1870 (* do we need EnumName here too? *)
1871 | A.StructUnionName
(sua
, sa
) ->
1872 fullType tya2
structnameb >>= (fun tya2
structnameb ->
1874 let tya1 = A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1
1876 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1878 match structnameb with
1879 | _nQ
, (B.StructUnionName
(sub
, s), [iisub
;iisbopt
]) ->
1881 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1882 [iisub
;iisbopt
;lbb
;rbb
] in
1883 let typb0 = ((qu
, il
), typb1) in
1886 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1887 (({B.v_namei
= Some
(nameidb
, None
);
1889 B.v_storage
= (B.StoTypedef
, inl
);
1892 B.v_type_bis
= typb0bis
;
1894 iivirg
),iiptvirgb
,iistob
)
1896 | _
-> raise Impossible
1898 | _
-> raise Impossible
1907 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1908 ({B.v_namei
= Some
(nameidb
, _
);B.v_storage
= (B.StoTypedef
,_
);}, iivirg
)
1911 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1912 ({B.v_namei
=Some
(nameidb
, _
);B.v_storage
=(B.StoTypedef
,_
);}, iivirg
)
1917 (* could handle iso here but handled in standard.iso *)
1918 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1919 ({B.v_namei
= Some
(nameidb
, None
);
1924 B.v_type_bis
= typbbis
;
1927 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1928 fullType typa typb
>>= (fun typa typb
->
1929 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1930 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1931 (fun stoa
(stob
, iistob
) ->
1933 (A.UnInit
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
1934 (({B.v_namei
= Some
(nameidb
, None
);
1939 B.v_type_bis
= typbbis
;
1944 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1945 ({B.v_namei
= Some
(nameidb
, Some
(iieqb
, inib
));
1950 B.v_type_bis
= typbbis
;
1953 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1954 tokenf eqa iieqb
>>= (fun eqa iieqb
->
1955 fullType typa typb
>>= (fun typa typb
->
1956 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1957 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1958 (fun stoa
(stob
, iistob
) ->
1959 initialiser inia inib
>>= (fun inia inib
->
1961 (A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
)) +> A.rewrap decla
,
1962 (({B.v_namei
= Some
(nameidb
, Some
(iieqb
, inib
));
1967 B.v_type_bis
= typbbis
;
1972 (* do iso-by-absence here ? allow typedecl and var ? *)
1973 | A.TyDecl
(typa
, ptvirga
),
1974 ({B.v_namei
= None
; B.v_type
= typb
;
1978 B.v_type_bis
= typbbis
;
1981 if stob
=*= (B.NoSto
, false)
1983 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1984 fullType typa typb
>>= (fun typa typb
->
1986 (A.TyDecl
(typa
, ptvirga
)) +> A.rewrap decla
,
1987 (({B.v_namei
= None
;
1992 B.v_type_bis
= typbbis
;
1993 }, iivirg
), iiptvirgb
, iistob
)
1998 | A.Typedef
(stoa
, typa
, ida
, ptvirga
),
1999 ({B.v_namei
= Some
(nameidb
, None
);
2001 B.v_storage
= (B.StoTypedef
,inline
);
2004 B.v_type_bis
= typbbis
;
2007 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2008 fullType typa typb
>>= (fun typa typb
->
2011 tokenf stoa iitypedef
>>= (fun stoa iitypedef
->
2012 return (stoa
, [iitypedef
])
2014 | _
-> failwith
"weird, have both typedef and inline or nothing";
2015 ) >>= (fun stoa iistob
->
2016 (match A.unwrap ida
with
2017 | A.MetaType
(_
,_
,_
) ->
2020 Ast_c.nQ
, ((B.TypeName
(nameidb
, Ast_c.noTypedefDef
())), [])
2022 fullTypebis ida
fake_typeb >>= (fun ida
fake_typeb ->
2023 match fake_typeb with
2024 | _nQ
, ((B.TypeName
(nameidb
, _typ
)), []) ->
2025 return (ida
, nameidb
)
2026 | _
-> raise Impossible
2031 | B.RegularName
(sb
, iidb
) ->
2032 let iidb1 = tuple_of_list1 iidb
in
2036 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
2038 (A.TypeName sa
) +> A.rewrap ida
,
2039 B.RegularName
(sb
, [iidb1])
2043 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
2047 | _
-> raise Impossible
2049 ) >>= (fun ida nameidb
->
2051 (A.Typedef
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
2052 (({B.v_namei
= Some
(nameidb
, None
);
2054 B.v_storage
= (B.StoTypedef
,inline
);
2057 B.v_type_bis
= typbbis
;
2065 | _
, ({B.v_namei
= None
;}, _
) ->
2066 (* old: failwith "no variable in this declaration, weird" *)
2071 | A.DisjDecl declas
, declb
->
2072 declas
+> List.fold_left
(fun acc decla
->
2074 (* (declaration (mckstart, allminus, decla) declb) *)
2075 (onedecl allminus decla
(declb
,iiptvirgb
, iistob
))
2080 (* only in struct type decls *)
2081 | A.Ddots
(dots
,whencode
), _
->
2084 | A.OptDecl _
, _
| A.UniqueDecl _
, _
->
2085 failwith
"not handling Opt/Unique Decl"
2087 | _
, ({B.v_namei
=Some _
}, _
) ->
2093 (* ------------------------------------------------------------------------- *)
2095 and (initialiser
: (A.initialiser
, Ast_c.initialiser
) matcher
) = fun ia ib
->
2096 X.all_bound
(A.get_inherited ia
) >&&>
2097 match (A.unwrap ia
,ib
) with
2099 | (A.MetaInit
(ida
,keep
,inherited
), ib
) ->
2101 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_ini ib
) in
2102 X.envf keep inherited
(ida
, Ast_c.MetaInitVal ib
, max_min)
2104 X.distrf_ini ida ib
>>= (fun ida ib
->
2106 A.MetaInit
(ida
,keep
,inherited
) +> A.rewrap ia
,
2111 | (A.InitExpr expa
, ib
) ->
2112 (match A.unwrap expa
, ib
with
2113 | A.Edots
(mcode, None
), ib
->
2114 X.distrf_ini
(dots2metavar mcode) ib
>>= (fun mcode ib
->
2117 (A.Edots
(metavar2dots mcode, None
) +> A.rewrap expa
)
2122 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
2124 | _
, (B.InitExpr expb
, ii
) ->
2126 expression expa expb
>>= (fun expa expb
->
2128 (A.InitExpr expa
) +> A.rewrap ia
,
2129 (B.InitExpr expb
, ii
)
2134 | (A.ArInitList
(ia1
, ias
, ia2
), (B.InitList ibs
, ii
)) ->
2136 | ib1::ib2
::iicommaopt
->
2137 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2138 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2139 ar_initialisers
(A.undots ias
) (ibs
, iicommaopt
) >>=
2140 (fun iasundots
(ibs
,iicommaopt
) ->
2142 (A.ArInitList
(ia1
, redots ias iasundots
, ia2
)) +> A.rewrap ia
,
2143 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2146 | _
-> raise Impossible
2149 | (A.StrInitList
(allminus
, ia1
, ias
, ia2
, []), (B.InitList ibs
, ii
)) ->
2151 | ib1::ib2
::iicommaopt
->
2152 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2153 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2154 str_initialisers allminus ias
(ibs
, iicommaopt
) >>=
2155 (fun ias
(ibs
,iicommaopt
) ->
2157 (A.StrInitList
(allminus
, ia1
, ias
, ia2
, [])) +> A.rewrap ia
,
2158 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2161 | _
-> raise Impossible
2164 | (A.StrInitList
(allminus
, i1
, ias
, i2
, whencode
),
2165 (B.InitList ibs
, _ii
)) ->
2166 failwith
"TODO: not handling whencode in initialisers"
2169 | (A.InitGccExt
(designatorsa
, ia2
, inia
),
2170 (B.InitDesignators
(designatorsb
, inib
), ii2
))->
2172 let iieq = tuple_of_list1 ii2
in
2174 tokenf ia2
iieq >>= (fun ia2
iieq ->
2175 designators designatorsa designatorsb
>>=
2176 (fun designatorsa designatorsb
->
2177 initialiser inia inib
>>= (fun inia inib
->
2179 (A.InitGccExt
(designatorsa
, ia2
, inia
)) +> A.rewrap ia
,
2180 (B.InitDesignators
(designatorsb
, inib
), [iieq])
2186 | (A.InitGccName
(ida
, ia1
, inia
), (B.InitFieldOld
(idb
, inib
), ii
)) ->
2189 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2190 initialiser inia inib
>>= (fun inia inib
->
2191 tokenf ia1 iicolon
>>= (fun ia1 iicolon
->
2193 (A.InitGccName
(ida
, ia1
, inia
)) +> A.rewrap ia
,
2194 (B.InitFieldOld
(idb
, inib
), [iidb
;iicolon
])
2201 | A.IComma
(comma
), _
->
2204 | A.UniqueIni _
,_
| A.OptIni _
,_
->
2205 failwith
"not handling Opt/Unique on initialisers"
2207 | _
, (B.InitIndexOld
(_
, _
), _
) -> fail
2208 | _
, (B.InitFieldOld
(_
, _
), _
) -> fail
2210 | _
, ((B.InitDesignators
(_
, _
)|B.InitList _
|B.InitExpr _
), _
)
2213 and designators dla dlb
=
2214 match (dla
,dlb
) with
2215 ([],[]) -> return ([], [])
2216 | ([],_
) | (_
,[]) -> fail
2217 | (da
::dla
,db
::dlb
) ->
2218 designator da db
>>= (fun da db
->
2219 designators dla dlb
>>= (fun dla dlb
->
2220 return (da
::dla
, db
::dlb
)))
2222 and designator da db
=
2224 (A.DesignatorField
(ia1
, ida
), (B.DesignatorField idb
,ii1
)) ->
2226 let (iidot
, iidb
) = tuple_of_list2 ii1
in
2227 tokenf ia1 iidot
>>= (fun ia1 iidot
->
2228 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2230 A.DesignatorField
(ia1
, ida
),
2231 (B.DesignatorField idb
, [iidot
;iidb
])
2234 | (A.DesignatorIndex
(ia1
,ea
,ia2
), (B.DesignatorIndex eb
, ii1
)) ->
2236 let (ib1, ib2
) = tuple_of_list2 ii1
in
2237 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2238 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2239 expression ea eb
>>= (fun ea eb
->
2241 A.DesignatorIndex
(ia1
,ea
,ia2
),
2242 (B.DesignatorIndex eb
, [ib1;ib2
])
2245 | (A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2246 (B.DesignatorRange
(e1b
, e2b
), ii1
)) ->
2248 let (ib1, ib2
, ib3
) = tuple_of_list3 ii1
in
2249 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2250 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2251 tokenf ia3 ib3
>>= (fun ia3 ib3
->
2252 expression e1a e1b
>>= (fun e1a e1b
->
2253 expression e2a e2b
>>= (fun e2a e2b
->
2255 A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2256 (B.DesignatorRange
(e1b
, e2b
), [ib1;ib2
;ib3
])
2258 | (_
, ((B.DesignatorField _
|B.DesignatorIndex _
|B.DesignatorRange _
), _
)) ->
2261 and str_initialisers
= fun allminus ias
(ibs
, iicomma
) ->
2262 let ias_unsplit = unsplit_icomma ias
in
2263 let ibs_split = resplit_initialiser ibs iicomma
in
2265 if need_unordered_initialisers ibs
2266 then initialisers_unordered2 allminus
ias_unsplit ibs_split >>=
2267 (fun ias_unsplit ibs_split ->
2269 split_icomma ias_unsplit,
2270 unsplit_initialiser ibs_split))
2273 and ar_initialisers
= fun ias
(ibs
, iicomma
) ->
2274 (* this doesn't check need_unordered_initialisers because ... can be
2275 implemented as ordered, even if it matches unordered initializers *)
2276 let ibs = resplit_initialiser ibs iicomma
in
2279 (List.map
(function (elem
,comma
) -> [Left elem
; Right
[comma
]]) ibs) in
2280 initialisers_ordered2 ias
ibs >>=
2281 (fun ias
ibs_split ->
2283 match List.rev
ibs_split with
2284 (Right comma
)::rest
-> (Ast_c.unsplit_comma
(List.rev rest
),comma
)
2285 | (Left _
)::_
-> (Ast_c.unsplit_comma
ibs_split,[]) (* possible *)
2287 return (ias
, (ibs,iicomma
)))
2289 and initialisers_ordered2
= fun ias
ibs ->
2291 match A.unwrap ea
with
2292 A.Idots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2294 let build_dots (mcode, optexpr
) = A.Idots
(mcode, optexpr
) in
2295 let match_comma ea
=
2296 match A.unwrap ea
with
2297 A.IComma ia1
-> Some ia1
2299 let build_comma ia1
= A.IComma ia1
in
2300 let match_metalist ea
= None
in
2301 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
2302 let mktermval v
= failwith
"not possible" in
2303 let special_cases ea
eas ebs
= None
in
2304 let no_ii x
= failwith
"not possible" in
2305 list_matcher match_dots build_dots match_comma build_comma
2306 match_metalist build_metalist mktermval
2307 special_cases initialiser
X.distrf_inis
no_ii ias
ibs
2310 and initialisers_unordered2
= fun allminus ias
ibs ->
2315 let rec loop = function
2316 [] -> return ([],[])
2317 | (ib
,comma
)::ibs ->
2318 X.distrf_ini
minusizer ib
>>= (fun _ ib
->
2319 tokenf minusizer comma
>>= (fun _ comma
->
2320 loop ibs >>= (fun l
ibs ->
2321 return(l
,(ib
,comma
)::ibs)))) in
2323 else return ([], ys
)
2325 let permut = Common.uncons_permut_lazy ys
in
2326 permut +> List.fold_left
(fun acc
((e
, pos
), rest
) ->
2328 (initialiser_comma x e
2330 let rest = Lazy.force
rest in
2331 initialisers_unordered2 allminus xs
rest >>= (fun xs
rest ->
2334 Common.insert_elem_pos
(e
, pos
) rest
2338 and initialiser_comma
(x
,xcomma
) (y
, commay
) =
2339 match A.unwrap xcomma
with
2341 tokenf commax commay
>>= (fun commax commay
->
2342 initialiser x y
>>= (fun x y
->
2344 (x
, (A.IComma commax
) +> A.rewrap xcomma
),
2346 | _
-> raise Impossible
(* unsplit_iicomma wrong *)
2348 (* ------------------------------------------------------------------------- *)
2349 and (struct_fields
: (A.declaration list
, B.field list
) matcher
) =
2352 match A.unwrap ea
with
2353 A.Ddots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2355 let build_dots (mcode, optexpr
) = A.Ddots
(mcode, optexpr
) in
2356 let match_comma ea
= None
in
2357 let build_comma ia1
= failwith
"not possible" in
2358 let match_metalist ea
= None
in
2359 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
2360 let mktermval v
= failwith
"not possible" in
2361 let special_cases ea
eas ebs
= None
in
2362 let no_ii x
= failwith
"not possible" in
2363 let make_ebs ebs
= List.map
(function x
-> Left x
) ebs
in
2364 let unmake_ebs ebs
=
2365 List.map
(function Left x
-> x
| Right x
-> failwith
"no right") ebs
in
2366 let distrf mcode startxs =
2367 let startxs = unmake_ebs startxs in
2368 X.distrf_struct_fields
mcode startxs >>=
2369 (fun mcode startxs -> return (mcode,make_ebs startxs)) in
2370 list_matcher match_dots build_dots match_comma build_comma
2371 match_metalist build_metalist mktermval
2372 special_cases struct_field
distrf no_ii eas (make_ebs ebs
) >>=
2373 (fun eas ebs
-> return (eas,unmake_ebs ebs
))
2375 and (struct_field
: (A.declaration
, B.field
) matcher
) = fun fa fb
->
2377 match A.unwrap fa
,fb
with
2378 | A.MetaField
(ida
,keep
,inherited
), _
->
2380 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_field fb
) in
2381 X.envf keep inherited
(ida
, Ast_c.MetaFieldVal fb
, max_min) (fun () ->
2382 X.distrf_field ida fb
2383 ) >>= (fun ida fb
->
2384 return ((A.MetaField
(ida
, keep
, inherited
))+> A.rewrap fa
,
2386 | _
,B.DeclarationField
(B.FieldDeclList
(onefield_multivars
,iiptvirg
)) ->
2388 let iiptvirgb = tuple_of_list1 iiptvirg
in
2390 (match onefield_multivars
with
2391 | [] -> raise Impossible
2392 | [onevar
,iivirg
] ->
2393 assert (null iivirg
);
2395 | B.BitField
(sopt
, typb
, _
, expr
) ->
2396 pr2_once
"warning: bitfield not handled by ast_cocci";
2398 | B.Simple
(None
, typb
) ->
2399 pr2_once
"warning: unamed struct field not handled by ast_cocci";
2401 | B.Simple
(Some nameidb
, typb
) ->
2403 (* build a declaration from a struct field *)
2404 let allminus = false in
2406 let stob = B.NoSto
, false in
2408 ({B.v_namei
= Some
(nameidb
, None
);
2411 B.v_local
= Ast_c.NotLocalDecl
;
2412 B.v_attr
= Ast_c.noattr
;
2413 B.v_type_bis
= ref None
;
2414 (* the struct field should also get expanded ? no it's not
2415 * important here, we will rematch very soon *)
2419 onedecl
allminus fa
(fake_var,iiptvirgb,iisto) >>=
2420 (fun fa
(var
,iiptvirgb,iisto) ->
2423 | ({B.v_namei
= Some
(nameidb
, None
);
2428 let onevar = B.Simple
(Some nameidb
, typb
) in
2432 ((B.DeclarationField
2433 (B.FieldDeclList
([onevar, iivirg
], [iiptvirgb])))
2436 | _
-> raise Impossible
2441 pr2_once
"PB: More that one variable in decl. Have to split";
2444 | _
,B.EmptyField _iifield
->
2447 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
),B.MacroDeclField
((sb
,ebs
),ii
) ->
2449 | _
,B.MacroDeclField
((sb
,ebs
),ii
) -> fail
2451 | _
,B.CppDirectiveStruct directive
-> fail
2452 | _
,B.IfdefStruct directive
-> fail
2455 and enum_fields
= fun eas ebs
->
2457 match A.unwrap ea
with
2458 A.Edots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2460 let build_dots (mcode, optexpr
) = A.Edots
(mcode, optexpr
) in
2461 let match_comma ea
=
2462 match A.unwrap ea
with
2463 A.EComma ia1
-> Some ia1
2465 let build_comma ia1
= A.EComma ia1
in
2466 let match_metalist ea
= None
in
2467 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
2468 let mktermval v
= failwith
"not possible" in
2469 let special_cases ea
eas ebs
= None
in
2470 list_matcher match_dots build_dots match_comma build_comma
2471 match_metalist build_metalist mktermval
2472 special_cases enum_field
X.distrf_enum_fields
2473 Lib_parsing_c.ii_of_enum_fields
eas ebs
2475 and enum_field ida idb
=
2476 X.all_bound
(A.get_inherited ida
) >&&>
2477 match A.unwrap ida
, idb
with
2478 A.Ident
(id
),(nameidb
,None
) ->
2479 ident_cpp DontKnow id nameidb
>>= (fun id nameidb
->
2480 return ((A.Ident id
) +> A.rewrap ida
, (nameidb
,None
)))
2481 | A.Assignment
(ea1
,opa
,ea2
,init
),(nameidb
,Some
(opbi,eb2
)) ->
2482 (match A.unwrap ea1
with
2484 ident_cpp DontKnow id nameidb
>>= (fun id nameidb
->
2485 expression ea2 eb2
>>= (fun ea2 eb2
->
2486 tokenf opa
opbi >>= (fun opa
opbi -> (* only one kind of assignop *)
2488 (A.Assignment
((A.Ident
(id
))+>A.rewrap ea1
,opa
,ea2
,init
)) +>
2490 (nameidb
,Some
(opbi,eb2
))))))
2491 | _
-> failwith
"not possible")
2492 | _
-> failwith
"not possible"
2494 (* ------------------------------------------------------------------------- *)
2495 and (fullType
: (A.fullType
, Ast_c.fullType
) matcher
) =
2497 X.optional_qualifier_flag
(fun optional_qualifier
->
2498 X.all_bound
(A.get_inherited typa
) >&&>
2499 match A.unwrap typa
, typb
with
2500 | A.Type
(cv
,ty1
), ((qu
,il
),ty2
) ->
2502 if qu
.B.const
&& qu
.B.volatile
2505 ("warning: the type is both const & volatile but cocci " ^
2506 "does not handle that");
2508 (* Drop out the const/volatile part that has been matched.
2509 * This is because a SP can contain const T v; in which case
2510 * later in match_t_t when we encounter a T, we must not add in
2511 * the environment the whole type.
2516 (* "iso-by-absence" *)
2519 fullTypebis ty1
((qu
,il
), ty2
) >>= (fun ty1 fullty2
->
2521 (A.Type
(None
, ty1
)) +> A.rewrap typa
,
2525 (match optional_qualifier
, qu
.B.const
|| qu
.B.volatile
with
2526 | false, false -> do_stuff ()
2527 | false, true -> fail
2528 | true, false -> do_stuff ()
2531 then pr2_once
"USING optional_qualifier builtin isomorphism";
2537 (* todo: can be __const__ ? can be const & volatile so
2538 * should filter instead ?
2540 (match term x
, il
with
2541 | A.Const
, [i1
] when qu
.B.const
->
2543 tokenf x i1
>>= (fun x i1
->
2544 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2546 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2550 | A.Volatile
, [i1
] when qu
.B.volatile
->
2551 tokenf x i1
>>= (fun x i1
->
2552 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2554 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2562 | A.DisjType typas
, typb
->
2564 List.fold_left
(fun acc typa
-> acc
>|+|> (fullType typa typb
)) fail
2566 | A.OptType
(_
), _
| A.UniqueType
(_
), _
2567 -> failwith
"not handling Opt/Unique on type"
2572 * Why not (A.typeC, Ast_c.typeC) matcher ?
2573 * because when there is MetaType, we want that T record the whole type,
2574 * including the qualifier, and so this type (and the new_il function in
2575 * preceding function).
2578 and (fullTypebis
: (A.typeC
, Ast_c.fullType
) matcher
) =
2580 X.all_bound
(A.get_inherited ta
) >&&>
2581 match A.unwrap ta
, tb
with
2584 | A.MetaType
(ida
,keep
, inherited
), typb
->
2586 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
2587 X.envf keep inherited
(ida
, B.MetaTypeVal typb
, max_min) (fun () ->
2588 X.distrf_type ida typb
>>= (fun ida typb
->
2590 A.MetaType
(ida
,keep
, inherited
) +> A.rewrap ta
,
2594 | unwrap
, (qub
, typb
) ->
2595 typeC ta typb
>>= (fun ta typb
->
2596 return (ta
, (qub
, typb
))
2599 and simulate_signed ta basea stringsa signaopt tb baseb ii rebuilda
=
2600 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2601 * And even if in baseb we have a Signed Int, that does not mean
2602 * that ii is of length 2, cos Signed is the default, so if in signa
2603 * we have Signed explicitely ? we cant "accrocher" this mcode to
2604 * something :( So for the moment when there is signed in cocci,
2605 * we force that there is a signed in c too (done in pattern.ml).
2607 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2610 (* handle some iso on type ? (cf complex C rule for possible implicit
2612 match basea
, baseb
with
2613 | A.VoidType
, B.Void
2614 | A.FloatType
, B.FloatType
(B.CFloat
)
2615 | A.DoubleType
, B.FloatType
(B.CDouble
)
2616 | A.SizeType
, B.SizeType
2617 | A.SSizeType
, B.SSizeType
2618 | A.PtrDiffType
,B.PtrDiffType
->
2619 assert (signaopt
=*= None
);
2620 let stringa = tuple_of_list1 stringsa
in
2621 let (ibaseb
) = tuple_of_list1 ii
in
2622 tokenf stringa ibaseb
>>= (fun stringa ibaseb
->
2624 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2625 (B.BaseType baseb
, [ibaseb
])
2628 | A.CharType
, B.IntType
B.CChar
when signaopt
=*= None
->
2629 let stringa = tuple_of_list1 stringsa
in
2630 let ibaseb = tuple_of_list1 ii
in
2631 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2633 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2634 (B.BaseType
(B.IntType
B.CChar
), [ibaseb])
2637 | A.CharType
,B.IntType
(B.Si
(_sign
, B.CChar2
)) when signaopt
<> None
->
2638 let stringa = tuple_of_list1 stringsa
in
2639 let ibaseb = tuple_of_list1 iibaseb
in
2640 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2641 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2643 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2644 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2647 | A.ShortType
, B.IntType
(B.Si
(_
, B.CShort
))
2648 | A.IntType
, B.IntType
(B.Si
(_
, B.CInt
))
2649 | A.LongType
, B.IntType
(B.Si
(_
, B.CLong
)) ->
2650 let stringa = tuple_of_list1 stringsa
in
2653 (* iso-by-presence ? *)
2654 (* when unsigned int in SP, allow have just unsigned in C ? *)
2655 if mcode_contain_plus (mcodekind stringa)
2659 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2661 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2662 (B.BaseType
(baseb
), iisignbopt
++ [])
2668 "warning: long int or short int not handled by ast_cocci";
2672 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2673 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2675 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2676 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2678 | _
-> raise Impossible
2683 | A.LongLongType
, B.IntType
(B.Si
(_
, B.CLongLong
)) ->
2684 let (string1a
,string2a
) = tuple_of_list2 stringsa
in
2686 [ibase1b
;ibase2b
] ->
2687 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2688 tokenf string1a ibase1b
>>= (fun base1a ibase1b
->
2689 tokenf string2a ibase2b
>>= (fun base2a ibase2b
->
2691 (rebuilda
([base1a
;base2a
], signaopt
)) +> A.rewrap ta
,
2692 (B.BaseType
(baseb
), iisignbopt
++ [ibase1b
;ibase2b
])
2694 | [] -> fail (* should something be done in this case? *)
2695 | _
-> raise Impossible
)
2698 | _
, B.FloatType
B.CLongDouble
2701 "warning: long double not handled by ast_cocci";
2704 | _
, (B.Void
|B.FloatType _
|B.IntType _
2705 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
2707 and simulate_signed_meta ta basea signaopt tb baseb ii rebuilda
=
2708 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2709 * And even if in baseb we have a Signed Int, that does not mean
2710 * that ii is of length 2, cos Signed is the default, so if in signa
2711 * we have Signed explicitely ? we cant "accrocher" this mcode to
2712 * something :( So for the moment when there is signed in cocci,
2713 * we force that there is a signed in c too (done in pattern.ml).
2715 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2717 let match_to_type rebaseb
=
2718 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2719 let fta = A.rewrap basea
(A.Type
(None
,basea
)) in
2720 let ftb = Ast_c.nQ
,(B.BaseType
(rebaseb
), iibaseb
) in
2721 fullType
fta ftb >>= (fun fta (_
,tb
) ->
2722 (match A.unwrap
fta,tb
with
2723 A.Type
(_
,basea
), (B.BaseType baseb
, ii
) ->
2725 (rebuilda
(basea
, signaopt
)) +> A.rewrap ta
,
2726 (B.BaseType
(baseb
), iisignbopt
++ ii
)
2728 | _
-> failwith
"not possible"))) in
2730 (* handle some iso on type ? (cf complex C rule for possible implicit
2733 | B.IntType
(B.Si
(_sign
, B.CChar2
)) ->
2734 match_to_type (B.IntType
B.CChar
)
2736 | B.IntType
(B.Si
(_
, ty
)) ->
2738 | [] -> fail (* metavariable has to match something *)
2740 | _
-> match_to_type (B.IntType
(B.Si
(B.Signed
, ty
)))
2744 | (B.Void
|B.FloatType _
|B.IntType _
2745 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
2747 and (typeC
: (A.typeC
, Ast_c.typeC
) matcher
) =
2749 match A.unwrap ta
, tb
with
2750 | A.BaseType
(basea
,stringsa
), (B.BaseType baseb
, ii
) ->
2751 simulate_signed ta basea stringsa None tb baseb ii
2752 (function (stringsa
, signaopt
) -> A.BaseType
(basea
,stringsa
))
2753 | A.SignedT
(signaopt
, Some basea
), (B.BaseType baseb
, ii
) ->
2754 (match A.unwrap basea
with
2755 A.BaseType
(basea1
,strings1
) ->
2756 simulate_signed ta basea1 strings1
(Some signaopt
) tb baseb ii
2757 (function (strings1
, Some signaopt
) ->
2760 Some
(A.rewrap basea
(A.BaseType
(basea1
,strings1
))))
2761 | _
-> failwith
"not possible")
2762 | A.MetaType
(ida
,keep
,inherited
) ->
2763 simulate_signed_meta ta basea
(Some signaopt
) tb baseb ii
2764 (function (basea
, Some signaopt
) ->
2765 A.SignedT
(signaopt
,Some basea
)
2766 | _
-> failwith
"not possible")
2767 | _
-> failwith
"not possible")
2768 | A.SignedT
(signa
,None
), (B.BaseType baseb
, ii
) ->
2769 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2770 (match iibaseb
, baseb
with
2771 | [], B.IntType
(B.Si
(_sign
, B.CInt
)) ->
2772 sign
(Some signa
) signbopt >>= (fun signaopt iisignbopt
->
2774 | None
-> raise Impossible
2777 (A.SignedT
(signa
,None
)) +> A.rewrap ta
,
2778 (B.BaseType baseb
, iisignbopt
)
2786 (* todo? iso with array *)
2787 | A.Pointer
(typa
, iamult
), (B.Pointer typb
, ii
) ->
2788 let (ibmult
) = tuple_of_list1 ii
in
2789 fullType typa typb
>>= (fun typa typb
->
2790 tokenf iamult ibmult
>>= (fun iamult ibmult
->
2792 (A.Pointer
(typa
, iamult
)) +> A.rewrap ta
,
2793 (B.Pointer typb
, [ibmult
])
2796 | A.FunctionType
(allminus,tyaopt
,lpa
,paramsa
,rpa
),
2797 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
) ->
2799 let (lpb
, rpb
) = tuple_of_list2 ii
in
2803 ("Not handling well variable length arguments func. "^
2804 "You have been warned");
2805 tokenf lpa lpb
>>= (fun lpa lpb
->
2806 tokenf rpa rpb
>>= (fun rpa rpb
->
2807 fullType_optional_allminus
allminus tyaopt tyb
>>= (fun tyaopt tyb
->
2808 parameters
(seqstyle paramsa
) (A.undots paramsa
) paramsb
>>=
2809 (fun paramsaundots paramsb
->
2810 let paramsa = redots
paramsa paramsaundots
in
2812 (A.FunctionType
(allminus,tyaopt
,lpa
,paramsa,rpa
) +> A.rewrap ta
,
2813 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), [lpb
;rpb
])
2821 | A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
),
2822 (B.ParenType t1
, ii
) ->
2823 let (lp1b
, rp1b
) = tuple_of_list2 ii
in
2824 let (qu1b
, t1b
) = t1
in
2826 | B.Pointer t2
, ii
->
2827 let (starb
) = tuple_of_list1 ii
in
2828 let (qu2b
, t2b
) = t2
in
2830 | B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
->
2831 let (lp2b
, rp2b
) = tuple_of_list2 ii
in
2836 ("Not handling well variable length arguments func. "^
2837 "You have been warned");
2839 fullType tya tyb
>>= (fun tya tyb
->
2840 tokenf lp1a lp1b
>>= (fun lp1a lp1b
->
2841 tokenf rp1a rp1b
>>= (fun rp1a rp1b
->
2842 tokenf lp2a lp2b
>>= (fun lp2a lp2b
->
2843 tokenf rp2a rp2b
>>= (fun rp2a rp2b
->
2844 tokenf stara starb
>>= (fun stara starb
->
2845 parameters
(seqstyle paramsa) (A.undots
paramsa) paramsb
>>=
2846 (fun paramsaundots paramsb
->
2847 let paramsa = redots
paramsa paramsaundots
in
2851 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))),
2856 (B.Pointer
t2, [starb
]))
2860 (A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
))
2862 (B.ParenType
t1, [lp1b
;rp1b
])
2875 (* todo: handle the iso on optionnal size specifification ? *)
2876 | A.Array
(typa
, ia1
, eaopt
, ia2
), (B.Array
(ebopt
, typb
), ii
) ->
2877 let (ib1, ib2
) = tuple_of_list2 ii
in
2878 fullType typa typb
>>= (fun typa typb
->
2879 option expression eaopt ebopt
>>= (fun eaopt ebopt
->
2880 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2881 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2883 (A.Array
(typa
, ia1
, eaopt
, ia2
)) +> A.rewrap ta
,
2884 (B.Array
(ebopt
, typb
), [ib1;ib2
])
2888 (* todo: could also match a Struct that has provided a name *)
2889 (* This is for the case where the SmPL code contains "struct x", without
2890 a definition. In this case, the name field is always present.
2891 This case is also called from the case for A.StructUnionDef when
2892 a name is present in the C code. *)
2893 | A.StructUnionName
(sua
, Some sa
), (B.StructUnionName
(sub
, sb
), ii
) ->
2894 (* sa is now an ident, not an mcode, old: ... && (term sa) =$= sb *)
2895 let (ib1, ib2
) = tuple_of_list2 ii
in
2896 if equal_structUnion (term sua
) sub
2898 ident DontKnow sa
(sb
, ib2
) >>= (fun sa
(sb
, ib2
) ->
2899 tokenf sua
ib1 >>= (fun sua
ib1 ->
2901 (A.StructUnionName
(sua
, Some sa
)) +> A.rewrap ta
,
2902 (B.StructUnionName
(sub
, sb
), [ib1;ib2
])
2907 | A.StructUnionDef
(ty
, lba
, declsa, rba
),
2908 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
2910 let (ii_sub_sb
, lbb
, rbb
) =
2912 [iisub
; lbb
; rbb
] -> (Common.Left iisub
,lbb
,rbb
)
2913 | [iisub
; iisb
; lbb
; rbb
] -> (Common.Right
(iisub
,iisb
),lbb
,rbb
)
2914 | _
-> failwith
"list of length 3 or 4 expected" in
2917 match (sbopt
,ii_sub_sb
) with
2918 (None
,Common.Left iisub
) ->
2919 (* the following doesn't reconstruct the complete SP code, just
2920 the part that matched *)
2922 match A.unwrap
s with
2924 (match A.unwrap ty
with
2925 A.StructUnionName
(sua
, None
) ->
2926 (match (term sua
, sub
) with
2928 | (A.Union
,B.Union
) -> return ((),())
2931 tokenf sua iisub
>>= (fun sua iisub
->
2934 A.StructUnionName
(sua
, None
) +> A.rewrap
ty)
2936 return (ty,[iisub
])))
2938 | A.DisjType
(disjs
) ->
2940 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
2944 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
2946 (* build a StructUnionName from a StructUnion *)
2947 let fake_su = B.nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) in
2949 fullType
ty fake_su >>= (fun ty fake_su ->
2951 | _nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) ->
2952 return (ty, [iisub
; iisb
])
2953 | _
-> raise Impossible
)
2957 >>= (fun ty ii_sub_sb
->
2959 tokenf lba lbb
>>= (fun lba lbb
->
2960 tokenf rba rbb
>>= (fun rba rbb
->
2961 struct_fields
(A.undots
declsa) declsb
>>=(fun undeclsa declsb
->
2962 let declsa = redots
declsa undeclsa
in
2965 (A.StructUnionDef
(ty, lba
, declsa, rba
)) +> A.rewrap ta
,
2966 (B.StructUnion
(sub
, sbopt
, declsb
),ii_sub_sb
@[lbb
;rbb
])
2970 (* todo? handle isomorphisms ? because Unsigned Int can be match on a
2971 * uint in the C code. But some CEs consists in renaming some types,
2972 * so we don't want apply isomorphisms every time.
2974 | A.TypeName sa
, (B.TypeName
(nameb
, typb
), noii
) ->
2978 | B.RegularName
(sb
, iidb
) ->
2979 let iidb1 = tuple_of_list1 iidb
in
2983 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
2985 (A.TypeName sa
) +> A.rewrap ta
,
2986 (B.TypeName
(B.RegularName
(sb
, [iidb1]), typb
), noii
)
2990 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
2995 | _
, (B.TypeOfExpr e
, ii
) -> fail
2996 | _
, (B.TypeOfType e
, ii
) -> fail
2998 | _
, (B.ParenType e
, ii
) -> fail (* todo ?*)
2999 | A.EnumName
(en
,Some namea
), (B.EnumName nameb
, ii
) ->
3000 let (ib1,ib2
) = tuple_of_list2 ii
in
3001 ident DontKnow namea
(nameb
, ib2
) >>= (fun namea
(nameb
, ib2
) ->
3002 tokenf en
ib1 >>= (fun en
ib1 ->
3004 (A.EnumName
(en
, Some namea
)) +> A.rewrap ta
,
3005 (B.EnumName nameb
, [ib1;ib2
])
3008 | A.EnumDef
(ty, lba
, idsa
, rba
),
3009 (B.Enum
(sbopt
, idsb
), ii
) ->
3011 let (ii_sub_sb
, lbb
, rbb
, comma_opt
) =
3013 [iisub
; lbb
; rbb
; comma_opt
] ->
3014 (Common.Left iisub
,lbb
,rbb
,comma_opt
)
3015 | [iisub
; iisb
; lbb
; rbb
; comma_opt
] ->
3016 (Common.Right
(iisub
,iisb
),lbb
,rbb
,comma_opt
)
3017 | _
-> failwith
"list of length 4 or 5 expected" in
3020 match (sbopt
,ii_sub_sb
) with
3021 (None
,Common.Left iisub
) ->
3022 (* the following doesn't reconstruct the complete SP code, just
3023 the part that matched *)
3025 match A.unwrap
s with
3027 (match A.unwrap
ty with
3028 A.EnumName
(sua
, None
) ->
3029 tokenf sua iisub
>>= (fun sua iisub
->
3031 A.Type
(None
,A.EnumName
(sua
, None
) +> A.rewrap
ty)
3033 return (ty,[iisub
]))
3035 | A.DisjType
(disjs
) ->
3037 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
3041 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
3043 (* build an EnumName from an Enum *)
3044 let fake_su = B.nQ
, (B.EnumName sb
, [iisub
;iisb
]) in
3046 fullType
ty fake_su >>= (fun ty fake_su ->
3048 | _nQ
, (B.EnumName sb
, [iisub
;iisb
]) ->
3049 return (ty, [iisub
; iisb
])
3050 | _
-> raise Impossible
)
3054 >>= (fun ty ii_sub_sb
->
3056 tokenf lba lbb
>>= (fun lba lbb
->
3057 tokenf rba rbb
>>= (fun rba rbb
->
3058 let idsb = resplit_initialiser idsb [comma_opt
] in
3062 (function (elem
,comma
) -> [Left elem
; Right
[comma
]])
3064 enum_fields
(A.undots idsa
) idsb >>= (fun unidsa
idsb ->
3065 let idsa = redots
idsa unidsa
in
3067 match List.rev
idsb with
3068 (Right comma
)::rest ->
3069 (Ast_c.unsplit_comma
(List.rev
rest),comma
)
3070 | (Left _
)::_
-> (Ast_c.unsplit_comma
idsb,[]) (* possible *)
3073 (A.EnumDef
(ty, lba
, idsa, rba
)) +> A.rewrap ta
,
3074 (B.Enum
(sbopt
, idsb),ii_sub_sb
@[lbb
;rbb
]@iicomma
)
3078 | _
, (B.Enum _
, _
) -> fail (* todo cocci ?*)
3081 ((B.TypeName _
| B.StructUnionName
(_
, _
) | B.EnumName _
|
3082 B.StructUnion
(_
, _
, _
) |
3083 B.FunctionType _
| B.Array
(_
, _
) | B.Pointer _
|
3089 (* todo: iso on sign, if not mentioned then free. tochange?
3090 * but that require to know if signed int because explicit
3091 * signed int, or because implicit signed int.
3094 and sign signa signb
=
3095 match signa
, signb
with
3096 | None
, None
-> return (None
, [])
3097 | Some signa
, Some
(signb
, ib
) ->
3098 if equal_sign (term signa
) signb
3099 then tokenf signa ib
>>= (fun signa ib
->
3100 return (Some signa
, [ib
])
3106 and minusize_list iixs
=
3107 iixs
+> List.fold_left
(fun acc ii
->
3108 acc
>>= (fun xs ys
->
3109 tokenf minusizer ii
>>= (fun minus ii
->
3110 return (minus
::xs
, ii
::ys
)
3111 ))) (return ([],[]))
3112 >>= (fun _xsminys ys
->
3113 return ((), List.rev ys
)
3116 and storage_optional_allminus
allminus stoa
(stob, iistob
) =
3117 (* "iso-by-absence" for storage, and return type. *)
3118 X.optional_storage_flag
(fun optional_storage
->
3119 match stoa
, stob with
3120 | None
, (stobis
, inline
) ->
3124 minusize_list iistob
>>= (fun () iistob
->
3125 return (None
, (stob, iistob
))
3127 else return (None
, (stob, iistob
))
3130 (match optional_storage
, stobis
with
3131 | false, B.NoSto
-> do_minus ()
3133 | true, B.NoSto
-> do_minus ()
3136 then pr2_once
"USING optional_storage builtin isomorphism";
3140 | Some x
, ((stobis
, inline
)) ->
3141 if equal_storage (term x
) stobis
3143 let rec loop acc
= function
3146 let str = B.str_of_info i1
in
3148 "static" | "extern" | "auto" | "register" ->
3149 (* not very elegant, but tokenf doesn't know what token to
3151 tokenf x i1
>>= (fun x i1
->
3152 let rebuilt = (List.rev acc
) @ i1
:: iistob
in
3153 return (Some x
, ((stobis
, inline
), rebuilt)))
3154 | _
-> loop (i1
::acc
) iistob
) in
3159 and inline_optional_allminus
allminus inla
(stob, iistob
) =
3160 (* "iso-by-absence" for storage, and return type. *)
3161 X.optional_storage_flag
(fun optional_storage
->
3162 match inla
, stob with
3163 | None
, (stobis
, inline
) ->
3167 minusize_list iistob
>>= (fun () iistob
->
3168 return (None
, (stob, iistob
))
3170 else return (None
, (stob, iistob
))
3179 then pr2_once
"USING optional_storage builtin isomorphism";
3182 else fail (* inline not in SP and present in C code *)
3185 | Some x
, ((stobis
, inline
)) ->
3188 let rec loop acc
= function
3191 let str = B.str_of_info i1
in
3194 (* not very elegant, but tokenf doesn't know what token to
3196 tokenf x i1
>>= (fun x i1
->
3197 let rebuilt = (List.rev acc
) @ i1
:: iistob
in
3198 return (Some x
, ((stobis
, inline
), rebuilt)))
3199 | _
-> loop (i1
::acc
) iistob
) in
3201 else fail (* SP has inline, but the C code does not *)
3204 and fullType_optional_allminus
allminus tya retb
=
3209 X.distrf_type
minusizer retb
>>= (fun _x retb
->
3213 else return (None
, retb
)
3215 fullType tya retb
>>= (fun tya retb
->
3216 return (Some tya
, retb
)
3221 (*---------------------------------------------------------------------------*)
3223 and compatible_base_type a signa b
=
3224 let ok = return ((),()) in
3227 | Type_cocci.VoidType
, B.Void
3228 | Type_cocci.SizeType
, B.SizeType
3229 | Type_cocci.SSizeType
, B.SSizeType
3230 | Type_cocci.PtrDiffType
, B.PtrDiffType
->
3231 assert (signa
=*= None
);
3233 | Type_cocci.CharType
, B.IntType
B.CChar
when signa
=*= None
->
3235 | Type_cocci.CharType
, B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3236 compatible_sign signa signb
3237 | Type_cocci.ShortType
, B.IntType
(B.Si
(signb
, B.CShort
)) ->
3238 compatible_sign signa signb
3239 | Type_cocci.IntType
, B.IntType
(B.Si
(signb
, B.CInt
)) ->
3240 compatible_sign signa signb
3241 | Type_cocci.LongType
, B.IntType
(B.Si
(signb
, B.CLong
)) ->
3242 compatible_sign signa signb
3243 | _
, B.IntType
(B.Si
(signb
, B.CLongLong
)) ->
3244 pr2_once
"no longlong in cocci";
3246 | Type_cocci.FloatType
, B.FloatType
B.CFloat
->
3247 assert (signa
=*= None
);
3249 | Type_cocci.DoubleType
, B.FloatType
B.CDouble
->
3250 assert (signa
=*= None
);
3252 | _
, B.FloatType
B.CLongDouble
->
3253 pr2_once
"no longdouble in cocci";
3255 | Type_cocci.BoolType
, _
-> failwith
"no booltype in C"
3257 | _
, (B.Void
|B.FloatType _
|B.IntType _
3258 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
3260 and compatible_base_type_meta a signa qua b ii
local =
3262 | Type_cocci.MetaType
(ida
,keep
,inherited
),
3263 B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3264 compatible_sign signa signb
>>= fun _ _
->
3265 let newb = ((qua
, (B.BaseType
(B.IntType
B.CChar
),ii
)),local) in
3266 compatible_type a
newb
3267 | Type_cocci.MetaType
(ida
,keep
,inherited
), B.IntType
(B.Si
(signb
, ty)) ->
3268 compatible_sign signa signb
>>= fun _ _
->
3270 ((qua
, (B.BaseType
(B.IntType
(B.Si
(B.Signed
, ty))),ii
)),local) in
3271 compatible_type a
newb
3272 | _
, B.FloatType
B.CLongDouble
->
3273 pr2_once
"no longdouble in cocci";
3276 | _
, (B.Void
|B.FloatType _
|B.IntType _
3277 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
3280 and compatible_type a
(b
,local) =
3281 let ok = return ((),()) in
3283 let rec loop = function
3284 | Type_cocci.BaseType a
, (qua
, (B.BaseType b
,ii
)) ->
3285 compatible_base_type a None b
3287 | Type_cocci.SignedT
(signa
,None
), (qua
, (B.BaseType b
,ii
)) ->
3288 compatible_base_type
Type_cocci.IntType
(Some signa
) b
3290 | Type_cocci.SignedT
(signa
,Some
ty), (qua
, (B.BaseType b
,ii
)) ->
3292 Type_cocci.BaseType
ty ->
3293 compatible_base_type
ty (Some signa
) b
3294 | Type_cocci.MetaType
(ida
,keep
,inherited
) ->
3295 compatible_base_type_meta
ty (Some signa
) qua b ii
local
3296 | _
-> failwith
"not possible")
3298 | Type_cocci.Pointer a
, (qub
, (B.Pointer b
, ii
)) ->
3300 | Type_cocci.FunctionPointer a
, _
->
3302 "TODO: function pointer type doesn't store enough information to determine compatability"
3303 | Type_cocci.Array a
, (qub
, (B.Array
(eopt
, b
),ii
)) ->
3304 (* no size info for cocci *)
3306 | Type_cocci.StructUnionName
(sua
, name
),
3307 (qub
, (B.StructUnionName
(sub
, sb
),ii
)) ->
3308 if equal_structUnion_type_cocci sua sub
3309 then structure_type_name name sb ii
3311 | Type_cocci.EnumName
(name
),
3312 (qub
, (B.EnumName
(sb
),ii
)) -> structure_type_name name sb ii
3313 | Type_cocci.TypeName sa
, (qub
, (B.TypeName
(namesb
, _typb
),noii
)) ->
3314 let sb = Ast_c.str_of_name namesb
in
3319 | Type_cocci.ConstVol
(qua
, a
), (qub
, b
) ->
3320 if (fst qub
).B.const
&& (fst qub
).B.volatile
3323 pr2_once
("warning: the type is both const & volatile but cocci " ^
3324 "does not handle that");
3330 | Type_cocci.Const
-> (fst qub
).B.const
3331 | Type_cocci.Volatile
-> (fst qub
).B.volatile
3333 then loop (a
,(Ast_c.nQ
, b
))
3336 | Type_cocci.MetaType
(ida
,keep
,inherited
), typb
->
3338 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
3339 X.envf keep inherited
(A.make_mcode ida
, B.MetaTypeVal typb
, max_min)
3343 (* subtil: must be after the MetaType case *)
3344 | a
, (qub
, (B.TypeName
(_namesb
, Some b
), noii
)) ->
3345 (* kind of typedef iso *)
3348 (* for metavariables of type expression *^* *)
3349 | Type_cocci.Unknown
, _
-> ok
3354 B.TypeOfType _
|B.TypeOfExpr _
|B.ParenType _
|
3355 B.EnumName _
|B.StructUnion
(_
, _
, _
)|B.Enum
(_
, _
)
3362 B.StructUnionName
(_
, _
)|
3364 B.Array
(_
, _
)|B.Pointer _
|B.TypeName _
|
3369 and structure_type_name nm
sb ii
=
3371 Type_cocci.NoName
-> ok
3372 | Type_cocci.Name sa
->
3376 | Type_cocci.MV
(ida
,keep
,inherited
) ->
3377 (* degenerate version of MetaId, no transformation possible *)
3378 let (ib1, ib2
) = tuple_of_list2 ii
in
3379 let max_min _
= Lib_parsing_c.lin_col_by_pos
[ib2
] in
3380 let mida = A.make_mcode ida
in
3381 X.envf keep inherited
(mida, B.MetaIdVal
(sb,[]), max_min)
3387 and compatible_sign signa signb
=
3388 let ok = return ((),()) in
3389 match signa
, signb
with
3391 | Some
Type_cocci.Signed
, B.Signed
3392 | Some
Type_cocci.Unsigned
, B.UnSigned
3397 and equal_structUnion_type_cocci a b
=
3399 | Type_cocci.Struct
, B.Struct
-> true
3400 | Type_cocci.Union
, B.Union
-> true
3401 | _
, (B.Struct
| B.Union
) -> false
3405 (*---------------------------------------------------------------------------*)
3406 and inc_file
(a
, before_after
) (b
, h_rel_pos
) =
3408 let rec aux_inc (ass
, bss
) passed
=
3412 let passed = List.rev
passed in
3414 (match before_after
, !h_rel_pos
with
3415 | IncludeNothing
, _
-> true
3416 | IncludeMcodeBefore
, Some x
->
3417 List.mem
passed (x
.Ast_c.first_of
)
3419 | IncludeMcodeAfter
, Some x
->
3420 List.mem
passed (x
.Ast_c.last_of
)
3422 (* no info, maybe cos of a #include <xx.h> that was already in a .h *)
3426 | (A.IncPath x
)::xs
, y
::ys
-> x
=$
= y
&& aux_inc (xs
, ys
) (x
::passed)
3427 | _
-> failwith
"IncDots not in last place or other pb"
3432 | A.Local ass
, B.Local bss
->
3433 aux_inc (ass
, bss
) []
3434 | A.NonLocal ass
, B.NonLocal bss
->
3435 aux_inc (ass
, bss
) []
3440 (*---------------------------------------------------------------------------*)
3442 and (define_params
: sequence
->
3443 (A.define_param list
, (string B.wrap
) B.wrap2 list
) matcher
) =
3444 fun seqstyle eas ebs
->
3446 | Unordered
-> failwith
"not handling ooo"
3448 define_paramsbis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
3449 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
3452 (* todo? facto code with argument and parameters ? *)
3453 and define_paramsbis
= fun eas ebs
->
3455 match A.unwrap ea
with
3456 A.DPdots
(mcode) -> Some
(mcode, None
)
3458 let build_dots (mcode, _optexpr
) = A.DPdots
(mcode) in
3459 let match_comma ea
=
3460 match A.unwrap ea
with
3461 A.DPComma ia1
-> Some ia1
3463 let build_comma ia1
= A.DPComma ia1
in
3464 let match_metalist ea
= None
in
3465 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
3466 let mktermval v
= failwith
"not possible" in
3467 let special_cases ea
eas ebs
= None
in
3468 let no_ii x
= failwith
"not possible" in
3469 list_matcher match_dots build_dots match_comma build_comma
3470 match_metalist build_metalist mktermval
3471 special_cases define_parameter
X.distrf_define_params
no_ii eas ebs
3473 and define_parameter
= fun parama paramb
->
3474 match A.unwrap parama
, paramb
with
3475 A.DParam ida
, (idb
, ii
) ->
3476 let ib1 = tuple_of_list1 ii
in
3477 ident DontKnow ida
(idb
, ib1) >>= (fun ida
(idb
, ib1) ->
3478 return ((A.DParam ida
)+> A.rewrap parama
,(idb
, [ib1])))
3479 | (A.OptDParam _
| A.UniqueDParam _
), _
->
3480 failwith
"handling Opt/Unique for define parameters"
3481 | A.DPcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
3484 (*****************************************************************************)
3486 (*****************************************************************************)
3488 (* no global solution for positions here, because for a statement metavariable
3489 we want a MetaStmtVal, and for the others, it's not clear what we want *)
3491 let rec (rule_elem_node
: (A.rule_elem
, Control_flow_c.node
) matcher
) =
3494 x
>>= (fun a b
-> return (A.rewrap re a
, F.rewrap node b
))
3496 X.all_bound
(A.get_inherited re
) >&&>
3499 match A.unwrap re
, F.unwrap node
with
3501 (* note: the order of the clauses is important. *)
3503 | _
, F.Enter
| _
, F.Exit
| _
, F.ErrorExit
-> fail2()
3505 (* the metaRuleElem contains just '-' information. We dont need to add
3506 * stuff in the environment. If we need stuff in environment, because
3507 * there is a + S somewhere, then this will be done via MetaStmt, not
3509 * Can match TrueNode/FalseNode/... so must be placed before those cases.
3512 | A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
->
3513 let default = A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
in
3514 (match unwrap_node
with
3516 | F.TrueNode
| F.FalseNode
| F.AfterNode
3517 | F.LoopFallThroughNode
| F.FallThroughNode
3519 if X.mode
=*= PatternMode
3522 if mcode_contain_plus (mcodekind mcode)
3523 then failwith
"try add stuff on fake node"
3524 (* minusize or contextize a fake node is ok *)
3527 | F.EndStatement None
->
3528 if X.mode
=*= PatternMode
then return default
3530 (* DEAD CODE NOW ? only useful in -no_cocci_vs_c_3 ?
3531 if mcode_contain_plus (mcodekind mcode)
3533 let fake_info = Ast_c.fakeInfo() in
3534 distrf distrf_node (mcodekind mcode)
3535 (F.EndStatement (Some fake_info))
3536 else return unwrap_node
3540 | F.EndStatement
(Some i1
) ->
3541 tokenf mcode i1
>>= (fun mcode i1
->
3543 A.MetaRuleElem
(mcode,keep
, inherited
),
3544 F.EndStatement
(Some i1
)
3548 if X.mode
=*= PatternMode
then return default
3549 else failwith
"a MetaRuleElem can't transform a headfunc"
3551 if X.mode
=*= PatternMode
then return default
3553 X.distrf_node
(generalize_mcode mcode) node
>>= (fun mcode node
->
3555 A.MetaRuleElem
(mcode,keep
, inherited
),
3561 (* rene cant have found that a state containing a fake/exit/... should be
3563 * TODO: and F.Fake ?
3565 | _
, F.EndStatement _
| _
, F.CaseNode _
3566 | _
, F.TrueNode
| _
, F.FalseNode
| _
, F.AfterNode
3567 | _
, F.FallThroughNode
| _
, F.LoopFallThroughNode
3571 (* really ? diff between pattern.ml and transformation.ml *)
3572 | _
, F.Fake
-> fail2()
3575 (* cas general: a Meta can match everything. It matches only
3576 * "header"-statement. We transform only MetaRuleElem, not MetaStmt.
3577 * So can't have been called in transform.
3579 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), F.Decl
(_
) -> fail
3581 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), unwrap_node
->
3582 (* todo: should not happen in transform mode *)
3584 (match Control_flow_c.extract_fullstatement node
with
3587 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_stmt stb
) in
3588 X.envf keep inherited
(ida
, Ast_c.MetaStmtVal stb
, max_min)
3590 (* no need tag ida, we can't be called in transform-mode *)
3592 A.MetaStmt
(ida
, keep
, metainfoMaybeTodo
, inherited
),
3600 | A.MetaStmtList _
, _
->
3601 failwith
"not handling MetaStmtList"
3603 | A.TopExp ea
, F.DefineExpr eb
->
3604 expression ea eb
>>= (fun ea eb
->
3610 | A.TopExp ea
, F.DefineType eb
->
3611 (match A.unwrap ea
with
3613 fullType ft eb
>>= (fun ft eb
->
3615 A.TopExp
(A.rewrap ea
(A.TypeExp
(ft
))),
3622 (* It is important to put this case before the one that fails because
3623 * of the lack of the counter part of a C construct in SmPL (for instance
3624 * there is not yet a CaseRange in SmPL). Even if SmPL don't handle
3625 * yet certain constructs, those constructs may contain expression
3626 * that we still want and can transform.
3629 | A.Exp exp
, nodeb
->
3631 (* kind of iso, initialisation vs affectation *)
3633 match A.unwrap exp
, nodeb
with
3634 | A.Assignment
(ea
, op
, eb
, true), F.Decl decl
->
3635 initialisation_to_affectation decl
+> F.rewrap node
3640 (* Now keep fullstatement inside the control flow node,
3641 * so that can then get in a MetaStmtVar the fullstatement to later
3642 * pp back when the S is in a +. But that means that
3643 * Exp will match an Ifnode even if there is no such exp
3644 * inside the condition of the Ifnode (because the exp may
3645 * be deeper, in the then branch). So have to not visit
3646 * all inside a node anymore.
3648 * update: j'ai choisi d'accrocher au noeud du CFG Ã la
3649 * fois le fullstatement et le partialstatement et appeler le
3650 * visiteur que sur le partialstatement.
3653 match Ast_cocci.get_pos re
with
3654 | None
-> expression
3658 Lib_parsing_c.max_min_by_pos
(Lib_parsing_c.ii_of_expr eb
) in
3659 let keep = Type_cocci.Unitary
in
3660 let inherited = false in
3661 let max_min _
= failwith
"no pos" in
3662 X.envf
keep inherited (pos
, B.MetaPosVal
(min
,max
), max_min)
3668 X.cocciExp
expfn exp
node >>= (fun exp
node ->
3676 X.cocciTy fullType
ty node >>= (fun ty node ->
3683 | A.TopInit init
, nodeb
->
3684 X.cocciInit initialiser init
node >>= (fun init
node ->
3692 | A.FunHeader
(mckstart
, allminus, fninfoa
, ida
, oparen
, paramsa, cparen
),
3693 F.FunHeader
({B.f_name
= nameidb
;
3694 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3698 f_old_c_style
= oldstyle
;
3703 then pr2 "OLD STYLE DECL NOT WELL SUPPORTED";
3706 (* fninfoa records the order in which the SP specified the various
3707 information, but this isn't taken into account in the matching.
3708 Could this be a problem for transformation? *)
3711 List.filter
(function A.FStorage
(s) -> true | _
-> false) fninfoa
3712 with [A.FStorage
(s)] -> Some
s | _
-> None
in
3714 match List.filter
(function A.FType
(s) -> true | _
-> false) fninfoa
3715 with [A.FType
(t
)] -> Some t
| _
-> None
in
3718 match List.filter
(function A.FInline
(i
) -> true | _
-> false) fninfoa
3719 with [A.FInline
(i
)] -> Some i
| _
-> None
in
3721 (match List.filter
(function A.FAttr
(a
) -> true | _
-> false) fninfoa
3722 with [A.FAttr
(a
)] -> failwith
"not checking attributes" | _
-> ());
3725 | ioparenb
::icparenb
::iifakestart
::iistob
->
3727 (* maybe important to put ident as the first tokens to transform.
3728 * It's related to transform_proto. So don't change order
3731 ident_cpp LocalFunction ida nameidb
>>= (fun ida nameidb
->
3732 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
3733 tokenf oparen ioparenb
>>= (fun oparen ioparenb
->
3734 tokenf cparen icparenb
>>= (fun cparen icparenb
->
3735 parameters
(seqstyle paramsa)
3736 (A.undots
paramsa) paramsb
>>=
3737 (fun paramsaundots paramsb
->
3738 let paramsa = redots
paramsa paramsaundots
in
3739 inline_optional_allminus
allminus
3740 inla (stob, iistob
) >>= (fun inla (stob, iistob
) ->
3741 storage_optional_allminus
allminus
3742 stoa (stob, iistob
) >>= (fun stoa (stob, iistob
) ->
3747 ("Not handling well variable length arguments func. "^
3748 "You have been warned");
3750 then minusize_list iidotsb
3751 else return ((),iidotsb
)
3752 ) >>= (fun () iidotsb
->
3754 fullType_optional_allminus
allminus tya retb
>>= (fun tya retb
->
3757 (match stoa with Some st
-> [A.FStorage st
] | None
-> []) ++
3758 (match inla with Some i
-> [A.FInline i
] | None
-> []) ++
3759 (match tya with Some t
-> [A.FType t
] | None
-> [])
3764 A.FunHeader
(mckstart
,allminus,fninfoa,ida
,oparen
,
3766 F.FunHeader
({B.f_name
= nameidb
;
3767 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3771 f_old_c_style
= oldstyle
; (* TODO *)
3773 ioparenb
::icparenb
::iifakestart
::iistob
)
3776 | _
-> raise Impossible
3784 | A.Decl
(mckstart
,allminus,decla
), F.Decl declb
->
3785 declaration
(mckstart
,allminus,decla
) declb
>>=
3786 (fun (mckstart
,allminus,decla
) declb
->
3788 A.Decl
(mckstart
,allminus,decla
),
3793 | A.SeqStart
mcode, F.SeqStart
(st
, level
, i1
) ->
3794 tokenf mcode i1
>>= (fun mcode i1
->
3797 F.SeqStart
(st
, level
, i1
)
3800 | A.SeqEnd
mcode, F.SeqEnd
(level
, i1
) ->
3801 tokenf mcode i1
>>= (fun mcode i1
->
3804 F.SeqEnd
(level
, i1
)
3807 | A.ExprStatement
(ea
, ia1
), F.ExprStatement
(st
, (Some eb
, ii
)) ->
3808 let ib1 = tuple_of_list1 ii
in
3809 expression ea eb
>>= (fun ea eb
->
3810 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3812 A.ExprStatement
(ea
, ia1
),
3813 F.ExprStatement
(st
, (Some eb
, [ib1]))
3818 | A.IfHeader
(ia1
,ia2
, ea
, ia3
), F.IfHeader
(st
, (eb
,ii
)) ->
3819 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3820 expression ea eb
>>= (fun ea eb
->
3821 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3822 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3823 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3825 A.IfHeader
(ia1
, ia2
, ea
, ia3
),
3826 F.IfHeader
(st
, (eb
,[ib1;ib2
;ib3
]))
3829 | A.Else ia
, F.Else ib
->
3830 tokenf ia ib
>>= (fun ia ib
->
3831 return (A.Else ia
, F.Else ib
)
3834 | A.WhileHeader
(ia1
, ia2
, ea
, ia3
), F.WhileHeader
(st
, (eb
, ii
)) ->
3835 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3836 expression ea eb
>>= (fun ea eb
->
3837 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3838 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3839 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3841 A.WhileHeader
(ia1
, ia2
, ea
, ia3
),
3842 F.WhileHeader
(st
, (eb
, [ib1;ib2
;ib3
]))
3845 | A.DoHeader ia
, F.DoHeader
(st
, ib
) ->
3846 tokenf ia ib
>>= (fun ia ib
->
3851 | A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
), F.DoWhileTail
(eb
, ii
) ->
3852 let (ib1, ib2
, ib3
, ib4
) = tuple_of_list4 ii
in
3853 expression ea eb
>>= (fun ea eb
->
3854 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3855 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3856 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3857 tokenf ia4 ib4
>>= (fun ia4 ib4
->
3859 A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
),
3860 F.DoWhileTail
(eb
, [ib1;ib2
;ib3
;ib4
])
3862 | A.IteratorHeader
(ia1
, ia2
, eas, ia3
), F.MacroIterHeader
(st
, ((s,ebs
),ii
))
3864 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3866 ident DontKnow ia1
(s, ib1) >>= (fun ia1
(s, ib1) ->
3867 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3868 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3869 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
3870 let eas = redots
eas easundots
in
3872 A.IteratorHeader
(ia1
, ia2
, eas, ia3
),
3873 F.MacroIterHeader
(st
, ((s,ebs
), [ib1;ib2
;ib3
]))
3878 | A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3879 F.ForHeader
(st
, (((eb1opt
,ib3s
), (eb2opt
,ib4s
), (eb3opt
,ib4vide
)), ii
))
3881 assert (null ib4vide
);
3882 let (ib1, ib2
, ib5
) = tuple_of_list3 ii
in
3883 let ib3 = tuple_of_list1 ib3s
in
3884 let ib4 = tuple_of_list1 ib4s
in
3886 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3887 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3888 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3889 tokenf ia4
ib4 >>= (fun ia4
ib4 ->
3890 tokenf ia5 ib5
>>= (fun ia5 ib5
->
3891 option expression ea1opt eb1opt
>>= (fun ea1opt eb1opt
->
3892 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
3893 option expression ea3opt eb3opt
>>= (fun ea3opt eb3opt
->
3895 A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3896 F.ForHeader
(st
, (((eb1opt
,[ib3]), (eb2opt
,[ib4]), (eb3opt
,[])),
3902 | A.SwitchHeader
(ia1
,ia2
,ea
,ia3
), F.SwitchHeader
(st
, (eb
,ii
)) ->
3903 let (ib1, ib2
, ib3) = tuple_of_list3 ii
in
3904 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3905 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3906 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3907 expression ea eb
>>= (fun ea eb
->
3909 A.SwitchHeader
(ia1
,ia2
,ea
,ia3
),
3910 F.SwitchHeader
(st
, (eb
,[ib1;ib2
;ib3]))
3913 | A.Break
(ia1
, ia2
), F.Break
(st
, ((),ii
)) ->
3914 let (ib1, ib2
) = tuple_of_list2 ii
in
3915 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3916 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3919 F.Break
(st
, ((),[ib1;ib2
]))
3922 | A.Continue
(ia1
, ia2
), F.Continue
(st
, ((),ii
)) ->
3923 let (ib1, ib2
) = tuple_of_list2 ii
in
3924 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3925 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3927 A.Continue
(ia1
, ia2
),
3928 F.Continue
(st
, ((),[ib1;ib2
]))
3931 | A.Return
(ia1
, ia2
), F.Return
(st
, ((),ii
)) ->
3932 let (ib1, ib2
) = tuple_of_list2 ii
in
3933 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3934 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3936 A.Return
(ia1
, ia2
),
3937 F.Return
(st
, ((),[ib1;ib2
]))
3940 | A.ReturnExpr
(ia1
, ea
, ia2
), F.ReturnExpr
(st
, (eb
, ii
)) ->
3941 let (ib1, ib2
) = tuple_of_list2 ii
in
3942 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3943 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3944 expression ea eb
>>= (fun ea eb
->
3946 A.ReturnExpr
(ia1
, ea
, ia2
),
3947 F.ReturnExpr
(st
, (eb
, [ib1;ib2
]))
3952 | A.Include
(incla
,filea
),
3953 F.Include
{B.i_include
= (fileb
, ii
);
3954 B.i_rel_pos
= h_rel_pos
;
3955 B.i_is_in_ifdef
= inifdef
;
3958 assert (copt
=*= None
);
3960 let include_requirment =
3961 match mcodekind incla
, mcodekind filea
with
3962 | A.CONTEXT
(_
, A.BEFORE _
), _
->
3964 | _
, A.CONTEXT
(_
, A.AFTER _
) ->
3970 let (inclb
, iifileb
) = tuple_of_list2 ii
in
3971 if inc_file
(term filea
, include_requirment) (fileb
, h_rel_pos
)
3973 tokenf incla inclb
>>= (fun incla inclb
->
3974 tokenf filea iifileb
>>= (fun filea iifileb
->
3976 A.Include
(incla
, filea
),
3977 F.Include
{B.i_include
= (fileb
, [inclb
;iifileb
]);
3978 B.i_rel_pos
= h_rel_pos
;
3979 B.i_is_in_ifdef
= inifdef
;
3987 | A.DefineHeader
(definea
,ida
,params
), F.DefineHeader
((idb
, ii
), defkind
) ->
3988 let (defineb
, iidb
, ieol
) = tuple_of_list3 ii
in
3989 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
3990 tokenf definea defineb
>>= (fun definea defineb
->
3991 (match A.unwrap params
, defkind
with
3992 | A.NoParams
, B.DefineVar
->
3994 A.NoParams
+> A.rewrap params
,
3997 | A.DParams
(lpa
,eas,rpa
), (B.DefineFunc
(ebs
, ii
)) ->
3998 let (lpb
, rpb
) = tuple_of_list2 ii
in
3999 tokenf lpa lpb
>>= (fun lpa lpb
->
4000 tokenf rpa rpb
>>= (fun rpa rpb
->
4002 define_params
(seqstyle eas) (A.undots
eas) ebs
>>=
4003 (fun easundots ebs
->
4004 let eas = redots
eas easundots
in
4006 A.DParams
(lpa
,eas,rpa
) +> A.rewrap params
,
4007 B.DefineFunc
(ebs
,[lpb
;rpb
])
4011 ) >>= (fun params defkind
->
4013 A.DefineHeader
(definea
, ida
, params
),
4014 F.DefineHeader
((idb
,[defineb
;iidb
;ieol
]),defkind
)
4019 | A.Default
(def
,colon
), F.Default
(st
, ((),ii
)) ->
4020 let (ib1, ib2
) = tuple_of_list2 ii
in
4021 tokenf def
ib1 >>= (fun def
ib1 ->
4022 tokenf colon ib2
>>= (fun colon ib2
->
4024 A.Default
(def
,colon
),
4025 F.Default
(st
, ((),[ib1;ib2
]))
4030 | A.Case
(case
,ea
,colon
), F.Case
(st
, (eb
,ii
)) ->
4031 let (ib1, ib2
) = tuple_of_list2 ii
in
4032 tokenf case
ib1 >>= (fun case
ib1 ->
4033 expression ea eb
>>= (fun ea eb
->
4034 tokenf colon ib2
>>= (fun colon ib2
->
4036 A.Case
(case
,ea
,colon
),
4037 F.Case
(st
, (eb
,[ib1;ib2
]))
4040 (* only occurs in the predicates generated by asttomember *)
4041 | A.DisjRuleElem
eas, _
->
4043 List.fold_left
(fun acc ea
-> acc
>|+|> (rule_elem_node ea
node)) fail)
4044 >>= (fun ea eb
-> return (A.unwrap ea
,F.unwrap eb
))
4046 | _
, F.ExprStatement
(_
, (None
, ii
)) -> fail (* happen ? *)
4048 | A.Label
(id
,dd
), F.Label
(st
, nameb
, ((),ii
)) ->
4049 let (ib2
) = tuple_of_list1 ii
in
4050 ident_cpp DontKnow id nameb
>>= (fun ida nameb
->
4051 tokenf dd ib2
>>= (fun dd ib2
->
4054 F.Label
(st
,nameb
, ((),[ib2
]))
4057 | A.Goto
(goto
,id
,sem
), F.Goto
(st
,nameb
, ((),ii
)) ->
4058 let (ib1,ib3) = tuple_of_list2 ii
in
4059 tokenf goto
ib1 >>= (fun goto
ib1 ->
4060 ident_cpp DontKnow id nameb
>>= (fun id nameb
->
4061 tokenf sem
ib3 >>= (fun sem
ib3 ->
4063 A.Goto
(goto
,id
,sem
),
4064 F.Goto
(st
,nameb
, ((),[ib1;ib3]))
4067 (* have not a counter part in coccinelle, for the moment *)
4068 (* todo?: print a warning at least ? *)
4074 | _
, (F.IfdefEndif _
|F.IfdefElse _
|F.IfdefHeader _
)
4078 (F.MacroStmt
(_
, _
)| F.DefineDoWhileZeroHeader _
| F.EndNode
|F.TopNode
)
4081 (F.Label
(_
, _
, _
)|F.Break
(_
, _
)|F.Continue
(_
, _
)|F.Default
(_
, _
)|
4082 F.Case
(_
, _
)|F.Include _
|F.Goto _
|F.ExprStatement _
|
4083 F.DefineType _
|F.DefineExpr _
|F.DefineTodo
|
4084 F.DefineHeader
(_
, _
)|F.ReturnExpr
(_
, _
)|F.Return
(_
, _
)|F.MacroIterHeader
(_
, _
)|
4085 F.SwitchHeader
(_
, _
)|F.ForHeader
(_
, _
)|F.DoWhileTail _
|F.DoHeader
(_
, _
)|
4086 F.WhileHeader
(_
, _
)|F.Else _
|F.IfHeader
(_
, _
)|
4087 F.SeqEnd
(_
, _
)|F.SeqStart
(_
, _
, _
)|
4088 F.Decl _
|F.FunHeader _
)