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.
30 module F
= Control_flow_c
32 module Flag
= Flag_matcher
34 (*****************************************************************************)
36 (*****************************************************************************)
37 let pr2, pr2_once
= Common.mk_pr2_wrappers
Flag_matcher.verbose_matcher
39 let (+++) a b
= match a
with Some x
-> Some x
| None
-> b
41 (*****************************************************************************)
43 (*****************************************************************************)
45 type sequence
= Ordered
| Unordered
48 match A.unwrap eas
with
50 | A.CIRCLES _
-> Unordered
51 | A.STARS _
-> failwith
"not handling stars"
53 let (redots
: 'a
A.dots
-> 'a list
-> 'a
A.dots
)=fun eas easundots
->
55 match A.unwrap eas
with
56 | A.DOTS _
-> A.DOTS easundots
57 | A.CIRCLES _
-> A.CIRCLES easundots
58 | A.STARS _
-> A.STARS easundots
62 let (need_unordered_initialisers
: B.initialiser
B.wrap2 list
-> bool) =
64 ibs
+> List.exists
(fun (ib
, icomma
) ->
65 match B.unwrap ib
with
74 (* For the #include <linux/...> in the .cocci, need to find where is
75 * the '+' attached to this element, to later find the first concrete
76 * #include <linux/xxx.h> or last one in the series of #includes in the
79 type include_requirement
=
86 (* todo? put in semantic_c.ml *)
89 | LocalFunction
(* entails Function *)
93 let term mc
= A.unwrap_mcode mc
94 let mcodekind mc
= A.get_mcodekind mc
97 let mcode_contain_plus = function
98 | A.CONTEXT
(_
,A.NOTHING
) -> false
100 | A.MINUS
(_
,_
,_
,[]) -> false
101 | A.MINUS
(_
,_
,_
,x
::xs
) -> true
102 | A.PLUS _
-> raise Impossible
104 let mcode_simple_minus = function
105 | A.MINUS
(_
,_
,_
,[]) -> true
109 (* In transformation.ml sometime I build some mcodekind myself and
110 * julia has put None for the pos. But there is no possible raise
111 * NoMatch in those cases because it is for the minusall trick or for
112 * the distribute, so either have to build those pos, in fact a range,
113 * because for the distribute have to erase a fullType with one
114 * mcodekind, or add an argument to tag_with_mck such as "safe" that
115 * don't do the check_pos. Hence this DontCarePos constructor. *)
119 {A.line
= 0; A.column
=0; A.strbef
=[]; A.straft
=[];},
120 (A.MINUS
(A.DontCarePos
,[],-1,[])),
123 let generalize_mcode ia
=
124 let (s1
, i
, mck
, pos
) = ia
in
127 | A.PLUS _
-> raise Impossible
128 | A.CONTEXT
(A.NoPos
,x
) ->
129 A.CONTEXT
(A.DontCarePos
,x
)
130 | A.MINUS
(A.NoPos
,inst
,adj
,x
) ->
131 A.MINUS
(A.DontCarePos
,inst
,adj
,x
)
133 | A.CONTEXT
((A.FixPos _
|A.DontCarePos
), _
)
134 | A.MINUS
((A.FixPos _
|A.DontCarePos
), _
, _
, _
)
138 (s1
, i
, new_mck, pos
)
142 (*---------------------------------------------------------------------------*)
144 (* 0x0 is equivalent to 0, value format isomorphism *)
145 let equal_c_int s1 s2
=
147 int_of_string s1
=|= int_of_string s2
148 with Failure
("int_of_string") ->
153 (*---------------------------------------------------------------------------*)
154 (* Normally A should reuse some types of Ast_c, so those
155 * functions should not exist.
157 * update: but now Ast_c depends on A, so can't make too
158 * A depends on Ast_c, so have to stay with those equal_xxx
162 let equal_unaryOp a b
=
164 | A.GetRef
, B.GetRef
-> true
165 | A.DeRef
, B.DeRef
-> true
166 | A.UnPlus
, B.UnPlus
-> true
167 | A.UnMinus
, B.UnMinus
-> true
168 | A.Tilde
, B.Tilde
-> true
169 | A.Not
, B.Not
-> true
170 | _
, B.GetRefLabel
-> false (* todo cocci? *)
171 | _
, (B.Not
|B.Tilde
|B.UnMinus
|B.UnPlus
|B.DeRef
|B.GetRef
) -> false
175 let equal_arithOp a b
=
177 | A.Plus
, B.Plus
-> true
178 | A.Minus
, B.Minus
-> true
179 | A.Mul
, B.Mul
-> true
180 | A.Div
, B.Div
-> true
181 | A.Mod
, B.Mod
-> true
182 | A.DecLeft
, B.DecLeft
-> true
183 | A.DecRight
, B.DecRight
-> true
184 | A.And
, B.And
-> true
185 | A.Or
, B.Or
-> true
186 | A.Xor
, B.Xor
-> true
187 | _
, (B.Xor
|B.Or
|B.And
|B.DecRight
|B.DecLeft
|B.Mod
|B.Div
|B.Mul
|B.Minus
|B.Plus
)
190 let equal_logicalOp a b
=
192 | A.Inf
, B.Inf
-> true
193 | A.Sup
, B.Sup
-> true
194 | A.InfEq
, B.InfEq
-> true
195 | A.SupEq
, B.SupEq
-> true
196 | A.Eq
, B.Eq
-> true
197 | A.NotEq
, B.NotEq
-> true
198 | A.AndLog
, B.AndLog
-> true
199 | A.OrLog
, B.OrLog
-> true
200 | _
, (B.OrLog
|B.AndLog
|B.NotEq
|B.Eq
|B.SupEq
|B.InfEq
|B.Sup
|B.Inf
)
203 let equal_assignOp a b
=
205 | A.SimpleAssign
, B.SimpleAssign
-> true
206 | A.OpAssign a
, B.OpAssign b
-> equal_arithOp a b
207 | _
, (B.OpAssign _
|B.SimpleAssign
) -> false
209 let equal_fixOp a b
=
211 | A.Dec
, B.Dec
-> true
212 | A.Inc
, B.Inc
-> true
213 | _
, (B.Inc
|B.Dec
) -> false
215 let equal_binaryOp a b
=
217 | A.Arith a
, B.Arith b
-> equal_arithOp a b
218 | A.Logical a
, B.Logical b
-> equal_logicalOp a b
219 | _
, (B.Logical _
| B.Arith _
) -> false
221 let equal_structUnion a b
=
223 | A.Struct
, B.Struct
-> true
224 | A.Union
, B.Union
-> true
225 | _
, (B.Struct
|B.Union
) -> false
229 | A.Signed
, B.Signed
-> true
230 | A.Unsigned
, B.UnSigned
-> true
231 | _
, (B.UnSigned
|B.Signed
) -> false
233 let equal_storage a b
=
235 | A.Static
, B.Sto
B.Static
236 | A.Auto
, B.Sto
B.Auto
237 | A.Register
, B.Sto
B.Register
238 | A.Extern
, B.Sto
B.Extern
240 | _
, (B.NoSto
| B.StoTypedef
) -> false
241 | _
, (B.Sto
(B.Register
|B.Static
|B.Auto
|B.Extern
)) -> false
244 (*---------------------------------------------------------------------------*)
246 let equal_metavarval valu valu'
=
247 match valu
, valu'
with
248 | Ast_c.MetaIdVal
(a
,_
), Ast_c.MetaIdVal
(b
,_
) -> a
=$
= b
249 | Ast_c.MetaFuncVal a
, Ast_c.MetaFuncVal b
-> a
=$
= b
250 | Ast_c.MetaLocalFuncVal a
, Ast_c.MetaLocalFuncVal b
->
251 (* do something more ? *)
254 (* al_expr before comparing !!! and accept when they match.
255 * Note that here we have Astc._expression, so it is a match
256 * modulo isomorphism (there is no metavariable involved here,
257 * just isomorphisms). => TODO call isomorphism_c_c instead of
258 * =*=. Maybe would be easier to transform ast_c in ast_cocci
259 * and call the iso engine of julia. *)
260 | Ast_c.MetaExprVal
(a
,_
), Ast_c.MetaExprVal
(b
,_
) ->
261 Lib_parsing_c.al_expr a
=*= Lib_parsing_c.al_expr b
262 | Ast_c.MetaExprListVal a
, Ast_c.MetaExprListVal b
->
263 Lib_parsing_c.al_arguments a
=*= Lib_parsing_c.al_arguments b
265 | Ast_c.MetaDeclVal a
, Ast_c.MetaDeclVal b
->
266 Lib_parsing_c.al_declaration a
=*= Lib_parsing_c.al_declaration b
267 | Ast_c.MetaFieldVal a
, Ast_c.MetaFieldVal b
->
268 Lib_parsing_c.al_field a
=*= Lib_parsing_c.al_field b
269 | Ast_c.MetaStmtVal a
, Ast_c.MetaStmtVal b
->
270 Lib_parsing_c.al_statement a
=*= Lib_parsing_c.al_statement b
271 | Ast_c.MetaInitVal a
, Ast_c.MetaInitVal b
->
272 Lib_parsing_c.al_init a
=*= Lib_parsing_c.al_init b
273 | Ast_c.MetaTypeVal a
, Ast_c.MetaTypeVal b
->
274 (* old: Lib_parsing_c.al_type a =*= Lib_parsing_c.al_type b *)
277 | Ast_c.MetaListlenVal a
, Ast_c.MetaListlenVal b
-> a
=|= b
279 | Ast_c.MetaParamVal a
, Ast_c.MetaParamVal b
->
280 Lib_parsing_c.al_param a
=*= Lib_parsing_c.al_param b
281 | Ast_c.MetaParamListVal a
, Ast_c.MetaParamListVal b
->
282 Lib_parsing_c.al_params a
=*= Lib_parsing_c.al_params b
284 | Ast_c.MetaPosVal
(posa1
,posa2
), Ast_c.MetaPosVal
(posb1
,posb2
) ->
285 Ast_cocci.equal_pos posa1 posb1
&& Ast_cocci.equal_pos posa2 posb2
287 | Ast_c.MetaPosValList l1
, Ast_c.MetaPosValList l2
->
289 (function (fla
,cea
,posa1
,posa2
) ->
291 (function (flb
,ceb
,posb1
,posb2
) ->
292 fla
=$
= flb
&& cea
=$
= ceb
&&
293 Ast_c.equal_posl posa1 posb1
&& Ast_c.equal_posl posa2 posb2
)
297 | (B.MetaPosValList _
|B.MetaListlenVal _
|B.MetaPosVal _
|B.MetaStmtVal _
298 |B.MetaDeclVal _
|B.MetaFieldVal _
|B.MetaTypeVal _
|B.MetaInitVal _
299 |B.MetaParamListVal _
|B.MetaParamVal _
|B.MetaExprListVal _
300 |B.MetaExprVal _
|B.MetaLocalFuncVal _
|B.MetaFuncVal _
|B.MetaIdVal _
304 (* probably only one argument needs to be stripped, because inherited
305 metavariables containing expressions are stripped in advance. But don't
306 know which one is which... *)
307 let equal_inh_metavarval valu valu'
=
308 match valu
, valu'
with
309 | Ast_c.MetaIdVal
(a
,_
), Ast_c.MetaIdVal
(b
,_
) -> a
=$
= b
310 | Ast_c.MetaFuncVal a
, Ast_c.MetaFuncVal b
-> a
=$
= b
311 | Ast_c.MetaLocalFuncVal a
, Ast_c.MetaLocalFuncVal b
->
312 (* do something more ? *)
315 (* al_expr before comparing !!! and accept when they match.
316 * Note that here we have Astc._expression, so it is a match
317 * modulo isomorphism (there is no metavariable involved here,
318 * just isomorphisms). => TODO call isomorphism_c_c instead of
319 * =*=. Maybe would be easier to transform ast_c in ast_cocci
320 * and call the iso engine of julia. *)
321 | Ast_c.MetaExprVal
(a
,_
), Ast_c.MetaExprVal
(b
,_
) ->
322 Lib_parsing_c.al_inh_expr a
=*= Lib_parsing_c.al_inh_expr b
323 | Ast_c.MetaExprListVal a
, Ast_c.MetaExprListVal b
->
324 Lib_parsing_c.al_inh_arguments a
=*= Lib_parsing_c.al_inh_arguments b
326 | Ast_c.MetaDeclVal a
, Ast_c.MetaDeclVal b
->
327 Lib_parsing_c.al_inh_declaration a
=*= Lib_parsing_c.al_inh_declaration b
328 | Ast_c.MetaFieldVal a
, Ast_c.MetaFieldVal b
->
329 Lib_parsing_c.al_inh_field a
=*= Lib_parsing_c.al_inh_field b
330 | Ast_c.MetaStmtVal a
, Ast_c.MetaStmtVal b
->
331 Lib_parsing_c.al_inh_statement a
=*= Lib_parsing_c.al_inh_statement b
332 | Ast_c.MetaInitVal a
, Ast_c.MetaInitVal b
->
333 Lib_parsing_c.al_inh_init a
=*= Lib_parsing_c.al_inh_init b
334 | Ast_c.MetaTypeVal a
, Ast_c.MetaTypeVal b
->
335 (* old: Lib_parsing_c.al_inh_type a =*= Lib_parsing_c.al_inh_type b *)
338 | Ast_c.MetaListlenVal a
, Ast_c.MetaListlenVal b
-> a
=|= b
340 | Ast_c.MetaParamVal a
, Ast_c.MetaParamVal b
->
341 Lib_parsing_c.al_param a
=*= Lib_parsing_c.al_param b
342 | Ast_c.MetaParamListVal a
, Ast_c.MetaParamListVal b
->
343 Lib_parsing_c.al_params a
=*= Lib_parsing_c.al_params b
345 | Ast_c.MetaPosVal
(posa1
,posa2
), Ast_c.MetaPosVal
(posb1
,posb2
) ->
346 Ast_cocci.equal_pos posa1 posb1
&& Ast_cocci.equal_pos posa2 posb2
348 | Ast_c.MetaPosValList l1
, Ast_c.MetaPosValList l2
->
350 (function (fla
,cea
,posa1
,posa2
) ->
352 (function (flb
,ceb
,posb1
,posb2
) ->
353 fla
=$
= flb
&& cea
=$
= ceb
&&
354 Ast_c.equal_posl posa1 posb1
&& Ast_c.equal_posl posa2 posb2
)
358 | (B.MetaPosValList _
|B.MetaListlenVal _
|B.MetaPosVal _
|B.MetaStmtVal _
359 |B.MetaDeclVal _
|B.MetaFieldVal _
|B.MetaTypeVal _
|B.MetaInitVal _
360 |B.MetaParamListVal _
|B.MetaParamVal _
|B.MetaExprListVal _
361 |B.MetaExprVal _
|B.MetaLocalFuncVal _
|B.MetaFuncVal _
|B.MetaIdVal _
366 (*---------------------------------------------------------------------------*)
367 (* could put in ast_c.ml, next to the split/unsplit_comma *)
368 let split_signb_baseb_ii (baseb
, ii
) =
369 let iis = ii
+> List.map
(fun info
-> (B.str_of_info info
), info
) in
370 match baseb
, iis with
372 | B.Void
, ["void",i1
] -> None
, [i1
]
374 | B.FloatType
(B.CFloat
),["float",i1
] -> None
, [i1
]
375 | B.FloatType
(B.CDouble
),["double",i1
] -> None
, [i1
]
376 | B.FloatType
(B.CLongDouble
),["long",i1
;"double",i2
] -> None
,[i1
;i2
]
378 | B.IntType
(B.CChar
), ["char",i1
] -> None
, [i1
]
381 | B.IntType
(B.Si
(sign
, base
)), xs
->
385 | (B.Signed
,(("signed",i1
)::rest
)) -> (Some
(B.Signed
,i1
),rest
)
386 | (B.Signed
,rest
) -> (None
,rest
)
387 | (B.UnSigned
,(("unsigned",i1
)::rest
)) -> (Some
(B.UnSigned
,i1
),rest
)
388 | (B.UnSigned
,rest
) -> (* is this case possible? *) (None
,rest
) in
389 (* The original code only allowed explicit signed and unsigned for char,
390 while this code allows char by itself. Not sure that needs to be
391 checked for here. If it does, then add a special case. *)
393 match (base
,rest
) with
394 B.CInt
, ["int",i1
] -> [i1
]
397 | B.CInt
, ["",i1
] -> (* no type is specified at all *)
398 (match i1
.B.pinfo
with
400 | _
-> failwith
("unrecognized signed int: "^
401 (String.concat
" "(List.map fst
iis))))
403 | B.CChar2
, ["char",i2
] -> [i2
]
405 | B.CShort
, ["short",i1
] -> [i1
]
406 | B.CShort
, ["short",i1
;"int",i2
] -> [i1
;i2
]
408 | B.CLong
, ["long",i1
] -> [i1
]
409 | B.CLong
, ["long",i1
;"int",i2
] -> [i1
;i2
]
411 | B.CLongLong
, ["long",i1
;"long",i2
] -> [i1
;i2
]
412 | B.CLongLong
, ["long",i1
;"long",i2
;"int",i3
] -> [i1
;i2
;i3
]
415 failwith
("strange type1, maybe because of weird order: "^
416 (String.concat
" " (List.map fst
iis))) in
419 | B.SizeType
, ["size_t",i1
] -> None
, [i1
]
420 | B.SSizeType
, ["ssize_t",i1
] -> None
, [i1
]
421 | B.PtrDiffType
, ["ptrdiff_t",i1
] -> None
, [i1
]
423 | _
-> failwith
("strange type2, maybe because of weird order: "^
424 (String.concat
" " (List.map fst
iis)))
426 (*---------------------------------------------------------------------------*)
428 let rec unsplit_icomma xs
=
432 (match A.unwrap y
with
434 (x
, y
)::unsplit_icomma xs
435 | _
-> failwith
"wrong ast_cocci in initializer"
438 failwith
("wrong ast_cocci in initializer, should have pair " ^
443 let resplit_initialiser ibs iicomma
=
444 match iicomma
, ibs
with
447 failwith
"should have a iicomma, do you generate fakeInfo in parser?"
449 failwith
"shouldn't have a iicomma"
450 | [iicomma
], x
::xs
->
451 let elems = List.map fst
(x
::xs
) in
452 let commas = List.map snd
(x
::xs
) +> List.flatten
in
453 let commas = commas @ [iicomma
] in
455 | _
-> raise Impossible
459 let rec split_icomma xs
=
462 | (x
,y
)::xs
-> x
::y
::split_icomma xs
464 let rec unsplit_initialiser ibs_unsplit
=
465 match ibs_unsplit
with
466 | [] -> [], [] (* empty iicomma *)
468 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
469 (x
, [])::xs
, lastcomma
471 and unsplit_initialiser_bis comma_before
= function
472 | [] -> [], [comma_before
]
474 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
475 (x
, [comma_before
])::xs
, lastcomma
480 (*---------------------------------------------------------------------------*)
481 (* coupling: same in type_annotater_c.ml *)
482 let structdef_to_struct_name ty
=
484 | qu
, (B.StructUnion
(su
, sopt
, fields
), iis) ->
486 | Some s
, [i1
;i2
;i3
;i4
] ->
487 qu
, (B.StructUnionName
(su
, s
), [i1
;i2
])
491 | x
-> raise Impossible
493 | _
-> raise Impossible
495 (*---------------------------------------------------------------------------*)
496 let one_initialisation_to_affectation x
=
497 let ({B.v_namei
= var
;
498 B.v_type
= returnType
;
499 B.v_type_bis
= tybis
;
500 B.v_storage
= storage
;
504 | Some
(name
, iniopt
) ->
506 | Some
(iini
, (B.InitExpr e
, ii_empty2
)) ->
509 Ast_c.NotLocalDecl
-> Ast_c.NotLocalVar
511 Ast_c.LocalVar
(Ast_c.info_of_type returnType
) in
513 (* old: Lib_parsing_c.al_type returnType
514 * but this type has not the typename completed so
515 * instead try to use tybis
518 | Some ty_with_typename_completed
-> ty_with_typename_completed
519 | None
-> raise Impossible
522 let typ = ref (Some
(typexp,local), Ast_c.NotTest
) in
524 let idexpr = Ast_c.mk_e_bis
(B.Ident
ident) typ Ast_c.noii
in
526 Ast_c.mk_e
(B.Assignment
(idexpr,B.SimpleAssign
, e
)) [iini
] in
531 let initialisation_to_affectation decl
=
533 | B.MacroDecl _
-> F.Decl decl
534 | B.DeclList
(xs
, iis) ->
536 (* todo?: should not do that if the variable is an array cos
537 * will have x[] = , mais de toute facon ca sera pas un InitExp
539 let possible_assignment =
543 match prev
,one_initialisation_to_affectation x
with
545 | None
,Some x
-> Some x
546 | Some prev
,Some x
->
547 (* [] is clearly an invalid ii value for a sequence.
548 hope that no one looks at it, since nothing will
549 match the sequence. Fortunately, SmPL doesn't
550 support , expressions. *)
551 Some
(Ast_c.mk_e
(Ast_c.Sequence
(prev
, x
)) []))
553 match possible_assignment with
554 Some x
-> F.DefineExpr x
555 | None
-> F.Decl decl
557 (*****************************************************************************)
558 (* Functor parameter combinators *)
559 (*****************************************************************************)
561 * src: papers on parser combinators in haskell (cf a pearl by meijer in ICFP)
563 * version0: was not tagging the SP, so just tag the C
565 * (tin -> 'c tout) -> ('c -> (tin -> 'b tout)) -> (tin -> 'b tout)
566 * val return : 'b -> tin -> 'b tout
567 * val fail : tin -> 'b tout
569 * version1: now also tag the SP so return a ('a * 'b)
572 type mode
= PatternMode
| TransformMode
580 type ('a
, 'b
) matcher
= 'a
-> 'b
-> tin
-> ('a
* 'b
) tout
585 (tin
-> ('a
* 'b
) tout
) ->
586 ('a
-> 'b
-> (tin
-> ('c
* 'd
) tout
)) ->
587 (tin
-> ('c
* 'd
) tout
)
589 val return
: ('a
* 'b
) -> tin
-> ('a
*'b
) tout
590 val fail
: tin
-> ('a
* 'b
) tout
602 val (>&&>) : (tin
-> bool) -> (tin
-> 'x tout
) -> (tin
-> 'x tout
)
604 val tokenf
: ('a
A.mcode
, B.info
) matcher
605 val tokenf_mck
: (A.mcodekind, B.info
) matcher
608 (A.meta_name
A.mcode
, B.expression
) matcher
610 (A.meta_name
A.mcode
, (Ast_c.argument
, Ast_c.il
) either list
) matcher
612 (A.meta_name
A.mcode
, Ast_c.fullType
) matcher
614 (A.meta_name
A.mcode
,
615 (Ast_c.parameterType
, Ast_c.il
) either list
) matcher
617 (A.meta_name
A.mcode
, Ast_c.parameterType
) matcher
619 (A.meta_name
A.mcode
, Ast_c.initialiser
) matcher
621 (A.meta_name
A.mcode
, (Ast_c.initialiser
, Ast_c.il
) either list
) matcher
623 (A.meta_name
A.mcode
, Ast_c.declaration
) matcher
625 (A.meta_name
A.mcode
, Ast_c.field
) matcher
627 (A.meta_name
A.mcode
, Control_flow_c.node
) matcher
629 val distrf_define_params
:
630 (A.meta_name
A.mcode
, (string Ast_c.wrap
, Ast_c.il
) either list
) matcher
632 val distrf_enum_fields
:
633 (A.meta_name
A.mcode
, (B.oneEnumType
, B.il
) either list
) matcher
635 val distrf_struct_fields
:
636 (A.meta_name
A.mcode
, B.field list
) matcher
639 (A.meta_name
A.mcode
, (B.constant
, string) either
B.wrap
) matcher
642 (A.expression
, B.expression
) matcher
-> (A.expression
, F.node
) matcher
645 (A.expression
, B.expression
) matcher
->
646 (A.expression
, B.expression
) matcher
649 (A.fullType
, B.fullType
) matcher
-> (A.fullType
, F.node
) matcher
652 (A.initialiser
, B.initialiser
) matcher
-> (A.initialiser
, F.node
) matcher
655 A.keep_binding
-> A.inherited
->
656 A.meta_name
A.mcode
* Ast_c.metavar_binding_kind
*
657 (unit -> Common.filename
* string * Ast_c.posl
* Ast_c.posl
) ->
658 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
660 val check_idconstraint
:
661 ('a
-> 'b
-> bool) -> 'a
-> 'b
->
662 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
664 val check_constraints_ne
:
665 ('a
, 'b
) matcher
-> 'a list
-> 'b
->
666 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
668 val all_bound
: A.meta_name list
-> (tin
-> bool)
670 val optional_storage_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
671 val optional_qualifier_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
672 val value_format_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
676 (*****************************************************************************)
677 (* Functor code, "Cocci vs C" *)
678 (*****************************************************************************)
681 functor (X
: PARAM
) ->
684 type ('a
, 'b
) matcher
= 'a
-> 'b
-> X.tin
-> ('a
* 'b
) X.tout
687 let return = X.return
690 let (>||>) = X.(>||>)
691 let (>|+|>) = X.(>|+|>)
692 let (>&&>) = X.(>&&>)
694 let tokenf = X.tokenf
696 (* should be raise Impossible when called from transformation.ml *)
699 | PatternMode
-> fail
700 | TransformMode
-> raise Impossible
703 let (option: ('a
,'b
) matcher
-> ('a
option,'b
option) matcher
)= fun f t1 t2
->
705 | (Some t1
, Some t2
) ->
706 f t1 t2
>>= (fun t1 t2
->
707 return (Some t1
, Some t2
)
709 | (None
, None
) -> return (None
, None
)
712 (* Dots are sometimes used as metavariables, since like metavariables they
713 can match other things. But they no longer have the same type. Perhaps these
714 functions could be avoided by introducing an appropriate level of polymorphism,
715 but I don't know how to declare polymorphism across functors *)
716 let dots2metavar (_
,info
,mcodekind,pos
) =
717 (("","..."),info
,mcodekind,pos
)
718 let metavar2dots (_
,info
,mcodekind,pos
) = ("...",info
,mcodekind,pos
)
720 let satisfies_regexpconstraint c id
: bool =
722 A.IdRegExp
(_
,recompiled
) -> Str.string_match recompiled id
0
723 | A.IdNotRegExp
(_
,recompiled
) -> not
(Str.string_match recompiled id
0)
725 let satisfies_iconstraint c id
: bool =
728 let satisfies_econstraint c exp
: bool =
729 let warning s
= pr2_once
("WARNING: "^s
); false in
730 match Ast_c.unwrap_expr exp
with
731 Ast_c.Ident
(name
) ->
733 Ast_c.RegularName rname
->
734 satisfies_regexpconstraint c
(Ast_c.unwrap_st rname
)
735 | Ast_c.CppConcatenatedName _
->
737 "Unable to apply a constraint on a CppConcatenatedName identifier!"
738 | Ast_c.CppVariadicName _
->
740 "Unable to apply a constraint on a CppVariadicName identifier!"
741 | Ast_c.CppIdentBuilder _
->
743 "Unable to apply a constraint on a CppIdentBuilder identifier!")
744 | Ast_c.Constant cst
->
746 | Ast_c.String
(str
, _
) -> satisfies_regexpconstraint c str
747 | Ast_c.MultiString strlist
->
748 warning "Unable to apply a constraint on an multistring constant!"
749 | Ast_c.Char
(char
, _
) -> satisfies_regexpconstraint c char
750 | Ast_c.Int
(int , _
) -> satisfies_regexpconstraint c
int
751 | Ast_c.Float
(float, _
) -> satisfies_regexpconstraint c
float)
752 | _
-> warning "Unable to apply a constraint on an expression!"
755 (* ------------------------------------------------------------------------- *)
756 (* This has to be up here to allow adequate polymorphism *)
758 let list_matcher match_dots rebuild_dots match_comma rebuild_comma
759 match_metalist rebuild_metalist mktermval special_cases
760 element distrf get_iis
= fun eas ebs
->
761 let rec loop = function
762 [], [] -> return ([], [])
763 | [], eb
::ebs
-> fail
765 X.all_bound
(A.get_inherited ea
) >&&>
767 (match match_dots ea
, ebs
with
768 Some
(mcode
, optexpr
), ys
->
769 (* todo: if optexpr, then a WHEN and so may have to filter yys *)
770 if optexpr
<> None
then failwith
"not handling when in a list";
772 (* '...' can take more or less the beginnings of the arguments *)
774 Common.zip
(Common.inits ys
) (Common.tails ys
) in
776 (startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
779 (* allow '...', and maybe its associated ',' to match nothing.
780 * for the associated ',' see below how we handle the EComma
785 if mcode_contain_plus (mcodekind mcode
)
788 "I have no token that I could accroche myself on"*)
789 else return (dots2metavar mcode
, [])
791 (* subtil: we dont want the '...' to match until the
792 * comma. cf -test pb_params_iso. We would get at
793 * "already tagged" error.
794 * this is because both f (... x, ...) and f (..., x, ...)
795 * would match a f(x,3) with our "optional-comma" strategy.
797 (match Common.last startxs
with
799 | Left _
-> distrf
(dots2metavar mcode
) startxs
))
801 >>= (fun mcode startxs
->
802 let mcode = metavar2dots mcode in
803 loop (eas
, endxs
) >>= (fun eas endxs
->
805 (rebuild_dots
(mcode, optexpr
) +> A.rewrap ea
) ::eas
,
813 (match match_comma ea
, ebs
with
814 | Some ia1
, Right ii
::ebs
->
816 (let ib1 = tuple_of_list1 ii
in
817 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
818 loop (eas
, ebs
) >>= (fun eas ebs
->
820 (rebuild_comma ia1
+> A.rewrap ea
)::eas
,
825 (* allow ',' to maching nothing. optional comma trick *)
827 (if mcode_contain_plus (mcodekind ia1
)
829 else loop (eas
, ebs
))
832 (match match_metalist ea
, ebs
with
833 Some
(ida
,leninfo
,keep
,inherited
), ys
->
835 Common.zip
(Common.inits ys
) (Common.tails ys
) in
837 (startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
842 if mcode_contain_plus (mcodekind ida
)
844 (* failwith "no token that I could accroche myself on" *)
847 (match Common.last startxs
with
854 let startxs'
= Ast_c.unsplit_comma
startxs in
855 let len = List.length
startxs'
in
858 | A.MetaListLen
(lenname
,lenkeep
,leninherited
) ->
859 let max_min _
= failwith
"no pos" in
860 X.envf lenkeep leninherited
861 (lenname
, Ast_c.MetaListlenVal
(len), max_min)
864 then (function f
-> f
())
865 else (function f
-> fail)
866 | A.AnyListLen
-> function f
-> f
()
870 Lib_parsing_c.lin_col_by_pos
(get_iis
startxs) in
871 X.envf keep inherited
872 (ida
, mktermval
startxs'
, max_min)
875 then return (ida
, [])
876 else distrf ida
(Ast_c.split_comma
startxs'
))
877 >>= (fun ida
startxs ->
878 loop (eas
, endxs
) >>= (fun eas endxs
->
880 (rebuild_metalist
(ida
,leninfo
,keep
,inherited
))
889 special_cases ea eas ebs
in
890 match try_matches with
895 element ea eb
>>= (fun ea eb
->
896 loop (eas
, ebs
) >>= (fun eas ebs
->
897 return (ea
::eas
, Left eb
::ebs
)))
898 | (Right y
)::ys
-> raise Impossible
902 (*---------------------------------------------------------------------------*)
914 (*---------------------------------------------------------------------------*)
915 let rec (expression
: (A.expression
, Ast_c.expression
) matcher
) =
917 if A.get_test_exp ea
&& not
(Ast_c.is_test eb
) then fail
919 X.all_bound
(A.get_inherited ea
) >&&>
920 let wa x
= A.rewrap ea x
in
921 match A.unwrap ea
, eb
with
923 (* general case: a MetaExpr can match everything *)
924 | A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
),
925 (((expr
, opttypb
), ii
) as expb
) ->
927 (* old: before have a MetaConst. Now we factorize and use 'form' to
928 * differentiate between different cases *)
929 let rec matches_id = function
930 B.Ident
(name
) -> true
931 | B.Cast
(ty
,e
) -> matches_id (B.unwrap_expr e
)
934 match (form
,expr
) with
937 let rec matches = function
938 B.Constant
(c
) -> true
939 | B.Ident
(nameidb
) ->
940 let s = Ast_c.str_of_name nameidb
in
941 if s =~
"^[A-Z_][A-Z_0-9]*$"
943 pr2_once
("warning: " ^
s ^
" treated as a constant");
947 | B.Cast
(ty
,e
) -> matches (B.unwrap_expr e
)
948 | B.Unary
(e
,B.UnMinus
) -> matches (B.unwrap_expr e
)
949 | B.SizeOfExpr
(exp
) -> true
950 | B.SizeOfType
(ty
) -> true
956 (Some
(_
,Ast_c.LocalVar _
),_
) -> true
958 | (A.ID
,e
) -> matches_id e
in
962 (let (opttypb
,_testb
) = !opttypb
in
963 match opttypa
, opttypb
with
964 | None
, _
-> return ((),())
966 pr2_once
("Missing type information. Certainly a pb in " ^
967 "annotate_typer.ml");
970 | Some tas
, Some tb
->
971 tas
+> List.fold_left
(fun acc ta
->
972 acc
>|+|> compatible_type ta tb
) fail
975 let meta_expr_val l x
= Ast_c.MetaExprVal
(x
,l
) in
976 match constraints
with
977 Ast_cocci.NoConstraint
-> return (meta_expr_val [],())
978 | Ast_cocci.NotIdCstrt cstrt
->
979 X.check_idconstraint
satisfies_econstraint cstrt eb
980 (fun () -> return (meta_expr_val [],()))
981 | Ast_cocci.NotExpCstrt cstrts
->
982 X.check_constraints_ne expression cstrts eb
983 (fun () -> return (meta_expr_val [],()))
984 | Ast_cocci.SubExpCstrt cstrts
->
985 return (meta_expr_val cstrts
,()))
989 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_expr expb
) in
990 X.envf keep inherited
(ida
, wrapper expb
, max_min)
992 X.distrf_e ida expb
>>=
995 A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
)+>
1003 * | A.MetaExpr(ida,false,opttypa,_inherited), expb ->
1004 * D.distribute_mck (mcodekind ida) D.distribute_mck_e expb binding
1006 * but bug! because if have not tagged SP, then transform without doing
1007 * any checks. Hopefully now have tagged SP technique.
1012 * | A.Edots _, _ -> raise Impossible.
1014 * In fact now can also have the Edots inside normal expression, not
1015 * just in arg lists. in 'x[...];' less: in if(<... x ... y ...>)
1017 | A.Edots
(mcode, None
), expb
->
1018 X.distrf_e
(dots2metavar mcode) expb
>>= (fun mcode expb
->
1020 A.Edots
(metavar2dots mcode, None
) +> A.rewrap ea
,
1025 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
1028 | A.Ident ida
, ((B.Ident
(nameidb
), typ),noii
) ->
1030 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1032 ((A.Ident ida
)) +> wa,
1033 ((B.Ident
(nameidb
), typ),Ast_c.noii
)
1039 | A.MetaErr _
, _
-> failwith
"not handling MetaErr"
1041 (* todo?: handle some isomorphisms in int/float ? can have different
1042 * format : 1l can match a 1.
1044 * todo: normally string can contain some metavar too, so should
1045 * recurse on the string
1047 | A.Constant
(ia1
), ((B.Constant
(ib
) , typ),ii
) ->
1048 (* for everything except the String case where can have multi elems *)
1050 let ib1 = tuple_of_list1 ii
in
1051 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1053 ((A.Constant ia1
)) +> wa,
1054 ((B.Constant
(ib
), typ),[ib1])
1057 (match term ia1
, ib
with
1058 | A.Int x
, B.Int
(y
,_
) ->
1059 X.value_format_flag
(fun use_value_equivalence
->
1060 if use_value_equivalence
1070 | A.Char x
, B.Char
(y
,_
) when x
=$
= y
(* todo: use kind ? *)
1072 | A.Float x
, B.Float
(y
,_
) when x
=$
= y
(* todo: use floatType ? *)
1075 | A.String sa
, B.String
(sb
,_kind
) when sa
=$
= sb
->
1078 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1080 ((A.Constant ia1
)) +> wa,
1081 ((B.Constant
(ib
), typ),[ib1])
1083 | _
-> fail (* multi string, not handled *)
1086 | _
, B.MultiString _
-> (* todo cocci? *) fail
1087 | _
, (B.String _
| B.Float _
| B.Char _
| B.Int _
) -> fail
1091 | A.FunCall
(ea
, ia1
, eas
, ia2
), ((B.FunCall
(eb
, ebs
), typ),ii
) ->
1092 (* todo: do special case to allow IdMetaFunc, cos doing the
1093 * recursive call will be too late, match_ident will not have the
1094 * info whether it was a function. todo: but how detect when do
1095 * x.field = f; how know that f is a Func ? By having computed
1096 * some information before the matching!
1098 * Allow match with FunCall containing types. Now ast_cocci allow
1099 * type in parameter, and morover ast_cocci allow f(...) and those
1100 * ... could match type.
1102 let (ib1, ib2
) = tuple_of_list2 ii
in
1103 expression ea eb
>>= (fun ea eb
->
1104 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1105 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1106 arguments
(seqstyle eas
) (A.undots eas
) ebs
>>= (fun easundots ebs
->
1107 let eas = redots
eas easundots
in
1109 ((A.FunCall
(ea
, ia1
, eas, ia2
)) +> wa,
1110 ((B.FunCall
(eb
, ebs
),typ), [ib1;ib2
])
1116 | A.Assignment
(ea1
, opa
, ea2
, simple
),
1117 ((B.Assignment
(eb1
, opb
, eb2
), typ),ii
) ->
1118 let (opbi
) = tuple_of_list1 ii
in
1119 if equal_assignOp (term opa
) opb
1121 expression ea1 eb1
>>= (fun ea1 eb1
->
1122 expression ea2 eb2
>>= (fun ea2 eb2
->
1123 tokenf opa opbi
>>= (fun opa opbi
->
1125 (A.Assignment
(ea1
, opa
, ea2
, simple
)) +> wa,
1126 ((B.Assignment
(eb1
, opb
, eb2
), typ), [opbi
])
1130 | A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
),((B.CondExpr
(eb1
,eb2opt
,eb3
),typ),ii
) ->
1131 let (ib1, ib2
) = tuple_of_list2 ii
in
1132 expression ea1 eb1
>>= (fun ea1 eb1
->
1133 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
1134 expression ea3 eb3
>>= (fun ea3 eb3
->
1135 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1136 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1138 ((A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
))) +> wa,
1139 ((B.CondExpr
(eb1
, eb2opt
, eb3
),typ), [ib1;ib2
])
1142 (* todo?: handle some isomorphisms here ? *)
1143 | A.Postfix
(ea
, opa
), ((B.Postfix
(eb
, opb
), typ),ii
) ->
1144 let opbi = tuple_of_list1 ii
in
1145 if equal_fixOp (term opa
) opb
1147 expression ea eb
>>= (fun ea eb
->
1148 tokenf opa
opbi >>= (fun opa
opbi ->
1150 ((A.Postfix
(ea
, opa
))) +> wa,
1151 ((B.Postfix
(eb
, opb
), typ),[opbi])
1156 | A.Infix
(ea
, opa
), ((B.Infix
(eb
, opb
), typ),ii
) ->
1157 let opbi = tuple_of_list1 ii
in
1158 if equal_fixOp (term opa
) opb
1160 expression ea eb
>>= (fun ea eb
->
1161 tokenf opa
opbi >>= (fun opa
opbi ->
1163 ((A.Infix
(ea
, opa
))) +> wa,
1164 ((B.Infix
(eb
, opb
), typ),[opbi])
1168 | A.Unary
(ea
, opa
), ((B.Unary
(eb
, opb
), typ),ii
) ->
1169 let opbi = tuple_of_list1 ii
in
1170 if equal_unaryOp (term opa
) opb
1172 expression ea eb
>>= (fun ea eb
->
1173 tokenf opa
opbi >>= (fun opa
opbi ->
1175 ((A.Unary
(ea
, opa
))) +> wa,
1176 ((B.Unary
(eb
, opb
), typ),[opbi])
1180 | A.Binary
(ea1
, opa
, ea2
), ((B.Binary
(eb1
, opb
, eb2
), typ),ii
) ->
1181 let opbi = tuple_of_list1 ii
in
1182 if equal_binaryOp (term opa
) opb
1184 expression ea1 eb1
>>= (fun ea1 eb1
->
1185 expression ea2 eb2
>>= (fun ea2 eb2
->
1186 tokenf opa
opbi >>= (fun opa
opbi ->
1188 ((A.Binary
(ea1
, opa
, ea2
))) +> wa,
1189 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1193 | A.Nested
(ea1
, opa
, ea2
), eb
->
1195 expression ea1 eb
>|+|>
1197 ((B.Binary
(eb1
, opb
, eb2
), typ),ii
)
1198 when equal_binaryOp (term opa
) opb
->
1199 let opbi = tuple_of_list1 ii
in
1201 (expression ea1 eb1
>>= (fun ea1 eb1
->
1202 expression ea2 eb2
>>= (fun ea2 eb2
->
1203 tokenf opa
opbi >>= (fun opa
opbi ->
1205 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1206 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1209 (expression ea2 eb1
>>= (fun ea2 eb1
->
1210 expression ea1 eb2
>>= (fun ea1 eb2
->
1211 tokenf opa
opbi >>= (fun opa
opbi ->
1213 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1214 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1217 (loop eb1
>>= (fun ea1 eb1
->
1218 expression ea2 eb2
>>= (fun ea2 eb2
->
1219 tokenf opa
opbi >>= (fun opa
opbi ->
1221 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1222 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1225 (expression ea2 eb1
>>= (fun ea2 eb1
->
1226 loop eb2
>>= (fun ea1 eb2
->
1227 tokenf opa
opbi >>= (fun opa
opbi ->
1229 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1230 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1232 left_to_right >|+|> right_to_left >|+|> in_left >|+|> in_right
1236 (* todo?: handle some isomorphisms here ? (with pointers = Unary Deref) *)
1237 | A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
),((B.ArrayAccess
(eb1
, eb2
), typ),ii
) ->
1238 let (ib1, ib2
) = tuple_of_list2 ii
in
1239 expression ea1 eb1
>>= (fun ea1 eb1
->
1240 expression ea2 eb2
>>= (fun ea2 eb2
->
1241 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1242 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1244 ((A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
))) +> wa,
1245 ((B.ArrayAccess
(eb1
, eb2
),typ), [ib1;ib2
])
1248 (* todo?: handle some isomorphisms here ? *)
1249 | A.RecordAccess
(ea
, ia1
, ida
), ((B.RecordAccess
(eb
, idb
), typ),ii
) ->
1250 let (ib1) = tuple_of_list1 ii
in
1251 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
1252 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1253 expression ea eb
>>= (fun ea eb
->
1255 ((A.RecordAccess
(ea
, ia1
, ida
))) +> wa,
1256 ((B.RecordAccess
(eb
, idb
), typ), [ib1])
1261 | A.RecordPtAccess
(ea
,ia1
,ida
),((B.RecordPtAccess
(eb
, idb
), typ), ii
) ->
1262 let (ib1) = tuple_of_list1 ii
in
1263 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
1264 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1265 expression ea eb
>>= (fun ea eb
->
1267 ((A.RecordPtAccess
(ea
, ia1
, ida
))) +> wa,
1268 ((B.RecordPtAccess
(eb
, idb
), typ), [ib1])
1272 (* todo?: handle some isomorphisms here ?
1273 * todo?: do some iso-by-absence on cast ?
1274 * by trying | ea, B.Case (typb, eb) -> match_e_e ea eb ?
1277 | A.Cast
(ia1
, typa
, ia2
, ea
), ((B.Cast
(typb
, eb
), typ),ii
) ->
1278 let (ib1, ib2
) = tuple_of_list2 ii
in
1279 fullType typa typb
>>= (fun typa typb
->
1280 expression ea eb
>>= (fun ea eb
->
1281 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1282 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1284 ((A.Cast
(ia1
, typa
, ia2
, ea
))) +> wa,
1285 ((B.Cast
(typb
, eb
),typ),[ib1;ib2
])
1288 | A.SizeOfExpr
(ia1
, ea
), ((B.SizeOfExpr
(eb
), typ),ii
) ->
1289 let ib1 = tuple_of_list1 ii
in
1290 expression ea eb
>>= (fun ea eb
->
1291 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1293 ((A.SizeOfExpr
(ia1
, ea
))) +> wa,
1294 ((B.SizeOfExpr
(eb
), typ),[ib1])
1297 | A.SizeOfType
(ia1
, ia2
, typa
, ia3
), ((B.SizeOfType typb
, typ),ii
) ->
1298 let (ib1,ib2
,ib3
) = tuple_of_list3 ii
in
1299 fullType typa typb
>>= (fun typa typb
->
1300 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1301 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1302 tokenf ia3 ib3
>>= (fun ia3 ib3
->
1304 ((A.SizeOfType
(ia1
, ia2
, typa
, ia3
))) +> wa,
1305 ((B.SizeOfType
(typb
),typ),[ib1;ib2
;ib3
])
1309 (* todo? iso ? allow all the combinations ? *)
1310 | A.Paren
(ia1
, ea
, ia2
), ((B.ParenExpr
(eb
), typ),ii
) ->
1311 let (ib1, ib2
) = tuple_of_list2 ii
in
1312 expression ea eb
>>= (fun ea eb
->
1313 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1314 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1316 ((A.Paren
(ia1
, ea
, ia2
))) +> wa,
1317 ((B.ParenExpr
(eb
), typ), [ib1;ib2
])
1320 | A.NestExpr
(starter
,exps
,ender
,None
,true), eb
->
1321 (match A.get_mcodekind starter
with
1322 A.MINUS _
-> failwith
"TODO: only context nests supported"
1324 (match A.unwrap exps
with
1326 X.cocciExpExp expression exp eb
>>= (fun exp eb
->
1329 (starter
,A.rewrap exps
(A.DOTS
[exp
]),ender
,None
,true)) +> wa,
1335 "for nestexpr, only handling the case with dots and only one exp")
1337 | A.NestExpr _
, _
->
1338 failwith
"only handling multi and no when code in a nest expr"
1340 (* only in arg lists or in define body *)
1341 | A.TypeExp _
, _
-> fail
1343 (* only in arg lists *)
1344 | A.MetaExprList _
, _
1351 | A.DisjExpr
eas, eb
->
1352 eas +> List.fold_left
(fun acc ea
-> acc
>|+|> (expression ea eb
)) fail
1354 | A.UniqueExp _
,_
| A.OptExp _
,_
->
1355 failwith
"not handling Opt/Unique/Multi on expr"
1357 (* Because of Exp cant put a raise Impossible; have to put a fail *)
1359 (* have not a counter part in coccinelle, for the moment *)
1360 | _
, ((B.Sequence _
,_
),_
)
1361 | _
, ((B.StatementExpr _
,_
),_
)
1362 | _
, ((B.Constructor _
,_
),_
)
1367 (((B.Cast
(_
, _
)|B.ParenExpr _
|B.SizeOfType _
|B.SizeOfExpr _
|
1368 B.RecordPtAccess
(_
, _
)|
1369 B.RecordAccess
(_
, _
)|B.ArrayAccess
(_
, _
)|
1370 B.Binary
(_
, _
, _
)|B.Unary
(_
, _
)|
1371 B.Infix
(_
, _
)|B.Postfix
(_
, _
)|
1372 B.Assignment
(_
, _
, _
)|B.CondExpr
(_
, _
, _
)|
1373 B.FunCall
(_
, _
)|B.Constant _
|B.Ident _
),
1381 (* ------------------------------------------------------------------------- *)
1382 and (ident_cpp
: info_ident
-> (A.ident, B.name
) matcher
) =
1383 fun infoidb ida idb
->
1385 | B.RegularName
(s, iis) ->
1386 let iis = tuple_of_list1
iis in
1387 ident infoidb ida
(s, iis) >>= (fun ida
(s,iis) ->
1390 (B.RegularName
(s, [iis]))
1392 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
1394 (* This should be moved to the Id case of ident. Metavariables
1395 should be allowed to be bound to such variables. But doing so
1396 would require implementing an appropriate distr function *)
1399 and (ident: info_ident
-> (A.ident, string * Ast_c.info
) matcher
) =
1400 fun infoidb ida
((idb
, iib
)) -> (* (idb, iib) as ib *)
1401 let check_constraints constraints idb
=
1402 let meta_id_val l x
= Ast_c.MetaIdVal
(x
,l
) in
1403 match constraints
with
1404 A.IdNoConstraint
-> return (meta_id_val [],())
1405 | A.IdNegIdSet
(str
,meta
) ->
1406 X.check_idconstraint
satisfies_iconstraint str idb
1407 (fun () -> return (meta_id_val meta
,()))
1408 | A.IdRegExpConstraint re
->
1409 X.check_idconstraint
satisfies_regexpconstraint re idb
1410 (fun () -> return (meta_id_val [],())) in
1411 X.all_bound
(A.get_inherited ida
) >&&>
1412 match A.unwrap ida
with
1414 if (term sa
) =$
= idb
then
1415 tokenf sa iib
>>= (fun sa iib
->
1417 ((A.Id sa
)) +> A.rewrap ida
,
1422 | A.MetaId
(mida
,constraints
,keep
,inherited
) ->
1423 check_constraints constraints idb
>>=
1425 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1426 (* use drop_pos for ids so that the pos is not added a second time in
1427 the call to tokenf *)
1428 X.envf keep inherited
(A.drop_pos mida
, wrapper idb
, max_min)
1430 tokenf mida iib
>>= (fun mida iib
->
1432 ((A.MetaId
(mida
, constraints
, keep
, inherited
)) +> A.rewrap ida
,
1437 | A.MetaFunc
(mida
,constraints
,keep
,inherited
) ->
1439 check_constraints constraints idb
>>=
1441 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1442 X.envf keep inherited
(A.drop_pos mida
,Ast_c.MetaFuncVal idb
,max_min)
1444 tokenf mida iib
>>= (fun mida iib
->
1446 ((A.MetaFunc
(mida
,constraints
,keep
,inherited
)))+>A.rewrap ida
,
1451 | LocalFunction
| Function
-> is_function()
1453 failwith
"MetaFunc, need more semantic info about id"
1454 (* the following implementation could possibly be useful, if one
1455 follows the convention that a macro is always in capital letters
1456 and that a macro is not a function.
1457 (if idb =~ "^[A-Z_][A-Z_0-9]*$" then fail else is_function())*)
1460 | A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
) ->
1463 check_constraints constraints idb
>>=
1465 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1466 X.envf keep inherited
1467 (A.drop_pos mida
,Ast_c.MetaLocalFuncVal idb
, max_min)
1469 tokenf mida iib
>>= (fun mida iib
->
1471 ((A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
)))
1477 | DontKnow
-> failwith
"MetaLocalFunc, need more semantic info about id"
1480 | A.OptIdent _
| A.UniqueIdent _
->
1481 failwith
"not handling Opt/Unique for ident"
1483 (* ------------------------------------------------------------------------- *)
1484 and (arguments
: sequence
->
1485 (A.expression list
, Ast_c.argument
Ast_c.wrap2 list
) matcher
) =
1486 fun seqstyle eas ebs
->
1488 | Unordered
-> failwith
"not handling ooo"
1490 arguments_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1491 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1493 (* because '...' can match nothing, need to take care when have
1494 * ', ...' or '...,' as in f(..., X, Y, ...). It must match
1495 * f(1,2) for instance.
1496 * So I have added special cases such as (if startxs = []) and code
1497 * in the Ecomma matching rule.
1499 * old: Must do some try, for instance when f(...,X,Y,...) have to
1500 * test the transfo for all the combinaitions and if multiple transfo
1501 * possible ? pb ? => the type is to return a expression option ? use
1502 * some combinators to help ?
1503 * update: with the tag-SP approach, no more a problem.
1506 and arguments_bis
= fun eas ebs
->
1508 match A.unwrap ea
with
1509 A.Edots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
1511 let build_dots (mcode, optexpr
) = A.Edots
(mcode, optexpr
) in
1512 let match_comma ea
=
1513 match A.unwrap ea
with
1514 A.EComma ia1
-> Some ia1
1516 let build_comma ia1
= A.EComma ia1
in
1517 let match_metalist ea
=
1518 match A.unwrap ea
with
1519 A.MetaExprList
(ida
,leninfo
,keep
,inherited
) ->
1520 Some
(ida
,leninfo
,keep
,inherited
)
1522 let build_metalist (ida
,leninfo
,keep
,inherited
) =
1523 A.MetaExprList
(ida
,leninfo
,keep
,inherited
) in
1524 let mktermval v
= Ast_c.MetaExprListVal v
in
1525 let special_cases ea
eas ebs
= None
in
1526 list_matcher match_dots build_dots match_comma build_comma
1527 match_metalist build_metalist mktermval
1528 special_cases argument
X.distrf_args
1529 Lib_parsing_c.ii_of_args
eas ebs
1531 and argument arga argb
=
1532 X.all_bound
(A.get_inherited arga
) >&&>
1533 match A.unwrap arga
, argb
with
1535 Right
(B.ArgType
{B.p_register
=b
,iib
; p_namei
=sopt
;p_type
=tyb
}) ->
1536 if b
|| sopt
<> None
1538 (* failwith "the argument have a storage and ast_cocci does not have"*)
1541 (* b = false and sopt = None *)
1542 fullType tya tyb
>>= (fun tya tyb
->
1544 (A.TypeExp tya
) +> A.rewrap arga
,
1545 (Right
(B.ArgType
{B.p_register
=(b
,iib
);
1550 | A.TypeExp tya
, _
-> fail
1551 | _
, Right
(B.ArgType _
) -> fail
1553 expression arga argb
>>= (fun arga argb
->
1554 return (arga
, Left argb
)
1556 | _
, Right
(B.ArgAction y
) -> fail
1559 (* ------------------------------------------------------------------------- *)
1560 (* todo? facto code with argument ? *)
1561 and (parameters
: sequence
->
1562 (A.parameterTypeDef list
, Ast_c.parameterType
Ast_c.wrap2 list
)
1564 fun seqstyle eas ebs
->
1566 | Unordered
-> failwith
"not handling ooo"
1568 parameters_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1569 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1573 and parameters_bis
eas ebs
=
1575 match A.unwrap ea
with
1576 A.Pdots
(mcode) -> Some
(mcode, None
)
1578 let build_dots (mcode, _optexpr
) = A.Pdots
(mcode) in
1579 let match_comma ea
=
1580 match A.unwrap ea
with
1581 A.PComma ia1
-> Some ia1
1583 let build_comma ia1
= A.PComma ia1
in
1584 let match_metalist ea
=
1585 match A.unwrap ea
with
1586 A.MetaParamList
(ida
,leninfo
,keep
,inherited
) ->
1587 Some
(ida
,leninfo
,keep
,inherited
)
1589 let build_metalist (ida
,leninfo
,keep
,inherited
) =
1590 A.MetaParamList
(ida
,leninfo
,keep
,inherited
) in
1591 let mktermval v
= Ast_c.MetaParamListVal v
in
1592 let special_cases ea
eas ebs
=
1593 (* a case where one smpl parameter matches a list of C parameters *)
1594 match A.unwrap ea
,ebs
with
1595 A.VoidParam ta
, ys
->
1597 (match eas, ebs
with
1599 let {B.p_register
=(hasreg
,iihasreg
);
1601 p_type
=tb
; } = eb
in
1603 if idbopt
=*= None
&& not hasreg
1606 | (qub
, (B.BaseType
B.Void
,_
)) ->
1607 fullType ta tb
>>= (fun ta tb
->
1609 [(A.VoidParam ta
) +> A.rewrap ea
],
1610 [Left
{B.p_register
=(hasreg
, iihasreg
);
1618 list_matcher match_dots build_dots match_comma build_comma
1619 match_metalist build_metalist mktermval
1620 special_cases parameter
X.distrf_params
1621 Lib_parsing_c.ii_of_params
eas ebs
1624 let split_register_param = fun (hasreg, idb, ii_b_s) ->
1625 match hasreg, idb, ii_b_s with
1626 | false, Some s, [i1] -> Left (s, [], i1)
1627 | true, Some s, [i1;i2] -> Left (s, [i1], i2)
1628 | _, None, ii -> Right ii
1629 | _ -> raise Impossible
1633 and parameter
= fun parama paramb
->
1634 match A.unwrap parama
, paramb
with
1635 A.MetaParam
(ida
,keep
,inherited
), eb
->
1636 (* todo: use quaopt, hasreg ? *)
1638 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_param eb
) in
1639 X.envf keep inherited
(ida
,Ast_c.MetaParamVal eb
,max_min) (fun () ->
1640 X.distrf_param ida eb
1641 ) >>= (fun ida eb
->
1642 return (A.MetaParam
(ida
,keep
,inherited
)+> A.rewrap parama
,eb
))
1643 | A.Param
(typa
, idaopt
), eb
->
1644 let {B.p_register
= (hasreg
,iihasreg
);
1645 p_namei
= nameidbopt
;
1646 p_type
= typb
;} = paramb
in
1648 fullType typa typb
>>= (fun typa typb
->
1649 match idaopt
, nameidbopt
with
1650 | Some ida
, Some nameidb
->
1651 (* todo: if minus on ida, should also minus the iihasreg ? *)
1652 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1654 A.Param
(typa
, Some ida
)+> A.rewrap parama
,
1655 {B.p_register
= (hasreg
, iihasreg
);
1656 p_namei
= Some
(nameidb
);
1662 A.Param
(typa
, None
)+> A.rewrap parama
,
1663 {B.p_register
=(hasreg
,iihasreg
);
1667 (* why handle this case ? because of transform_proto ? we may not
1668 * have an ident in the proto.
1669 * If have some plus on ida ? do nothing about ida ?
1671 (* not anymore !!! now that julia is handling the proto.
1672 | _, Right iihasreg ->
1675 ((hasreg, None, typb), iihasreg)
1679 | Some _
, None
-> fail
1680 | None
, Some _
-> fail)
1681 | (A.OptParam _
| A.UniqueParam _
), _
->
1682 failwith
"not handling Opt/Unique for Param"
1683 | A.Pcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
1686 (* ------------------------------------------------------------------------- *)
1687 and (declaration
: (A.mcodekind * bool * A.declaration
,B.declaration
) matcher
) =
1688 fun (mckstart
, allminus
, decla
) declb
->
1689 X.all_bound
(A.get_inherited decla
) >&&>
1690 match A.unwrap decla
, declb
with
1692 (* Un MetaDecl est introduit dans l'asttoctl pour sauter au dessus
1693 * de toutes les declarations qui sont au debut d'un fonction et
1694 * commencer le reste du match au premier statement. Alors, ca matche
1695 * n'importe quelle declaration. On n'a pas besoin d'ajouter
1696 * quoi que ce soit dans l'environnement. C'est une sorte de DDots.
1698 * When the SP want to remove the whole function, the minus is not
1699 * on the MetaDecl but on the MetaRuleElem. So there should
1700 * be no transform of MetaDecl, just matching are allowed.
1703 | A.MetaDecl
(ida
,keep
,inherited
), _
->
1705 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_decl declb
) in
1706 X.envf keep inherited
(ida
, Ast_c.MetaDeclVal declb
, max_min) (fun () ->
1707 X.distrf_decl ida declb
1708 ) >>= (fun ida declb
->
1709 return ((mckstart
, allminus
,
1710 (A.MetaDecl
(ida
, keep
, inherited
))+> A.rewrap decla
),
1712 | _
, (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
)) ->
1713 onedecl allminus decla
(var
,iiptvirgb
,iisto
) >>=
1714 (fun decla
(var
,iiptvirgb
,iisto
)->
1715 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1717 (mckstart
, allminus
, decla
),
1718 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1721 | _
, (B.DeclList
(xs
, iiptvirgb
::iifakestart
::iisto
)) ->
1723 let rec loop n
= function
1725 | x
::xs
-> (n
,x
)::(loop (n
+1) xs
) in
1727 let rec repln n vl cur
= function
1730 if n
= cur
then vl
:: xs
else x
:: (repln n vl
(cur
+1) xs
) in
1731 if X.mode
=*= PatternMode
|| A.get_safe_decl decla
1733 (indexify xs
) +> List.fold_left
(fun acc
(n
,var
) ->
1734 (* consider all possible matches *)
1735 acc
>||> (function tin
-> (
1736 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1737 onedecl allminus decla
(var
, iiptvirgb
, iisto
) >>=
1738 (fun decla
(var
, iiptvirgb
, iisto
) ->
1740 (mckstart
, allminus
, decla
),
1741 (* adjust the variable that was chosen *)
1742 (B.DeclList
(repln n var
0 xs
,
1743 iiptvirgb
::iifakestart
::iisto
))
1747 failwith
"More that one variable in decl. Have to split to transform."
1749 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
), B.MacroDecl
((sb
,ebs
),ii
) ->
1750 let (iisb
, lpb
, rpb
, iiendb
, iifakestart
, iistob
) =
1752 | iisb
::lpb
::rpb
::iiendb
::iifakestart
::iisto
->
1753 (iisb
,lpb
,rpb
,iiendb
, iifakestart
,iisto
)
1754 | _
-> raise Impossible
1757 then minusize_list iistob
1758 else return ((), iistob
)
1759 ) >>= (fun () iistob
->
1761 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1762 ident DontKnow sa
(sb
, iisb
) >>= (fun sa
(sb
, iisb
) ->
1763 tokenf lpa lpb
>>= (fun lpa lpb
->
1764 tokenf rpa rpb
>>= (fun rpa rpb
->
1765 tokenf enda iiendb
>>= (fun enda iiendb
->
1766 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
1767 let eas = redots
eas easundots
in
1770 (mckstart
, allminus
,
1771 (A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
)) +> A.rewrap decla
),
1772 (B.MacroDecl
((sb
,ebs
),
1773 [iisb
;lpb
;rpb
;iiendb
;iifakestart
] ++ iistob
))
1776 | _
, (B.MacroDecl _
|B.DeclList _
) -> fail
1779 and onedecl
= fun allminus decla
(declb
, iiptvirgb
, iistob
) ->
1780 X.all_bound
(A.get_inherited decla
) >&&>
1781 match A.unwrap decla
, declb
with
1783 (* kind of typedef iso, we must unfold, it's for the case
1784 * T { }; that we want to match against typedef struct { } xx_t;
1787 | A.TyDecl
(tya0
, ptvirga
),
1788 ({B.v_namei
= Some
(nameidb
, None
);
1790 B.v_storage
= (B.StoTypedef
, inl
);
1793 B.v_type_bis
= typb0bis
;
1796 (match A.unwrap tya0
, typb0
with
1797 | A.Type
(cv1
,tya1
), ((qu
,il
),typb1
) ->
1799 (match A.unwrap tya1
, typb1
with
1800 | A.StructUnionDef
(tya2
, lba
, declsa
, rba
),
1801 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
1803 let (iisub
, iisbopt
, lbb
, rbb
) =
1806 let (iisub
, lbb
, rbb
) = tuple_of_list3 ii
in
1807 (iisub
, [], lbb
, rbb
)
1810 "warning: both a typedef (%s) and struct name introduction (%s)"
1811 (Ast_c.str_of_name nameidb
) s
1813 pr2 "warning: I will consider only the typedef";
1814 let (iisub
, iisb
, lbb
, rbb
) = tuple_of_list4 ii
in
1815 (iisub
, [iisb
], lbb
, rbb
)
1818 structdef_to_struct_name
1819 (Ast_c.nQ
, (B.StructUnion
(sub
, sbopt
, declsb
), ii
))
1822 Ast_c.nQ
,((B.TypeName
(nameidb
, Some
1823 (Lib_parsing_c.al_type
structnameb))), [])
1826 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1827 tokenf lba lbb
>>= (fun lba lbb
->
1828 tokenf rba rbb
>>= (fun rba rbb
->
1829 struct_fields
(A.undots declsa
) declsb
>>=(fun undeclsa declsb
->
1830 let declsa = redots
declsa undeclsa
in
1832 (match A.unwrap tya2
with
1833 | A.Type
(cv3
, tya3
) ->
1834 (match A.unwrap tya3
with
1835 | A.MetaType
(ida
,keep
, inherited
) ->
1837 fullType tya2
fake_typeb >>= (fun tya2
fake_typeb ->
1839 A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1 in
1840 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1843 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1844 [iisub
] @ iisbopt
@ [lbb
;rbb
] in
1845 let typb0 = ((qu
, il
), typb1) in
1847 match fake_typeb with
1848 | _nQ
, ((B.TypeName
(nameidb
, _typ
)),[]) ->
1851 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1852 (({B.v_namei
= Some
(nameidb
, None
);
1854 B.v_storage
= (B.StoTypedef
, inl
);
1857 B.v_type_bis
= typb0bis
;
1859 iivirg
),iiptvirgb
,iistob
)
1861 | _
-> raise Impossible
1864 (* do we need EnumName here too? *)
1865 | A.StructUnionName
(sua
, sa
) ->
1866 fullType tya2
structnameb >>= (fun tya2
structnameb ->
1868 let tya1 = A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1
1870 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1872 match structnameb with
1873 | _nQ
, (B.StructUnionName
(sub
, s), [iisub
;iisbopt
]) ->
1875 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1876 [iisub
;iisbopt
;lbb
;rbb
] in
1877 let typb0 = ((qu
, il
), typb1) in
1880 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1881 (({B.v_namei
= Some
(nameidb
, None
);
1883 B.v_storage
= (B.StoTypedef
, inl
);
1886 B.v_type_bis
= typb0bis
;
1888 iivirg
),iiptvirgb
,iistob
)
1890 | _
-> raise Impossible
1892 | _
-> raise Impossible
1901 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1902 ({B.v_namei
= Some
(nameidb
, _
);B.v_storage
= (B.StoTypedef
,_
);}, iivirg
)
1905 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1906 ({B.v_namei
=Some
(nameidb
, _
);B.v_storage
=(B.StoTypedef
,_
);}, iivirg
)
1911 (* could handle iso here but handled in standard.iso *)
1912 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1913 ({B.v_namei
= Some
(nameidb
, None
);
1918 B.v_type_bis
= typbbis
;
1920 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1921 fullType typa typb
>>= (fun typa typb
->
1922 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1923 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1924 (fun stoa
(stob
, iistob
) ->
1926 (A.UnInit
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
1927 (({B.v_namei
= Some
(nameidb
, None
);
1932 B.v_type_bis
= typbbis
;
1937 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1938 ({B.v_namei
= Some
(nameidb
, Some
(iieqb
, inib
));
1943 B.v_type_bis
= typbbis
;
1946 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1947 tokenf eqa iieqb
>>= (fun eqa iieqb
->
1948 fullType typa typb
>>= (fun typa typb
->
1949 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1950 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1951 (fun stoa
(stob
, iistob
) ->
1952 initialiser inia inib
>>= (fun inia inib
->
1954 (A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
)) +> A.rewrap decla
,
1955 (({B.v_namei
= Some
(nameidb
, Some
(iieqb
, inib
));
1960 B.v_type_bis
= typbbis
;
1965 (* do iso-by-absence here ? allow typedecl and var ? *)
1966 | A.TyDecl
(typa
, ptvirga
),
1967 ({B.v_namei
= None
; B.v_type
= typb
;
1971 B.v_type_bis
= typbbis
;
1974 if stob
=*= (B.NoSto
, false)
1976 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1977 fullType typa typb
>>= (fun typa typb
->
1979 (A.TyDecl
(typa
, ptvirga
)) +> A.rewrap decla
,
1980 (({B.v_namei
= None
;
1985 B.v_type_bis
= typbbis
;
1986 }, iivirg
), iiptvirgb
, iistob
)
1991 | A.Typedef
(stoa
, typa
, ida
, ptvirga
),
1992 ({B.v_namei
= Some
(nameidb
, None
);
1994 B.v_storage
= (B.StoTypedef
,inline
);
1997 B.v_type_bis
= typbbis
;
2000 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2001 fullType typa typb
>>= (fun typa typb
->
2004 tokenf stoa iitypedef
>>= (fun stoa iitypedef
->
2005 return (stoa
, [iitypedef
])
2007 | _
-> failwith
"weird, have both typedef and inline or nothing";
2008 ) >>= (fun stoa iistob
->
2009 (match A.unwrap ida
with
2010 | A.MetaType
(_
,_
,_
) ->
2013 Ast_c.nQ
, ((B.TypeName
(nameidb
, Ast_c.noTypedefDef
())), [])
2015 fullTypebis ida
fake_typeb >>= (fun ida
fake_typeb ->
2016 match fake_typeb with
2017 | _nQ
, ((B.TypeName
(nameidb
, _typ
)), []) ->
2018 return (ida
, nameidb
)
2019 | _
-> raise Impossible
2024 | B.RegularName
(sb
, iidb
) ->
2025 let iidb1 = tuple_of_list1 iidb
in
2029 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
2031 (A.TypeName sa
) +> A.rewrap ida
,
2032 B.RegularName
(sb
, [iidb1])
2036 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
2040 | _
-> raise Impossible
2042 ) >>= (fun ida nameidb
->
2044 (A.Typedef
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
2045 (({B.v_namei
= Some
(nameidb
, None
);
2047 B.v_storage
= (B.StoTypedef
,inline
);
2050 B.v_type_bis
= typbbis
;
2058 | _
, ({B.v_namei
= None
;}, _
) ->
2059 (* old: failwith "no variable in this declaration, weird" *)
2064 | A.DisjDecl declas
, declb
->
2065 declas
+> List.fold_left
(fun acc decla
->
2067 (* (declaration (mckstart, allminus, decla) declb) *)
2068 (onedecl allminus decla
(declb
,iiptvirgb
, iistob
))
2073 (* only in struct type decls *)
2074 | A.Ddots
(dots
,whencode
), _
->
2077 | A.OptDecl _
, _
| A.UniqueDecl _
, _
->
2078 failwith
"not handling Opt/Unique Decl"
2080 | _
, ({B.v_namei
=Some _
}, _
) ->
2086 (* ------------------------------------------------------------------------- *)
2088 and (initialiser
: (A.initialiser
, Ast_c.initialiser
) matcher
) = fun ia ib
->
2089 X.all_bound
(A.get_inherited ia
) >&&>
2090 match (A.unwrap ia
,ib
) with
2092 | (A.MetaInit
(ida
,keep
,inherited
), ib
) ->
2094 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_ini ib
) in
2095 X.envf keep inherited
(ida
, Ast_c.MetaInitVal ib
, max_min)
2097 X.distrf_ini ida ib
>>= (fun ida ib
->
2099 A.MetaInit
(ida
,keep
,inherited
) +> A.rewrap ia
,
2104 | (A.InitExpr expa
, ib
) ->
2105 (match A.unwrap expa
, ib
with
2106 | A.Edots
(mcode, None
), ib
->
2107 X.distrf_ini
(dots2metavar mcode) ib
>>= (fun mcode ib
->
2110 (A.Edots
(metavar2dots mcode, None
) +> A.rewrap expa
)
2115 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
2117 | _
, (B.InitExpr expb
, ii
) ->
2119 expression expa expb
>>= (fun expa expb
->
2121 (A.InitExpr expa
) +> A.rewrap ia
,
2122 (B.InitExpr expb
, ii
)
2127 | (A.ArInitList
(ia1
, ias
, ia2
), (B.InitList ibs
, ii
)) ->
2129 | ib1::ib2
::iicommaopt
->
2130 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2131 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2132 ar_initialisers
(A.undots ias
) (ibs
, iicommaopt
) >>=
2133 (fun iasundots
(ibs
,iicommaopt
) ->
2135 (A.ArInitList
(ia1
, redots ias iasundots
, ia2
)) +> A.rewrap ia
,
2136 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2139 | _
-> raise Impossible
2142 | (A.StrInitList
(allminus
, ia1
, ias
, ia2
, []), (B.InitList ibs
, ii
)) ->
2144 | ib1::ib2
::iicommaopt
->
2145 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2146 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2147 str_initialisers allminus ias
(ibs
, iicommaopt
) >>=
2148 (fun ias
(ibs
,iicommaopt
) ->
2150 (A.StrInitList
(allminus
, ia1
, ias
, ia2
, [])) +> A.rewrap ia
,
2151 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2154 | _
-> raise Impossible
2157 | (A.StrInitList
(allminus
, i1
, ias
, i2
, whencode
),
2158 (B.InitList ibs
, _ii
)) ->
2159 failwith
"TODO: not handling whencode in initialisers"
2162 | (A.InitGccExt
(designatorsa
, ia2
, inia
),
2163 (B.InitDesignators
(designatorsb
, inib
), ii2
))->
2165 let iieq = tuple_of_list1 ii2
in
2167 tokenf ia2
iieq >>= (fun ia2
iieq ->
2168 designators designatorsa designatorsb
>>=
2169 (fun designatorsa designatorsb
->
2170 initialiser inia inib
>>= (fun inia inib
->
2172 (A.InitGccExt
(designatorsa
, ia2
, inia
)) +> A.rewrap ia
,
2173 (B.InitDesignators
(designatorsb
, inib
), [iieq])
2179 | (A.InitGccName
(ida
, ia1
, inia
), (B.InitFieldOld
(idb
, inib
), ii
)) ->
2182 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2183 initialiser inia inib
>>= (fun inia inib
->
2184 tokenf ia1 iicolon
>>= (fun ia1 iicolon
->
2186 (A.InitGccName
(ida
, ia1
, inia
)) +> A.rewrap ia
,
2187 (B.InitFieldOld
(idb
, inib
), [iidb
;iicolon
])
2194 | A.IComma
(comma
), _
->
2197 | A.UniqueIni _
,_
| A.OptIni _
,_
->
2198 failwith
"not handling Opt/Unique on initialisers"
2200 | _
, (B.InitIndexOld
(_
, _
), _
) -> fail
2201 | _
, (B.InitFieldOld
(_
, _
), _
) -> fail
2203 | _
, ((B.InitDesignators
(_
, _
)|B.InitList _
|B.InitExpr _
), _
)
2206 and designators dla dlb
=
2207 match (dla
,dlb
) with
2208 ([],[]) -> return ([], [])
2209 | ([],_
) | (_
,[]) -> fail
2210 | (da
::dla
,db
::dlb
) ->
2211 designator da db
>>= (fun da db
->
2212 designators dla dlb
>>= (fun dla dlb
->
2213 return (da
::dla
, db
::dlb
)))
2215 and designator da db
=
2217 (A.DesignatorField
(ia1
, ida
), (B.DesignatorField idb
,ii1
)) ->
2219 let (iidot
, iidb
) = tuple_of_list2 ii1
in
2220 tokenf ia1 iidot
>>= (fun ia1 iidot
->
2221 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2223 A.DesignatorField
(ia1
, ida
),
2224 (B.DesignatorField idb
, [iidot
;iidb
])
2227 | (A.DesignatorIndex
(ia1
,ea
,ia2
), (B.DesignatorIndex eb
, ii1
)) ->
2229 let (ib1, ib2
) = tuple_of_list2 ii1
in
2230 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2231 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2232 expression ea eb
>>= (fun ea eb
->
2234 A.DesignatorIndex
(ia1
,ea
,ia2
),
2235 (B.DesignatorIndex eb
, [ib1;ib2
])
2238 | (A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2239 (B.DesignatorRange
(e1b
, e2b
), ii1
)) ->
2241 let (ib1, ib2
, ib3
) = tuple_of_list3 ii1
in
2242 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2243 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2244 tokenf ia3 ib3
>>= (fun ia3 ib3
->
2245 expression e1a e1b
>>= (fun e1a e1b
->
2246 expression e2a e2b
>>= (fun e2a e2b
->
2248 A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2249 (B.DesignatorRange
(e1b
, e2b
), [ib1;ib2
;ib3
])
2251 | (_
, ((B.DesignatorField _
|B.DesignatorIndex _
|B.DesignatorRange _
), _
)) ->
2254 and str_initialisers
= fun allminus ias
(ibs
, iicomma
) ->
2255 let ias_unsplit = unsplit_icomma ias
in
2256 let ibs_split = resplit_initialiser ibs iicomma
in
2258 if need_unordered_initialisers ibs
2259 then initialisers_unordered2 allminus
ias_unsplit ibs_split >>=
2260 (fun ias_unsplit ibs_split ->
2262 split_icomma ias_unsplit,
2263 unsplit_initialiser ibs_split))
2266 and ar_initialisers
= fun ias
(ibs
, iicomma
) ->
2267 (* this doesn't check need_unordered_initialisers because ... can be
2268 implemented as ordered, even if it matches unordered initializers *)
2269 let ibs = resplit_initialiser ibs iicomma
in
2272 (List.map
(function (elem
,comma
) -> [Left elem
; Right
[comma
]]) ibs) in
2273 initialisers_ordered2 ias
ibs >>=
2274 (fun ias
ibs_split ->
2276 match List.rev
ibs_split with
2277 (Right comma
)::rest
-> (Ast_c.unsplit_comma
(List.rev rest
),comma
)
2278 | (Left _
)::_
-> (Ast_c.unsplit_comma
ibs_split,[]) (* possible *)
2280 return (ias
, (ibs,iicomma
)))
2282 and initialisers_ordered2
= fun ias
ibs ->
2284 match A.unwrap ea
with
2285 A.Idots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2287 let build_dots (mcode, optexpr
) = A.Idots
(mcode, optexpr
) in
2288 let match_comma ea
=
2289 match A.unwrap ea
with
2290 A.IComma ia1
-> Some ia1
2292 let build_comma ia1
= A.IComma ia1
in
2293 let match_metalist ea
= None
in
2294 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
2295 let mktermval v
= failwith
"not possible" in
2296 let special_cases ea
eas ebs
= None
in
2297 let no_ii x
= failwith
"not possible" in
2298 list_matcher match_dots build_dots match_comma build_comma
2299 match_metalist build_metalist mktermval
2300 special_cases initialiser
X.distrf_inis
no_ii ias
ibs
2303 and initialisers_unordered2
= fun allminus ias
ibs ->
2308 let rec loop = function
2309 [] -> return ([],[])
2310 | (ib
,comma
)::ibs ->
2311 X.distrf_ini
minusizer ib
>>= (fun _ ib
->
2312 tokenf minusizer comma
>>= (fun _ comma
->
2313 loop ibs >>= (fun l
ibs ->
2314 return(l
,(ib
,comma
)::ibs)))) in
2316 else return ([], ys
)
2318 let permut = Common.uncons_permut_lazy ys
in
2319 permut +> List.fold_left
(fun acc
((e
, pos
), rest
) ->
2321 (initialiser_comma x e
2323 let rest = Lazy.force
rest in
2324 initialisers_unordered2 allminus xs
rest >>= (fun xs
rest ->
2327 Common.insert_elem_pos
(e
, pos
) rest
2331 and initialiser_comma
(x
,xcomma
) (y
, commay
) =
2332 match A.unwrap xcomma
with
2334 tokenf commax commay
>>= (fun commax commay
->
2335 initialiser x y
>>= (fun x y
->
2337 (x
, (A.IComma commax
) +> A.rewrap xcomma
),
2339 | _
-> raise Impossible
(* unsplit_iicomma wrong *)
2341 (* ------------------------------------------------------------------------- *)
2342 and (struct_fields
: (A.declaration list
, B.field list
) matcher
) =
2345 match A.unwrap ea
with
2346 A.Ddots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2348 let build_dots (mcode, optexpr
) = A.Ddots
(mcode, optexpr
) in
2349 let match_comma ea
= None
in
2350 let build_comma ia1
= failwith
"not possible" in
2351 let match_metalist ea
= None
in
2352 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
2353 let mktermval v
= failwith
"not possible" in
2354 let special_cases ea
eas ebs
= None
in
2355 let no_ii x
= failwith
"not possible" in
2356 let make_ebs ebs
= List.map
(function x
-> Left x
) ebs
in
2357 let unmake_ebs ebs
=
2358 List.map
(function Left x
-> x
| Right x
-> failwith
"no right") ebs
in
2359 let distrf mcode startxs =
2360 let startxs = unmake_ebs startxs in
2361 X.distrf_struct_fields
mcode startxs >>=
2362 (fun mcode startxs -> return (mcode,make_ebs startxs)) in
2363 list_matcher match_dots build_dots match_comma build_comma
2364 match_metalist build_metalist mktermval
2365 special_cases struct_field
distrf no_ii eas (make_ebs ebs
) >>=
2366 (fun eas ebs
-> return (eas,unmake_ebs ebs
))
2368 and (struct_field
: (A.declaration
, B.field
) matcher
) = fun fa fb
->
2370 match A.unwrap fa
,fb
with
2371 | A.MetaField
(ida
,keep
,inherited
), _
->
2373 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_field fb
) in
2374 X.envf keep inherited
(ida
, Ast_c.MetaFieldVal fb
, max_min) (fun () ->
2375 X.distrf_field ida fb
2376 ) >>= (fun ida fb
->
2377 return ((A.MetaField
(ida
, keep
, inherited
))+> A.rewrap fa
,
2379 | _
,B.DeclarationField
(B.FieldDeclList
(onefield_multivars
,iiptvirg
)) ->
2381 let iiptvirgb = tuple_of_list1 iiptvirg
in
2383 (match onefield_multivars
with
2384 | [] -> raise Impossible
2385 | [onevar
,iivirg
] ->
2386 assert (null iivirg
);
2388 | B.BitField
(sopt
, typb
, _
, expr
) ->
2389 pr2_once
"warning: bitfield not handled by ast_cocci";
2391 | B.Simple
(None
, typb
) ->
2392 pr2_once
"warning: unamed struct field not handled by ast_cocci";
2394 | B.Simple
(Some nameidb
, typb
) ->
2396 (* build a declaration from a struct field *)
2397 let allminus = false in
2399 let stob = B.NoSto
, false in
2401 ({B.v_namei
= Some
(nameidb
, None
);
2404 B.v_local
= Ast_c.NotLocalDecl
;
2405 B.v_attr
= Ast_c.noattr
;
2406 B.v_type_bis
= ref None
;
2407 (* the struct field should also get expanded ? no it's not
2408 * important here, we will rematch very soon *)
2412 onedecl
allminus fa
(fake_var,iiptvirgb,iisto) >>=
2413 (fun fa
(var
,iiptvirgb,iisto) ->
2416 | ({B.v_namei
= Some
(nameidb
, None
);
2421 let onevar = B.Simple
(Some nameidb
, typb
) in
2425 ((B.DeclarationField
2426 (B.FieldDeclList
([onevar, iivirg
], [iiptvirgb])))
2429 | _
-> raise Impossible
2434 pr2_once
"PB: More that one variable in decl. Have to split";
2437 | _
,B.EmptyField _iifield
->
2440 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
),B.MacroDeclField
((sb
,ebs
),ii
) ->
2442 | _
,B.MacroDeclField
((sb
,ebs
),ii
) -> fail
2444 | _
,B.CppDirectiveStruct directive
-> fail
2445 | _
,B.IfdefStruct directive
-> fail
2448 and enum_fields
= fun eas ebs
->
2450 match A.unwrap ea
with
2451 A.Edots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2453 let build_dots (mcode, optexpr
) = A.Edots
(mcode, optexpr
) in
2454 let match_comma ea
=
2455 match A.unwrap ea
with
2456 A.EComma ia1
-> Some ia1
2458 let build_comma ia1
= A.EComma ia1
in
2459 let match_metalist ea
= None
in
2460 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
2461 let mktermval v
= failwith
"not possible" in
2462 let special_cases ea
eas ebs
= None
in
2463 list_matcher match_dots build_dots match_comma build_comma
2464 match_metalist build_metalist mktermval
2465 special_cases enum_field
X.distrf_enum_fields
2466 Lib_parsing_c.ii_of_enum_fields
eas ebs
2468 and enum_field ida idb
=
2469 X.all_bound
(A.get_inherited ida
) >&&>
2470 match A.unwrap ida
, idb
with
2471 A.Ident
(id
),(nameidb
,None
) ->
2472 ident_cpp DontKnow id nameidb
>>= (fun id nameidb
->
2473 return ((A.Ident id
) +> A.rewrap ida
, (nameidb
,None
)))
2474 | A.Assignment
(ea1
,opa
,ea2
,init
),(nameidb
,Some
(opbi,eb2
)) ->
2475 (match A.unwrap ea1
with
2477 ident_cpp DontKnow id nameidb
>>= (fun id nameidb
->
2478 expression ea2 eb2
>>= (fun ea2 eb2
->
2479 tokenf opa
opbi >>= (fun opa
opbi -> (* only one kind of assignop *)
2481 (A.Assignment
((A.Ident
(id
))+>A.rewrap ea1
,opa
,ea2
,init
)) +>
2483 (nameidb
,Some
(opbi,eb2
))))))
2484 | _
-> failwith
"not possible")
2485 | _
-> failwith
"not possible"
2487 (* ------------------------------------------------------------------------- *)
2488 and (fullType
: (A.fullType
, Ast_c.fullType
) matcher
) =
2490 X.optional_qualifier_flag
(fun optional_qualifier
->
2491 X.all_bound
(A.get_inherited typa
) >&&>
2492 match A.unwrap typa
, typb
with
2493 | A.Type
(cv
,ty1
), ((qu
,il
),ty2
) ->
2495 if qu
.B.const
&& qu
.B.volatile
2498 ("warning: the type is both const & volatile but cocci " ^
2499 "does not handle that");
2501 (* Drop out the const/volatile part that has been matched.
2502 * This is because a SP can contain const T v; in which case
2503 * later in match_t_t when we encounter a T, we must not add in
2504 * the environment the whole type.
2509 (* "iso-by-absence" *)
2512 fullTypebis ty1
((qu
,il
), ty2
) >>= (fun ty1 fullty2
->
2514 (A.Type
(None
, ty1
)) +> A.rewrap typa
,
2518 (match optional_qualifier
, qu
.B.const
|| qu
.B.volatile
with
2519 | false, false -> do_stuff ()
2520 | false, true -> fail
2521 | true, false -> do_stuff ()
2524 then pr2_once
"USING optional_qualifier builtin isomorphism";
2530 (* todo: can be __const__ ? can be const & volatile so
2531 * should filter instead ?
2533 (match term x
, il
with
2534 | A.Const
, [i1
] when qu
.B.const
->
2536 tokenf x i1
>>= (fun x i1
->
2537 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2539 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2543 | A.Volatile
, [i1
] when qu
.B.volatile
->
2544 tokenf x i1
>>= (fun x i1
->
2545 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2547 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2555 | A.DisjType typas
, typb
->
2557 List.fold_left
(fun acc typa
-> acc
>|+|> (fullType typa typb
)) fail
2559 | A.OptType
(_
), _
| A.UniqueType
(_
), _
2560 -> failwith
"not handling Opt/Unique on type"
2565 * Why not (A.typeC, Ast_c.typeC) matcher ?
2566 * because when there is MetaType, we want that T record the whole type,
2567 * including the qualifier, and so this type (and the new_il function in
2568 * preceding function).
2571 and (fullTypebis
: (A.typeC
, Ast_c.fullType
) matcher
) =
2573 X.all_bound
(A.get_inherited ta
) >&&>
2574 match A.unwrap ta
, tb
with
2577 | A.MetaType
(ida
,keep
, inherited
), typb
->
2579 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
2580 X.envf keep inherited
(ida
, B.MetaTypeVal typb
, max_min) (fun () ->
2581 X.distrf_type ida typb
>>= (fun ida typb
->
2583 A.MetaType
(ida
,keep
, inherited
) +> A.rewrap ta
,
2587 | unwrap
, (qub
, typb
) ->
2588 typeC ta typb
>>= (fun ta typb
->
2589 return (ta
, (qub
, typb
))
2592 and simulate_signed ta basea stringsa signaopt tb baseb ii rebuilda
=
2593 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2594 * And even if in baseb we have a Signed Int, that does not mean
2595 * that ii is of length 2, cos Signed is the default, so if in signa
2596 * we have Signed explicitely ? we cant "accrocher" this mcode to
2597 * something :( So for the moment when there is signed in cocci,
2598 * we force that there is a signed in c too (done in pattern.ml).
2600 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2603 (* handle some iso on type ? (cf complex C rule for possible implicit
2605 match basea
, baseb
with
2606 | A.VoidType
, B.Void
2607 | A.FloatType
, B.FloatType
(B.CFloat
)
2608 | A.DoubleType
, B.FloatType
(B.CDouble
)
2609 | A.SizeType
, B.SizeType
2610 | A.SSizeType
, B.SSizeType
2611 | A.PtrDiffType
,B.PtrDiffType
->
2612 assert (signaopt
=*= None
);
2613 let stringa = tuple_of_list1 stringsa
in
2614 let (ibaseb
) = tuple_of_list1 ii
in
2615 tokenf stringa ibaseb
>>= (fun stringa ibaseb
->
2617 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2618 (B.BaseType baseb
, [ibaseb
])
2621 | A.CharType
, B.IntType
B.CChar
when signaopt
=*= None
->
2622 let stringa = tuple_of_list1 stringsa
in
2623 let ibaseb = tuple_of_list1 ii
in
2624 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2626 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2627 (B.BaseType
(B.IntType
B.CChar
), [ibaseb])
2630 | A.CharType
,B.IntType
(B.Si
(_sign
, B.CChar2
)) when signaopt
<> None
->
2631 let stringa = tuple_of_list1 stringsa
in
2632 let ibaseb = tuple_of_list1 iibaseb
in
2633 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2634 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2636 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2637 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2640 | A.ShortType
, B.IntType
(B.Si
(_
, B.CShort
))
2641 | A.IntType
, B.IntType
(B.Si
(_
, B.CInt
))
2642 | A.LongType
, B.IntType
(B.Si
(_
, B.CLong
)) ->
2643 let stringa = tuple_of_list1 stringsa
in
2646 (* iso-by-presence ? *)
2647 (* when unsigned int in SP, allow have just unsigned in C ? *)
2648 if mcode_contain_plus (mcodekind stringa)
2652 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2654 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2655 (B.BaseType
(baseb
), iisignbopt
++ [])
2661 "warning: long int or short int not handled by ast_cocci";
2665 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2666 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2668 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2669 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2671 | _
-> raise Impossible
2676 | A.LongLongType
, B.IntType
(B.Si
(_
, B.CLongLong
)) ->
2677 let (string1a
,string2a
) = tuple_of_list2 stringsa
in
2679 [ibase1b
;ibase2b
] ->
2680 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2681 tokenf string1a ibase1b
>>= (fun base1a ibase1b
->
2682 tokenf string2a ibase2b
>>= (fun base2a ibase2b
->
2684 (rebuilda
([base1a
;base2a
], signaopt
)) +> A.rewrap ta
,
2685 (B.BaseType
(baseb
), iisignbopt
++ [ibase1b
;ibase2b
])
2687 | [] -> fail (* should something be done in this case? *)
2688 | _
-> raise Impossible
)
2691 | _
, B.FloatType
B.CLongDouble
2694 "warning: long double not handled by ast_cocci";
2697 | _
, (B.Void
|B.FloatType _
|B.IntType _
2698 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
2700 and simulate_signed_meta ta basea signaopt tb baseb ii rebuilda
=
2701 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2702 * And even if in baseb we have a Signed Int, that does not mean
2703 * that ii is of length 2, cos Signed is the default, so if in signa
2704 * we have Signed explicitely ? we cant "accrocher" this mcode to
2705 * something :( So for the moment when there is signed in cocci,
2706 * we force that there is a signed in c too (done in pattern.ml).
2708 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2710 let match_to_type rebaseb
=
2711 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2712 let fta = A.rewrap basea
(A.Type
(None
,basea
)) in
2713 let ftb = Ast_c.nQ
,(B.BaseType
(rebaseb
), iibaseb
) in
2714 fullType
fta ftb >>= (fun fta (_
,tb
) ->
2715 (match A.unwrap
fta,tb
with
2716 A.Type
(_
,basea
), (B.BaseType baseb
, ii
) ->
2718 (rebuilda
(basea
, signaopt
)) +> A.rewrap ta
,
2719 (B.BaseType
(baseb
), iisignbopt
++ ii
)
2721 | _
-> failwith
"not possible"))) in
2723 (* handle some iso on type ? (cf complex C rule for possible implicit
2726 | B.IntType
(B.Si
(_sign
, B.CChar2
)) ->
2727 match_to_type (B.IntType
B.CChar
)
2729 | B.IntType
(B.Si
(_
, ty
)) ->
2731 | [] -> fail (* metavariable has to match something *)
2733 | _
-> match_to_type (B.IntType
(B.Si
(B.Signed
, ty
)))
2737 | (B.Void
|B.FloatType _
|B.IntType _
2738 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
2740 and (typeC
: (A.typeC
, Ast_c.typeC
) matcher
) =
2742 match A.unwrap ta
, tb
with
2743 | A.BaseType
(basea
,stringsa
), (B.BaseType baseb
, ii
) ->
2744 simulate_signed ta basea stringsa None tb baseb ii
2745 (function (stringsa
, signaopt
) -> A.BaseType
(basea
,stringsa
))
2746 | A.SignedT
(signaopt
, Some basea
), (B.BaseType baseb
, ii
) ->
2747 (match A.unwrap basea
with
2748 A.BaseType
(basea1
,strings1
) ->
2749 simulate_signed ta basea1 strings1
(Some signaopt
) tb baseb ii
2750 (function (strings1
, Some signaopt
) ->
2753 Some
(A.rewrap basea
(A.BaseType
(basea1
,strings1
))))
2754 | _
-> failwith
"not possible")
2755 | A.MetaType
(ida
,keep
,inherited
) ->
2756 simulate_signed_meta ta basea
(Some signaopt
) tb baseb ii
2757 (function (basea
, Some signaopt
) ->
2758 A.SignedT
(signaopt
,Some basea
)
2759 | _
-> failwith
"not possible")
2760 | _
-> failwith
"not possible")
2761 | A.SignedT
(signa
,None
), (B.BaseType baseb
, ii
) ->
2762 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2763 (match iibaseb
, baseb
with
2764 | [], B.IntType
(B.Si
(_sign
, B.CInt
)) ->
2765 sign
(Some signa
) signbopt >>= (fun signaopt iisignbopt
->
2767 | None
-> raise Impossible
2770 (A.SignedT
(signa
,None
)) +> A.rewrap ta
,
2771 (B.BaseType baseb
, iisignbopt
)
2779 (* todo? iso with array *)
2780 | A.Pointer
(typa
, iamult
), (B.Pointer typb
, ii
) ->
2781 let (ibmult
) = tuple_of_list1 ii
in
2782 fullType typa typb
>>= (fun typa typb
->
2783 tokenf iamult ibmult
>>= (fun iamult ibmult
->
2785 (A.Pointer
(typa
, iamult
)) +> A.rewrap ta
,
2786 (B.Pointer typb
, [ibmult
])
2789 | A.FunctionType
(allminus,tyaopt
,lpa
,paramsa
,rpa
),
2790 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
) ->
2792 let (lpb
, rpb
) = tuple_of_list2 ii
in
2796 ("Not handling well variable length arguments func. "^
2797 "You have been warned");
2798 tokenf lpa lpb
>>= (fun lpa lpb
->
2799 tokenf rpa rpb
>>= (fun rpa rpb
->
2800 fullType_optional_allminus
allminus tyaopt tyb
>>= (fun tyaopt tyb
->
2801 parameters
(seqstyle paramsa
) (A.undots paramsa
) paramsb
>>=
2802 (fun paramsaundots paramsb
->
2803 let paramsa = redots
paramsa paramsaundots
in
2805 (A.FunctionType
(allminus,tyaopt
,lpa
,paramsa,rpa
) +> A.rewrap ta
,
2806 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), [lpb
;rpb
])
2814 | A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
),
2815 (B.ParenType t1
, ii
) ->
2816 let (lp1b
, rp1b
) = tuple_of_list2 ii
in
2817 let (qu1b
, t1b
) = t1
in
2819 | B.Pointer t2
, ii
->
2820 let (starb
) = tuple_of_list1 ii
in
2821 let (qu2b
, t2b
) = t2
in
2823 | B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
->
2824 let (lp2b
, rp2b
) = tuple_of_list2 ii
in
2829 ("Not handling well variable length arguments func. "^
2830 "You have been warned");
2832 fullType tya tyb
>>= (fun tya tyb
->
2833 tokenf lp1a lp1b
>>= (fun lp1a lp1b
->
2834 tokenf rp1a rp1b
>>= (fun rp1a rp1b
->
2835 tokenf lp2a lp2b
>>= (fun lp2a lp2b
->
2836 tokenf rp2a rp2b
>>= (fun rp2a rp2b
->
2837 tokenf stara starb
>>= (fun stara starb
->
2838 parameters
(seqstyle paramsa) (A.undots
paramsa) paramsb
>>=
2839 (fun paramsaundots paramsb
->
2840 let paramsa = redots
paramsa paramsaundots
in
2844 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))),
2849 (B.Pointer
t2, [starb
]))
2853 (A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
))
2855 (B.ParenType
t1, [lp1b
;rp1b
])
2868 (* todo: handle the iso on optionnal size specifification ? *)
2869 | A.Array
(typa
, ia1
, eaopt
, ia2
), (B.Array
(ebopt
, typb
), ii
) ->
2870 let (ib1, ib2
) = tuple_of_list2 ii
in
2871 fullType typa typb
>>= (fun typa typb
->
2872 option expression eaopt ebopt
>>= (fun eaopt ebopt
->
2873 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2874 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2876 (A.Array
(typa
, ia1
, eaopt
, ia2
)) +> A.rewrap ta
,
2877 (B.Array
(ebopt
, typb
), [ib1;ib2
])
2881 (* todo: could also match a Struct that has provided a name *)
2882 (* This is for the case where the SmPL code contains "struct x", without
2883 a definition. In this case, the name field is always present.
2884 This case is also called from the case for A.StructUnionDef when
2885 a name is present in the C code. *)
2886 | A.StructUnionName
(sua
, Some sa
), (B.StructUnionName
(sub
, sb
), ii
) ->
2887 (* sa is now an ident, not an mcode, old: ... && (term sa) =$= sb *)
2888 let (ib1, ib2
) = tuple_of_list2 ii
in
2889 if equal_structUnion (term sua
) sub
2891 ident DontKnow sa
(sb
, ib2
) >>= (fun sa
(sb
, ib2
) ->
2892 tokenf sua
ib1 >>= (fun sua
ib1 ->
2894 (A.StructUnionName
(sua
, Some sa
)) +> A.rewrap ta
,
2895 (B.StructUnionName
(sub
, sb
), [ib1;ib2
])
2900 | A.StructUnionDef
(ty
, lba
, declsa, rba
),
2901 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
2903 let (ii_sub_sb
, lbb
, rbb
) =
2905 [iisub
; lbb
; rbb
] -> (Common.Left iisub
,lbb
,rbb
)
2906 | [iisub
; iisb
; lbb
; rbb
] -> (Common.Right
(iisub
,iisb
),lbb
,rbb
)
2907 | _
-> failwith
"list of length 3 or 4 expected" in
2910 match (sbopt
,ii_sub_sb
) with
2911 (None
,Common.Left iisub
) ->
2912 (* the following doesn't reconstruct the complete SP code, just
2913 the part that matched *)
2915 match A.unwrap
s with
2917 (match A.unwrap ty
with
2918 A.StructUnionName
(sua
, None
) ->
2919 (match (term sua
, sub
) with
2921 | (A.Union
,B.Union
) -> return ((),())
2924 tokenf sua iisub
>>= (fun sua iisub
->
2927 A.StructUnionName
(sua
, None
) +> A.rewrap
ty)
2929 return (ty,[iisub
])))
2931 | A.DisjType
(disjs
) ->
2933 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
2937 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
2939 (* build a StructUnionName from a StructUnion *)
2940 let fake_su = B.nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) in
2942 fullType
ty fake_su >>= (fun ty fake_su ->
2944 | _nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) ->
2945 return (ty, [iisub
; iisb
])
2946 | _
-> raise Impossible
)
2950 >>= (fun ty ii_sub_sb
->
2952 tokenf lba lbb
>>= (fun lba lbb
->
2953 tokenf rba rbb
>>= (fun rba rbb
->
2954 struct_fields
(A.undots
declsa) declsb
>>=(fun undeclsa declsb
->
2955 let declsa = redots
declsa undeclsa
in
2958 (A.StructUnionDef
(ty, lba
, declsa, rba
)) +> A.rewrap ta
,
2959 (B.StructUnion
(sub
, sbopt
, declsb
),ii_sub_sb
@[lbb
;rbb
])
2963 (* todo? handle isomorphisms ? because Unsigned Int can be match on a
2964 * uint in the C code. But some CEs consists in renaming some types,
2965 * so we don't want apply isomorphisms every time.
2967 | A.TypeName sa
, (B.TypeName
(nameb
, typb
), noii
) ->
2971 | B.RegularName
(sb
, iidb
) ->
2972 let iidb1 = tuple_of_list1 iidb
in
2976 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
2978 (A.TypeName sa
) +> A.rewrap ta
,
2979 (B.TypeName
(B.RegularName
(sb
, [iidb1]), typb
), noii
)
2983 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
2988 | _
, (B.TypeOfExpr e
, ii
) -> fail
2989 | _
, (B.TypeOfType e
, ii
) -> fail
2991 | _
, (B.ParenType e
, ii
) -> fail (* todo ?*)
2992 | A.EnumName
(en
,Some namea
), (B.EnumName nameb
, ii
) ->
2993 let (ib1,ib2
) = tuple_of_list2 ii
in
2994 ident DontKnow namea
(nameb
, ib2
) >>= (fun namea
(nameb
, ib2
) ->
2995 tokenf en
ib1 >>= (fun en
ib1 ->
2997 (A.EnumName
(en
, Some namea
)) +> A.rewrap ta
,
2998 (B.EnumName nameb
, [ib1;ib2
])
3001 | A.EnumDef
(ty, lba
, idsa
, rba
),
3002 (B.Enum
(sbopt
, idsb
), ii
) ->
3004 let (ii_sub_sb
, lbb
, rbb
, comma_opt
) =
3006 [iisub
; lbb
; rbb
; comma_opt
] ->
3007 (Common.Left iisub
,lbb
,rbb
,comma_opt
)
3008 | [iisub
; iisb
; lbb
; rbb
; comma_opt
] ->
3009 (Common.Right
(iisub
,iisb
),lbb
,rbb
,comma_opt
)
3010 | _
-> failwith
"list of length 4 or 5 expected" in
3013 match (sbopt
,ii_sub_sb
) with
3014 (None
,Common.Left iisub
) ->
3015 (* the following doesn't reconstruct the complete SP code, just
3016 the part that matched *)
3018 match A.unwrap
s with
3020 (match A.unwrap
ty with
3021 A.EnumName
(sua
, None
) ->
3022 tokenf sua iisub
>>= (fun sua iisub
->
3024 A.Type
(None
,A.EnumName
(sua
, None
) +> A.rewrap
ty)
3026 return (ty,[iisub
]))
3028 | A.DisjType
(disjs
) ->
3030 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
3034 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
3036 (* build an EnumName from an Enum *)
3037 let fake_su = B.nQ
, (B.EnumName sb
, [iisub
;iisb
]) in
3039 fullType
ty fake_su >>= (fun ty fake_su ->
3041 | _nQ
, (B.EnumName sb
, [iisub
;iisb
]) ->
3042 return (ty, [iisub
; iisb
])
3043 | _
-> raise Impossible
)
3047 >>= (fun ty ii_sub_sb
->
3049 tokenf lba lbb
>>= (fun lba lbb
->
3050 tokenf rba rbb
>>= (fun rba rbb
->
3051 let idsb = resplit_initialiser idsb [comma_opt
] in
3055 (function (elem
,comma
) -> [Left elem
; Right
[comma
]])
3057 enum_fields
(A.undots idsa
) idsb >>= (fun unidsa
idsb ->
3058 let idsa = redots
idsa unidsa
in
3060 match List.rev
idsb with
3061 (Right comma
)::rest ->
3062 (Ast_c.unsplit_comma
(List.rev
rest),comma
)
3063 | (Left _
)::_
-> (Ast_c.unsplit_comma
idsb,[]) (* possible *)
3066 (A.EnumDef
(ty, lba
, idsa, rba
)) +> A.rewrap ta
,
3067 (B.Enum
(sbopt
, idsb),ii_sub_sb
@[lbb
;rbb
]@iicomma
)
3071 | _
, (B.Enum _
, _
) -> fail (* todo cocci ?*)
3074 ((B.TypeName _
| B.StructUnionName
(_
, _
) | B.EnumName _
|
3075 B.StructUnion
(_
, _
, _
) |
3076 B.FunctionType _
| B.Array
(_
, _
) | B.Pointer _
|
3082 (* todo: iso on sign, if not mentioned then free. tochange?
3083 * but that require to know if signed int because explicit
3084 * signed int, or because implicit signed int.
3087 and sign signa signb
=
3088 match signa
, signb
with
3089 | None
, None
-> return (None
, [])
3090 | Some signa
, Some
(signb
, ib
) ->
3091 if equal_sign (term signa
) signb
3092 then tokenf signa ib
>>= (fun signa ib
->
3093 return (Some signa
, [ib
])
3099 and minusize_list iixs
=
3100 iixs
+> List.fold_left
(fun acc ii
->
3101 acc
>>= (fun xs ys
->
3102 tokenf minusizer ii
>>= (fun minus ii
->
3103 return (minus
::xs
, ii
::ys
)
3104 ))) (return ([],[]))
3105 >>= (fun _xsminys ys
->
3106 return ((), List.rev ys
)
3109 and storage_optional_allminus
allminus stoa
(stob, iistob
) =
3110 (* "iso-by-absence" for storage, and return type. *)
3111 X.optional_storage_flag
(fun optional_storage
->
3112 match stoa
, stob with
3113 | None
, (stobis
, inline
) ->
3117 minusize_list iistob
>>= (fun () iistob
->
3118 return (None
, (stob, iistob
))
3120 else return (None
, (stob, iistob
))
3123 (match optional_storage
, stobis
with
3124 | false, B.NoSto
-> do_minus ()
3126 | true, B.NoSto
-> do_minus ()
3129 then pr2_once
"USING optional_storage builtin isomorphism";
3133 | Some x
, ((stobis
, inline
)) ->
3134 if equal_storage (term x
) stobis
3136 let rec loop acc
= function
3139 let str = B.str_of_info i1
in
3141 "static" | "extern" | "auto" | "register" ->
3142 (* not very elegant, but tokenf doesn't know what token to
3144 tokenf x i1
>>= (fun x i1
->
3145 let rebuilt = (List.rev acc
) @ i1
:: iistob
in
3146 return (Some x
, ((stobis
, inline
), rebuilt)))
3147 | _
-> loop (i1
::acc
) iistob
) in
3152 and inline_optional_allminus
allminus inla
(stob, iistob
) =
3153 (* "iso-by-absence" for storage, and return type. *)
3154 X.optional_storage_flag
(fun optional_storage
->
3155 match inla
, stob with
3156 | None
, (stobis
, inline
) ->
3160 minusize_list iistob
>>= (fun () iistob
->
3161 return (None
, (stob, iistob
))
3163 else return (None
, (stob, iistob
))
3172 then pr2_once
"USING optional_storage builtin isomorphism";
3175 else fail (* inline not in SP and present in C code *)
3178 | Some x
, ((stobis
, inline
)) ->
3181 let rec loop acc
= function
3184 let str = B.str_of_info i1
in
3187 (* not very elegant, but tokenf doesn't know what token to
3189 tokenf x i1
>>= (fun x i1
->
3190 let rebuilt = (List.rev acc
) @ i1
:: iistob
in
3191 return (Some x
, ((stobis
, inline
), rebuilt)))
3192 | _
-> loop (i1
::acc
) iistob
) in
3194 else fail (* SP has inline, but the C code does not *)
3197 and fullType_optional_allminus
allminus tya retb
=
3202 X.distrf_type
minusizer retb
>>= (fun _x retb
->
3206 else return (None
, retb
)
3208 fullType tya retb
>>= (fun tya retb
->
3209 return (Some tya
, retb
)
3214 (*---------------------------------------------------------------------------*)
3216 and compatible_base_type a signa b
=
3217 let ok = return ((),()) in
3220 | Type_cocci.VoidType
, B.Void
3221 | Type_cocci.SizeType
, B.SizeType
3222 | Type_cocci.SSizeType
, B.SSizeType
3223 | Type_cocci.PtrDiffType
, B.PtrDiffType
->
3224 assert (signa
=*= None
);
3226 | Type_cocci.CharType
, B.IntType
B.CChar
when signa
=*= None
->
3228 | Type_cocci.CharType
, B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3229 compatible_sign signa signb
3230 | Type_cocci.ShortType
, B.IntType
(B.Si
(signb
, B.CShort
)) ->
3231 compatible_sign signa signb
3232 | Type_cocci.IntType
, B.IntType
(B.Si
(signb
, B.CInt
)) ->
3233 compatible_sign signa signb
3234 | Type_cocci.LongType
, B.IntType
(B.Si
(signb
, B.CLong
)) ->
3235 compatible_sign signa signb
3236 | _
, B.IntType
(B.Si
(signb
, B.CLongLong
)) ->
3237 pr2_once
"no longlong in cocci";
3239 | Type_cocci.FloatType
, B.FloatType
B.CFloat
->
3240 assert (signa
=*= None
);
3242 | Type_cocci.DoubleType
, B.FloatType
B.CDouble
->
3243 assert (signa
=*= None
);
3245 | _
, B.FloatType
B.CLongDouble
->
3246 pr2_once
"no longdouble in cocci";
3248 | Type_cocci.BoolType
, _
-> failwith
"no booltype in C"
3250 | _
, (B.Void
|B.FloatType _
|B.IntType _
3251 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
3253 and compatible_base_type_meta a signa qua b ii
local =
3255 | Type_cocci.MetaType
(ida
,keep
,inherited
),
3256 B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3257 compatible_sign signa signb
>>= fun _ _
->
3258 let newb = ((qua
, (B.BaseType
(B.IntType
B.CChar
),ii
)),local) in
3259 compatible_type a
newb
3260 | Type_cocci.MetaType
(ida
,keep
,inherited
), B.IntType
(B.Si
(signb
, ty)) ->
3261 compatible_sign signa signb
>>= fun _ _
->
3263 ((qua
, (B.BaseType
(B.IntType
(B.Si
(B.Signed
, ty))),ii
)),local) in
3264 compatible_type a
newb
3265 | _
, B.FloatType
B.CLongDouble
->
3266 pr2_once
"no longdouble in cocci";
3269 | _
, (B.Void
|B.FloatType _
|B.IntType _
3270 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
3273 and compatible_type a
(b
,local) =
3274 let ok = return ((),()) in
3276 let rec loop = function
3277 | Type_cocci.BaseType a
, (qua
, (B.BaseType b
,ii
)) ->
3278 compatible_base_type a None b
3280 | Type_cocci.SignedT
(signa
,None
), (qua
, (B.BaseType b
,ii
)) ->
3281 compatible_base_type
Type_cocci.IntType
(Some signa
) b
3283 | Type_cocci.SignedT
(signa
,Some
ty), (qua
, (B.BaseType b
,ii
)) ->
3285 Type_cocci.BaseType
ty ->
3286 compatible_base_type
ty (Some signa
) b
3287 | Type_cocci.MetaType
(ida
,keep
,inherited
) ->
3288 compatible_base_type_meta
ty (Some signa
) qua b ii
local
3289 | _
-> failwith
"not possible")
3291 | Type_cocci.Pointer a
, (qub
, (B.Pointer b
, ii
)) ->
3293 | Type_cocci.FunctionPointer a
, _
->
3295 "TODO: function pointer type doesn't store enough information to determine compatability"
3296 | Type_cocci.Array a
, (qub
, (B.Array
(eopt
, b
),ii
)) ->
3297 (* no size info for cocci *)
3299 | Type_cocci.StructUnionName
(sua
, name
),
3300 (qub
, (B.StructUnionName
(sub
, sb
),ii
)) ->
3301 if equal_structUnion_type_cocci sua sub
3302 then structure_type_name name sb ii
3304 | Type_cocci.EnumName
(name
),
3305 (qub
, (B.EnumName
(sb
),ii
)) -> structure_type_name name sb ii
3306 | Type_cocci.TypeName sa
, (qub
, (B.TypeName
(namesb
, _typb
),noii
)) ->
3307 let sb = Ast_c.str_of_name namesb
in
3312 | Type_cocci.ConstVol
(qua
, a
), (qub
, b
) ->
3313 if (fst qub
).B.const
&& (fst qub
).B.volatile
3316 pr2_once
("warning: the type is both const & volatile but cocci " ^
3317 "does not handle that");
3323 | Type_cocci.Const
-> (fst qub
).B.const
3324 | Type_cocci.Volatile
-> (fst qub
).B.volatile
3326 then loop (a
,(Ast_c.nQ
, b
))
3329 | Type_cocci.MetaType
(ida
,keep
,inherited
), typb
->
3331 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
3332 X.envf keep inherited
(A.make_mcode ida
, B.MetaTypeVal typb
, max_min)
3336 (* subtil: must be after the MetaType case *)
3337 | a
, (qub
, (B.TypeName
(_namesb
, Some b
), noii
)) ->
3338 (* kind of typedef iso *)
3341 (* for metavariables of type expression *^* *)
3342 | Type_cocci.Unknown
, _
-> ok
3347 B.TypeOfType _
|B.TypeOfExpr _
|B.ParenType _
|
3348 B.EnumName _
|B.StructUnion
(_
, _
, _
)|B.Enum
(_
, _
)
3355 B.StructUnionName
(_
, _
)|
3357 B.Array
(_
, _
)|B.Pointer _
|B.TypeName _
|
3362 and structure_type_name nm
sb ii
=
3364 Type_cocci.NoName
-> ok
3365 | Type_cocci.Name sa
->
3369 | Type_cocci.MV
(ida
,keep
,inherited
) ->
3370 (* degenerate version of MetaId, no transformation possible *)
3371 let (ib1, ib2
) = tuple_of_list2 ii
in
3372 let max_min _
= Lib_parsing_c.lin_col_by_pos
[ib2
] in
3373 let mida = A.make_mcode ida
in
3374 X.envf keep inherited
(mida, B.MetaIdVal
(sb,[]), max_min)
3380 and compatible_sign signa signb
=
3381 let ok = return ((),()) in
3382 match signa
, signb
with
3384 | Some
Type_cocci.Signed
, B.Signed
3385 | Some
Type_cocci.Unsigned
, B.UnSigned
3390 and equal_structUnion_type_cocci a b
=
3392 | Type_cocci.Struct
, B.Struct
-> true
3393 | Type_cocci.Union
, B.Union
-> true
3394 | _
, (B.Struct
| B.Union
) -> false
3398 (*---------------------------------------------------------------------------*)
3399 and inc_file
(a
, before_after
) (b
, h_rel_pos
) =
3401 let rec aux_inc (ass
, bss
) passed
=
3405 let passed = List.rev
passed in
3407 (match before_after
, !h_rel_pos
with
3408 | IncludeNothing
, _
-> true
3409 | IncludeMcodeBefore
, Some x
->
3410 List.mem
passed (x
.Ast_c.first_of
)
3412 | IncludeMcodeAfter
, Some x
->
3413 List.mem
passed (x
.Ast_c.last_of
)
3415 (* no info, maybe cos of a #include <xx.h> that was already in a .h *)
3419 | (A.IncPath x
)::xs
, y
::ys
-> x
=$
= y
&& aux_inc (xs
, ys
) (x
::passed)
3420 | _
-> failwith
"IncDots not in last place or other pb"
3425 | A.Local ass
, B.Local bss
->
3426 aux_inc (ass
, bss
) []
3427 | A.NonLocal ass
, B.NonLocal bss
->
3428 aux_inc (ass
, bss
) []
3433 (*---------------------------------------------------------------------------*)
3435 and (define_params
: sequence
->
3436 (A.define_param list
, (string B.wrap
) B.wrap2 list
) matcher
) =
3437 fun seqstyle eas ebs
->
3439 | Unordered
-> failwith
"not handling ooo"
3441 define_paramsbis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
3442 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
3445 (* todo? facto code with argument and parameters ? *)
3446 and define_paramsbis
= fun eas ebs
->
3448 match A.unwrap ea
with
3449 A.DPdots
(mcode) -> Some
(mcode, None
)
3451 let build_dots (mcode, _optexpr
) = A.DPdots
(mcode) in
3452 let match_comma ea
=
3453 match A.unwrap ea
with
3454 A.DPComma ia1
-> Some ia1
3456 let build_comma ia1
= A.DPComma ia1
in
3457 let match_metalist ea
= None
in
3458 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
3459 let mktermval v
= failwith
"not possible" in
3460 let special_cases ea
eas ebs
= None
in
3461 let no_ii x
= failwith
"not possible" in
3462 list_matcher match_dots build_dots match_comma build_comma
3463 match_metalist build_metalist mktermval
3464 special_cases define_parameter
X.distrf_define_params
no_ii eas ebs
3466 and define_parameter
= fun parama paramb
->
3467 match A.unwrap parama
, paramb
with
3468 A.DParam ida
, (idb
, ii
) ->
3469 let ib1 = tuple_of_list1 ii
in
3470 ident DontKnow ida
(idb
, ib1) >>= (fun ida
(idb
, ib1) ->
3471 return ((A.DParam ida
)+> A.rewrap parama
,(idb
, [ib1])))
3472 | (A.OptDParam _
| A.UniqueDParam _
), _
->
3473 failwith
"handling Opt/Unique for define parameters"
3474 | A.DPcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
3477 (*****************************************************************************)
3479 (*****************************************************************************)
3481 (* no global solution for positions here, because for a statement metavariable
3482 we want a MetaStmtVal, and for the others, it's not clear what we want *)
3484 let rec (rule_elem_node
: (A.rule_elem
, Control_flow_c.node
) matcher
) =
3487 x
>>= (fun a b
-> return (A.rewrap re a
, F.rewrap node b
))
3489 X.all_bound
(A.get_inherited re
) >&&>
3492 match A.unwrap re
, F.unwrap node
with
3494 (* note: the order of the clauses is important. *)
3496 | _
, F.Enter
| _
, F.Exit
| _
, F.ErrorExit
-> fail2()
3498 (* the metaRuleElem contains just '-' information. We dont need to add
3499 * stuff in the environment. If we need stuff in environment, because
3500 * there is a + S somewhere, then this will be done via MetaStmt, not
3502 * Can match TrueNode/FalseNode/... so must be placed before those cases.
3505 | A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
->
3506 let default = A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
in
3507 (match unwrap_node
with
3509 | F.TrueNode
| F.FalseNode
| F.AfterNode
3510 | F.LoopFallThroughNode
| F.FallThroughNode
3512 if X.mode
=*= PatternMode
3515 if mcode_contain_plus (mcodekind mcode)
3516 then failwith
"try add stuff on fake node"
3517 (* minusize or contextize a fake node is ok *)
3520 | F.EndStatement None
->
3521 if X.mode
=*= PatternMode
then return default
3523 (* DEAD CODE NOW ? only useful in -no_cocci_vs_c_3 ?
3524 if mcode_contain_plus (mcodekind mcode)
3526 let fake_info = Ast_c.fakeInfo() in
3527 distrf distrf_node (mcodekind mcode)
3528 (F.EndStatement (Some fake_info))
3529 else return unwrap_node
3533 | F.EndStatement
(Some i1
) ->
3534 tokenf mcode i1
>>= (fun mcode i1
->
3536 A.MetaRuleElem
(mcode,keep
, inherited
),
3537 F.EndStatement
(Some i1
)
3541 if X.mode
=*= PatternMode
then return default
3542 else failwith
"a MetaRuleElem can't transform a headfunc"
3544 if X.mode
=*= PatternMode
then return default
3546 X.distrf_node
(generalize_mcode mcode) node
>>= (fun mcode node
->
3548 A.MetaRuleElem
(mcode,keep
, inherited
),
3554 (* rene cant have found that a state containing a fake/exit/... should be
3556 * TODO: and F.Fake ?
3558 | _
, F.EndStatement _
| _
, F.CaseNode _
3559 | _
, F.TrueNode
| _
, F.FalseNode
| _
, F.AfterNode
3560 | _
, F.FallThroughNode
| _
, F.LoopFallThroughNode
3561 | _
, F.InLoopNode
-> fail2()
3563 (* really ? diff between pattern.ml and transformation.ml *)
3564 | _
, F.Fake
-> fail2()
3567 (* cas general: a Meta can match everything. It matches only
3568 * "header"-statement. We transform only MetaRuleElem, not MetaStmt.
3569 * So can't have been called in transform.
3571 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), F.Decl
(_
) -> fail
3573 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), unwrap_node
->
3574 (* todo: should not happen in transform mode *)
3576 (match Control_flow_c.extract_fullstatement node
with
3579 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_stmt stb
) in
3580 X.envf keep inherited
(ida
, Ast_c.MetaStmtVal stb
, max_min)
3582 (* no need tag ida, we can't be called in transform-mode *)
3584 A.MetaStmt
(ida
, keep
, metainfoMaybeTodo
, inherited
),
3592 | A.MetaStmtList _
, _
->
3593 failwith
"not handling MetaStmtList"
3595 | A.TopExp ea
, F.DefineExpr eb
->
3596 expression ea eb
>>= (fun ea eb
->
3602 | A.TopExp ea
, F.DefineType eb
->
3603 (match A.unwrap ea
with
3605 fullType ft eb
>>= (fun ft eb
->
3607 A.TopExp
(A.rewrap ea
(A.TypeExp
(ft
))),
3614 (* It is important to put this case before the one that fails because
3615 * of the lack of the counter part of a C construct in SmPL (for instance
3616 * there is not yet a CaseRange in SmPL). Even if SmPL don't handle
3617 * yet certain constructs, those constructs may contain expression
3618 * that we still want and can transform.
3621 | A.Exp exp
, nodeb
->
3623 (* kind of iso, initialisation vs affectation *)
3625 match A.unwrap exp
, nodeb
with
3626 | A.Assignment
(ea
, op
, eb
, true), F.Decl decl
->
3627 initialisation_to_affectation decl
+> F.rewrap node
3632 (* Now keep fullstatement inside the control flow node,
3633 * so that can then get in a MetaStmtVar the fullstatement to later
3634 * pp back when the S is in a +. But that means that
3635 * Exp will match an Ifnode even if there is no such exp
3636 * inside the condition of the Ifnode (because the exp may
3637 * be deeper, in the then branch). So have to not visit
3638 * all inside a node anymore.
3640 * update: j'ai choisi d'accrocher au noeud du CFG Ã la
3641 * fois le fullstatement et le partialstatement et appeler le
3642 * visiteur que sur le partialstatement.
3645 match Ast_cocci.get_pos re
with
3646 | None
-> expression
3650 Lib_parsing_c.max_min_by_pos
(Lib_parsing_c.ii_of_expr eb
) in
3651 let keep = Type_cocci.Unitary
in
3652 let inherited = false in
3653 let max_min _
= failwith
"no pos" in
3654 X.envf
keep inherited (pos
, B.MetaPosVal
(min
,max
), max_min)
3660 X.cocciExp
expfn exp
node >>= (fun exp
node ->
3668 X.cocciTy fullType
ty node >>= (fun ty node ->
3675 | A.TopInit init
, nodeb
->
3676 X.cocciInit initialiser init
node >>= (fun init
node ->
3684 | A.FunHeader
(mckstart
, allminus, fninfoa
, ida
, oparen
, paramsa, cparen
),
3685 F.FunHeader
({B.f_name
= nameidb
;
3686 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3690 f_old_c_style
= oldstyle
;
3695 then pr2 "OLD STYLE DECL NOT WELL SUPPORTED";
3698 (* fninfoa records the order in which the SP specified the various
3699 information, but this isn't taken into account in the matching.
3700 Could this be a problem for transformation? *)
3703 List.filter
(function A.FStorage
(s) -> true | _
-> false) fninfoa
3704 with [A.FStorage
(s)] -> Some
s | _
-> None
in
3706 match List.filter
(function A.FType
(s) -> true | _
-> false) fninfoa
3707 with [A.FType
(t
)] -> Some t
| _
-> None
in
3710 match List.filter
(function A.FInline
(i
) -> true | _
-> false) fninfoa
3711 with [A.FInline
(i
)] -> Some i
| _
-> None
in
3713 (match List.filter
(function A.FAttr
(a
) -> true | _
-> false) fninfoa
3714 with [A.FAttr
(a
)] -> failwith
"not checking attributes" | _
-> ());
3717 | ioparenb
::icparenb
::iifakestart
::iistob
->
3719 (* maybe important to put ident as the first tokens to transform.
3720 * It's related to transform_proto. So don't change order
3723 ident_cpp LocalFunction ida nameidb
>>= (fun ida nameidb
->
3724 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
3725 tokenf oparen ioparenb
>>= (fun oparen ioparenb
->
3726 tokenf cparen icparenb
>>= (fun cparen icparenb
->
3727 parameters
(seqstyle paramsa)
3728 (A.undots
paramsa) paramsb
>>=
3729 (fun paramsaundots paramsb
->
3730 let paramsa = redots
paramsa paramsaundots
in
3731 inline_optional_allminus
allminus
3732 inla (stob, iistob
) >>= (fun inla (stob, iistob
) ->
3733 storage_optional_allminus
allminus
3734 stoa (stob, iistob
) >>= (fun stoa (stob, iistob
) ->
3739 ("Not handling well variable length arguments func. "^
3740 "You have been warned");
3742 then minusize_list iidotsb
3743 else return ((),iidotsb
)
3744 ) >>= (fun () iidotsb
->
3746 fullType_optional_allminus
allminus tya retb
>>= (fun tya retb
->
3749 (match stoa with Some st
-> [A.FStorage st
] | None
-> []) ++
3750 (match inla with Some i
-> [A.FInline i
] | None
-> []) ++
3751 (match tya with Some t
-> [A.FType t
] | None
-> [])
3756 A.FunHeader
(mckstart
,allminus,fninfoa,ida
,oparen
,
3758 F.FunHeader
({B.f_name
= nameidb
;
3759 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3763 f_old_c_style
= oldstyle
; (* TODO *)
3765 ioparenb
::icparenb
::iifakestart
::iistob
)
3768 | _
-> raise Impossible
3776 | A.Decl
(mckstart
,allminus,decla
), F.Decl declb
->
3777 declaration
(mckstart
,allminus,decla
) declb
>>=
3778 (fun (mckstart
,allminus,decla
) declb
->
3780 A.Decl
(mckstart
,allminus,decla
),
3785 | A.SeqStart
mcode, F.SeqStart
(st
, level
, i1
) ->
3786 tokenf mcode i1
>>= (fun mcode i1
->
3789 F.SeqStart
(st
, level
, i1
)
3792 | A.SeqEnd
mcode, F.SeqEnd
(level
, i1
) ->
3793 tokenf mcode i1
>>= (fun mcode i1
->
3796 F.SeqEnd
(level
, i1
)
3799 | A.ExprStatement
(ea
, ia1
), F.ExprStatement
(st
, (Some eb
, ii
)) ->
3800 let ib1 = tuple_of_list1 ii
in
3801 expression ea eb
>>= (fun ea eb
->
3802 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3804 A.ExprStatement
(ea
, ia1
),
3805 F.ExprStatement
(st
, (Some eb
, [ib1]))
3810 | A.IfHeader
(ia1
,ia2
, ea
, ia3
), F.IfHeader
(st
, (eb
,ii
)) ->
3811 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3812 expression ea eb
>>= (fun ea eb
->
3813 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3814 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3815 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3817 A.IfHeader
(ia1
, ia2
, ea
, ia3
),
3818 F.IfHeader
(st
, (eb
,[ib1;ib2
;ib3
]))
3821 | A.Else ia
, F.Else ib
->
3822 tokenf ia ib
>>= (fun ia ib
->
3823 return (A.Else ia
, F.Else ib
)
3826 | A.WhileHeader
(ia1
, ia2
, ea
, ia3
), F.WhileHeader
(st
, (eb
, ii
)) ->
3827 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3828 expression ea eb
>>= (fun ea eb
->
3829 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3830 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3831 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3833 A.WhileHeader
(ia1
, ia2
, ea
, ia3
),
3834 F.WhileHeader
(st
, (eb
, [ib1;ib2
;ib3
]))
3837 | A.DoHeader ia
, F.DoHeader
(st
, ib
) ->
3838 tokenf ia ib
>>= (fun ia ib
->
3843 | A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
), F.DoWhileTail
(eb
, ii
) ->
3844 let (ib1, ib2
, ib3
, ib4
) = tuple_of_list4 ii
in
3845 expression ea eb
>>= (fun ea eb
->
3846 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3847 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3848 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3849 tokenf ia4 ib4
>>= (fun ia4 ib4
->
3851 A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
),
3852 F.DoWhileTail
(eb
, [ib1;ib2
;ib3
;ib4
])
3854 | A.IteratorHeader
(ia1
, ia2
, eas, ia3
), F.MacroIterHeader
(st
, ((s,ebs
),ii
))
3856 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3858 ident DontKnow ia1
(s, ib1) >>= (fun ia1
(s, ib1) ->
3859 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3860 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3861 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
3862 let eas = redots
eas easundots
in
3864 A.IteratorHeader
(ia1
, ia2
, eas, ia3
),
3865 F.MacroIterHeader
(st
, ((s,ebs
), [ib1;ib2
;ib3
]))
3870 | A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3871 F.ForHeader
(st
, (((eb1opt
,ib3s
), (eb2opt
,ib4s
), (eb3opt
,ib4vide
)), ii
))
3873 assert (null ib4vide
);
3874 let (ib1, ib2
, ib5
) = tuple_of_list3 ii
in
3875 let ib3 = tuple_of_list1 ib3s
in
3876 let ib4 = tuple_of_list1 ib4s
in
3878 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3879 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3880 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3881 tokenf ia4
ib4 >>= (fun ia4
ib4 ->
3882 tokenf ia5 ib5
>>= (fun ia5 ib5
->
3883 option expression ea1opt eb1opt
>>= (fun ea1opt eb1opt
->
3884 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
3885 option expression ea3opt eb3opt
>>= (fun ea3opt eb3opt
->
3887 A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3888 F.ForHeader
(st
, (((eb1opt
,[ib3]), (eb2opt
,[ib4]), (eb3opt
,[])),
3894 | A.SwitchHeader
(ia1
,ia2
,ea
,ia3
), F.SwitchHeader
(st
, (eb
,ii
)) ->
3895 let (ib1, ib2
, ib3) = tuple_of_list3 ii
in
3896 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3897 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3898 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3899 expression ea eb
>>= (fun ea eb
->
3901 A.SwitchHeader
(ia1
,ia2
,ea
,ia3
),
3902 F.SwitchHeader
(st
, (eb
,[ib1;ib2
;ib3]))
3905 | A.Break
(ia1
, ia2
), F.Break
(st
, ((),ii
)) ->
3906 let (ib1, ib2
) = tuple_of_list2 ii
in
3907 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3908 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3911 F.Break
(st
, ((),[ib1;ib2
]))
3914 | A.Continue
(ia1
, ia2
), F.Continue
(st
, ((),ii
)) ->
3915 let (ib1, ib2
) = tuple_of_list2 ii
in
3916 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3917 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3919 A.Continue
(ia1
, ia2
),
3920 F.Continue
(st
, ((),[ib1;ib2
]))
3923 | A.Return
(ia1
, ia2
), F.Return
(st
, ((),ii
)) ->
3924 let (ib1, ib2
) = tuple_of_list2 ii
in
3925 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3926 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3928 A.Return
(ia1
, ia2
),
3929 F.Return
(st
, ((),[ib1;ib2
]))
3932 | A.ReturnExpr
(ia1
, ea
, ia2
), F.ReturnExpr
(st
, (eb
, ii
)) ->
3933 let (ib1, ib2
) = tuple_of_list2 ii
in
3934 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3935 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3936 expression ea eb
>>= (fun ea eb
->
3938 A.ReturnExpr
(ia1
, ea
, ia2
),
3939 F.ReturnExpr
(st
, (eb
, [ib1;ib2
]))
3944 | A.Include
(incla
,filea
),
3945 F.Include
{B.i_include
= (fileb
, ii
);
3946 B.i_rel_pos
= h_rel_pos
;
3947 B.i_is_in_ifdef
= inifdef
;
3950 assert (copt
=*= None
);
3952 let include_requirment =
3953 match mcodekind incla
, mcodekind filea
with
3954 | A.CONTEXT
(_
, A.BEFORE _
), _
->
3956 | _
, A.CONTEXT
(_
, A.AFTER _
) ->
3962 let (inclb
, iifileb
) = tuple_of_list2 ii
in
3963 if inc_file
(term filea
, include_requirment) (fileb
, h_rel_pos
)
3965 tokenf incla inclb
>>= (fun incla inclb
->
3966 tokenf filea iifileb
>>= (fun filea iifileb
->
3968 A.Include
(incla
, filea
),
3969 F.Include
{B.i_include
= (fileb
, [inclb
;iifileb
]);
3970 B.i_rel_pos
= h_rel_pos
;
3971 B.i_is_in_ifdef
= inifdef
;
3979 | A.DefineHeader
(definea
,ida
,params
), F.DefineHeader
((idb
, ii
), defkind
) ->
3980 let (defineb
, iidb
, ieol
) = tuple_of_list3 ii
in
3981 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
3982 tokenf definea defineb
>>= (fun definea defineb
->
3983 (match A.unwrap params
, defkind
with
3984 | A.NoParams
, B.DefineVar
->
3986 A.NoParams
+> A.rewrap params
,
3989 | A.DParams
(lpa
,eas,rpa
), (B.DefineFunc
(ebs
, ii
)) ->
3990 let (lpb
, rpb
) = tuple_of_list2 ii
in
3991 tokenf lpa lpb
>>= (fun lpa lpb
->
3992 tokenf rpa rpb
>>= (fun rpa rpb
->
3994 define_params
(seqstyle eas) (A.undots
eas) ebs
>>=
3995 (fun easundots ebs
->
3996 let eas = redots
eas easundots
in
3998 A.DParams
(lpa
,eas,rpa
) +> A.rewrap params
,
3999 B.DefineFunc
(ebs
,[lpb
;rpb
])
4003 ) >>= (fun params defkind
->
4005 A.DefineHeader
(definea
, ida
, params
),
4006 F.DefineHeader
((idb
,[defineb
;iidb
;ieol
]),defkind
)
4011 | A.Default
(def
,colon
), F.Default
(st
, ((),ii
)) ->
4012 let (ib1, ib2
) = tuple_of_list2 ii
in
4013 tokenf def
ib1 >>= (fun def
ib1 ->
4014 tokenf colon ib2
>>= (fun colon ib2
->
4016 A.Default
(def
,colon
),
4017 F.Default
(st
, ((),[ib1;ib2
]))
4022 | A.Case
(case
,ea
,colon
), F.Case
(st
, (eb
,ii
)) ->
4023 let (ib1, ib2
) = tuple_of_list2 ii
in
4024 tokenf case
ib1 >>= (fun case
ib1 ->
4025 expression ea eb
>>= (fun ea eb
->
4026 tokenf colon ib2
>>= (fun colon ib2
->
4028 A.Case
(case
,ea
,colon
),
4029 F.Case
(st
, (eb
,[ib1;ib2
]))
4032 (* only occurs in the predicates generated by asttomember *)
4033 | A.DisjRuleElem
eas, _
->
4035 List.fold_left
(fun acc ea
-> acc
>|+|> (rule_elem_node ea
node)) fail)
4036 >>= (fun ea eb
-> return (A.unwrap ea
,F.unwrap eb
))
4038 | _
, F.ExprStatement
(_
, (None
, ii
)) -> fail (* happen ? *)
4040 | A.Label
(id
,dd
), F.Label
(st
, nameb
, ((),ii
)) ->
4041 let (ib2
) = tuple_of_list1 ii
in
4042 ident_cpp DontKnow id nameb
>>= (fun ida nameb
->
4043 tokenf dd ib2
>>= (fun dd ib2
->
4046 F.Label
(st
,nameb
, ((),[ib2
]))
4049 | A.Goto
(goto
,id
,sem
), F.Goto
(st
,nameb
, ((),ii
)) ->
4050 let (ib1,ib3) = tuple_of_list2 ii
in
4051 tokenf goto
ib1 >>= (fun goto
ib1 ->
4052 ident_cpp DontKnow id nameb
>>= (fun id nameb
->
4053 tokenf sem
ib3 >>= (fun sem
ib3 ->
4055 A.Goto
(goto
,id
,sem
),
4056 F.Goto
(st
,nameb
, ((),[ib1;ib3]))
4059 (* have not a counter part in coccinelle, for the moment *)
4060 (* todo?: print a warning at least ? *)
4066 | _
, (F.IfdefEndif _
|F.IfdefElse _
|F.IfdefHeader _
)
4070 (F.MacroStmt
(_
, _
)| F.DefineDoWhileZeroHeader _
| F.EndNode
|F.TopNode
)
4073 (F.Label
(_
, _
, _
)|F.Break
(_
, _
)|F.Continue
(_
, _
)|F.Default
(_
, _
)|
4074 F.Case
(_
, _
)|F.Include _
|F.Goto _
|F.ExprStatement _
|
4075 F.DefineType _
|F.DefineExpr _
|F.DefineTodo
|
4076 F.DefineHeader
(_
, _
)|F.ReturnExpr
(_
, _
)|F.Return
(_
, _
)|F.MacroIterHeader
(_
, _
)|
4077 F.SwitchHeader
(_
, _
)|F.ForHeader
(_
, _
)|F.DoWhileTail _
|F.DoHeader
(_
, _
)|
4078 F.WhileHeader
(_
, _
)|F.Else _
|F.IfHeader
(_
, _
)|
4079 F.SeqEnd
(_
, _
)|F.SeqStart
(_
, _
, _
)|
4080 F.Decl _
|F.FunHeader _
)