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 _
,_
),_
)
1363 | _
, ((B.New _
,_
),_
)
1368 (((B.Cast
(_
, _
)|B.ParenExpr _
|B.SizeOfType _
|B.SizeOfExpr _
|
1369 B.RecordPtAccess
(_
, _
)|
1370 B.RecordAccess
(_
, _
)|B.ArrayAccess
(_
, _
)|
1371 B.Binary
(_
, _
, _
)|B.Unary
(_
, _
)|
1372 B.Infix
(_
, _
)|B.Postfix
(_
, _
)|
1373 B.Assignment
(_
, _
, _
)|B.CondExpr
(_
, _
, _
)|
1374 B.FunCall
(_
, _
)|B.Constant _
|B.Ident _
),
1382 (* ------------------------------------------------------------------------- *)
1383 and (ident_cpp
: info_ident
-> (A.ident, B.name
) matcher
) =
1384 fun infoidb ida idb
->
1386 | B.RegularName
(s, iis) ->
1387 let iis = tuple_of_list1
iis in
1388 ident infoidb ida
(s, iis) >>= (fun ida
(s,iis) ->
1391 (B.RegularName
(s, [iis]))
1393 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
1395 (* This should be moved to the Id case of ident. Metavariables
1396 should be allowed to be bound to such variables. But doing so
1397 would require implementing an appropriate distr function *)
1400 and (ident: info_ident
-> (A.ident, string * Ast_c.info
) matcher
) =
1401 fun infoidb ida
((idb
, iib
) as ib
) -> (* (idb, iib) as ib *)
1402 let check_constraints constraints idb
=
1403 let meta_id_val l x
= Ast_c.MetaIdVal
(x
,l
) in
1404 match constraints
with
1405 A.IdNoConstraint
-> return (meta_id_val [],())
1406 | A.IdNegIdSet
(str
,meta
) ->
1407 X.check_idconstraint
satisfies_iconstraint str idb
1408 (fun () -> return (meta_id_val meta
,()))
1409 | A.IdRegExpConstraint re
->
1410 X.check_idconstraint
satisfies_regexpconstraint re idb
1411 (fun () -> return (meta_id_val [],())) in
1412 X.all_bound
(A.get_inherited ida
) >&&>
1413 match A.unwrap ida
with
1415 if (term sa
) =$
= idb
then
1416 tokenf sa iib
>>= (fun sa iib
->
1418 ((A.Id sa
)) +> A.rewrap ida
,
1423 | A.MetaId
(mida
,constraints
,keep
,inherited
) ->
1424 check_constraints constraints idb
>>=
1426 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1427 (* use drop_pos for ids so that the pos is not added a second time in
1428 the call to tokenf *)
1429 X.envf keep inherited
(A.drop_pos mida
, wrapper idb
, max_min)
1431 tokenf mida iib
>>= (fun mida iib
->
1433 ((A.MetaId
(mida
, constraints
, keep
, inherited
)) +> A.rewrap ida
,
1438 | A.MetaFunc
(mida
,constraints
,keep
,inherited
) ->
1440 check_constraints constraints idb
>>=
1442 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1443 X.envf keep inherited
(A.drop_pos mida
,Ast_c.MetaFuncVal idb
,max_min)
1445 tokenf mida iib
>>= (fun mida iib
->
1447 ((A.MetaFunc
(mida
,constraints
,keep
,inherited
)))+>A.rewrap ida
,
1452 | LocalFunction
| Function
-> is_function()
1454 failwith
"MetaFunc, need more semantic info about id"
1455 (* the following implementation could possibly be useful, if one
1456 follows the convention that a macro is always in capital letters
1457 and that a macro is not a function.
1458 (if idb =~ "^[A-Z_][A-Z_0-9]*$" then fail else is_function())*)
1461 | A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
) ->
1464 check_constraints constraints idb
>>=
1466 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1467 X.envf keep inherited
1468 (A.drop_pos mida
,Ast_c.MetaLocalFuncVal idb
, max_min)
1470 tokenf mida iib
>>= (fun mida iib
->
1472 ((A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
)))
1478 | DontKnow
-> failwith
"MetaLocalFunc, need more semantic info about id"
1481 (* not clear why disj things are needed, after disjdistr? *)
1483 ias
+> List.fold_left
(fun acc ia
-> acc
>|+|> (ident infoidb ia ib
)) fail
1485 | A.OptIdent _
| A.UniqueIdent _
->
1486 failwith
"not handling Opt/Unique for ident"
1488 (* ------------------------------------------------------------------------- *)
1489 and (arguments
: sequence
->
1490 (A.expression list
, Ast_c.argument
Ast_c.wrap2 list
) matcher
) =
1491 fun seqstyle eas ebs
->
1493 | Unordered
-> failwith
"not handling ooo"
1495 arguments_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1496 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1498 (* because '...' can match nothing, need to take care when have
1499 * ', ...' or '...,' as in f(..., X, Y, ...). It must match
1500 * f(1,2) for instance.
1501 * So I have added special cases such as (if startxs = []) and code
1502 * in the Ecomma matching rule.
1504 * old: Must do some try, for instance when f(...,X,Y,...) have to
1505 * test the transfo for all the combinaitions and if multiple transfo
1506 * possible ? pb ? => the type is to return a expression option ? use
1507 * some combinators to help ?
1508 * update: with the tag-SP approach, no more a problem.
1511 and arguments_bis
= fun eas ebs
->
1513 match A.unwrap ea
with
1514 A.Edots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
1516 let build_dots (mcode, optexpr
) = A.Edots
(mcode, optexpr
) in
1517 let match_comma ea
=
1518 match A.unwrap ea
with
1519 A.EComma ia1
-> Some ia1
1521 let build_comma ia1
= A.EComma ia1
in
1522 let match_metalist ea
=
1523 match A.unwrap ea
with
1524 A.MetaExprList
(ida
,leninfo
,keep
,inherited
) ->
1525 Some
(ida
,leninfo
,keep
,inherited
)
1527 let build_metalist (ida
,leninfo
,keep
,inherited
) =
1528 A.MetaExprList
(ida
,leninfo
,keep
,inherited
) in
1529 let mktermval v
= Ast_c.MetaExprListVal v
in
1530 let special_cases ea
eas ebs
= None
in
1531 list_matcher match_dots build_dots match_comma build_comma
1532 match_metalist build_metalist mktermval
1533 special_cases argument
X.distrf_args
1534 Lib_parsing_c.ii_of_args
eas ebs
1536 and argument arga argb
=
1537 X.all_bound
(A.get_inherited arga
) >&&>
1538 match A.unwrap arga
, argb
with
1540 Right
(B.ArgType
{B.p_register
=b
,iib
; p_namei
=sopt
;p_type
=tyb
}) ->
1541 if b
|| sopt
<> None
1543 (* failwith "the argument have a storage and ast_cocci does not have"*)
1546 (* b = false and sopt = None *)
1547 fullType tya tyb
>>= (fun tya tyb
->
1549 (A.TypeExp tya
) +> A.rewrap arga
,
1550 (Right
(B.ArgType
{B.p_register
=(b
,iib
);
1555 | A.TypeExp tya
, _
-> fail
1556 | _
, Right
(B.ArgType _
) -> fail
1558 expression arga argb
>>= (fun arga argb
->
1559 return (arga
, Left argb
)
1561 | _
, Right
(B.ArgAction y
) -> fail
1564 (* ------------------------------------------------------------------------- *)
1565 (* todo? facto code with argument ? *)
1566 and (parameters
: sequence
->
1567 (A.parameterTypeDef list
, Ast_c.parameterType
Ast_c.wrap2 list
)
1569 fun seqstyle eas ebs
->
1571 | Unordered
-> failwith
"not handling ooo"
1573 parameters_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1574 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1578 and parameters_bis
eas ebs
=
1580 match A.unwrap ea
with
1581 A.Pdots
(mcode) -> Some
(mcode, None
)
1583 let build_dots (mcode, _optexpr
) = A.Pdots
(mcode) in
1584 let match_comma ea
=
1585 match A.unwrap ea
with
1586 A.PComma ia1
-> Some ia1
1588 let build_comma ia1
= A.PComma ia1
in
1589 let match_metalist ea
=
1590 match A.unwrap ea
with
1591 A.MetaParamList
(ida
,leninfo
,keep
,inherited
) ->
1592 Some
(ida
,leninfo
,keep
,inherited
)
1594 let build_metalist (ida
,leninfo
,keep
,inherited
) =
1595 A.MetaParamList
(ida
,leninfo
,keep
,inherited
) in
1596 let mktermval v
= Ast_c.MetaParamListVal v
in
1597 let special_cases ea
eas ebs
=
1598 (* a case where one smpl parameter matches a list of C parameters *)
1599 match A.unwrap ea
,ebs
with
1600 A.VoidParam ta
, ys
->
1602 (match eas, ebs
with
1604 let {B.p_register
=(hasreg
,iihasreg
);
1606 p_type
=tb
; } = eb
in
1608 if idbopt
=*= None
&& not hasreg
1611 | (qub
, (B.BaseType
B.Void
,_
)) ->
1612 fullType ta tb
>>= (fun ta tb
->
1614 [(A.VoidParam ta
) +> A.rewrap ea
],
1615 [Left
{B.p_register
=(hasreg
, iihasreg
);
1623 list_matcher match_dots build_dots match_comma build_comma
1624 match_metalist build_metalist mktermval
1625 special_cases parameter
X.distrf_params
1626 Lib_parsing_c.ii_of_params
eas ebs
1629 let split_register_param = fun (hasreg, idb, ii_b_s) ->
1630 match hasreg, idb, ii_b_s with
1631 | false, Some s, [i1] -> Left (s, [], i1)
1632 | true, Some s, [i1;i2] -> Left (s, [i1], i2)
1633 | _, None, ii -> Right ii
1634 | _ -> raise Impossible
1638 and parameter
= fun parama paramb
->
1639 match A.unwrap parama
, paramb
with
1640 A.MetaParam
(ida
,keep
,inherited
), eb
->
1641 (* todo: use quaopt, hasreg ? *)
1643 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_param eb
) in
1644 X.envf keep inherited
(ida
,Ast_c.MetaParamVal eb
,max_min) (fun () ->
1645 X.distrf_param ida eb
1646 ) >>= (fun ida eb
->
1647 return (A.MetaParam
(ida
,keep
,inherited
)+> A.rewrap parama
,eb
))
1648 | A.Param
(typa
, idaopt
), eb
->
1649 let {B.p_register
= (hasreg
,iihasreg
);
1650 p_namei
= nameidbopt
;
1651 p_type
= typb
;} = paramb
in
1653 fullType typa typb
>>= (fun typa typb
->
1654 match idaopt
, nameidbopt
with
1655 | Some ida
, Some nameidb
->
1656 (* todo: if minus on ida, should also minus the iihasreg ? *)
1657 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1659 A.Param
(typa
, Some ida
)+> A.rewrap parama
,
1660 {B.p_register
= (hasreg
, iihasreg
);
1661 p_namei
= Some
(nameidb
);
1667 A.Param
(typa
, None
)+> A.rewrap parama
,
1668 {B.p_register
=(hasreg
,iihasreg
);
1672 (* why handle this case ? because of transform_proto ? we may not
1673 * have an ident in the proto.
1674 * If have some plus on ida ? do nothing about ida ?
1676 (* not anymore !!! now that julia is handling the proto.
1677 | _, Right iihasreg ->
1680 ((hasreg, None, typb), iihasreg)
1684 | Some _
, None
-> fail
1685 | None
, Some _
-> fail)
1686 | (A.OptParam _
| A.UniqueParam _
), _
->
1687 failwith
"not handling Opt/Unique for Param"
1688 | A.Pcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
1691 (* ------------------------------------------------------------------------- *)
1692 and (declaration
: (A.mcodekind * bool * A.declaration
,B.declaration
) matcher
) =
1693 fun (mckstart
, allminus
, decla
) declb
->
1694 X.all_bound
(A.get_inherited decla
) >&&>
1695 match A.unwrap decla
, declb
with
1697 (* Un MetaDecl est introduit dans l'asttoctl pour sauter au dessus
1698 * de toutes les declarations qui sont au debut d'un fonction et
1699 * commencer le reste du match au premier statement. Alors, ca matche
1700 * n'importe quelle declaration. On n'a pas besoin d'ajouter
1701 * quoi que ce soit dans l'environnement. C'est une sorte de DDots.
1703 * When the SP want to remove the whole function, the minus is not
1704 * on the MetaDecl but on the MetaRuleElem. So there should
1705 * be no transform of MetaDecl, just matching are allowed.
1708 | A.MetaDecl
(ida
,keep
,inherited
), _
->
1710 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_decl declb
) in
1711 X.envf keep inherited
(ida
, Ast_c.MetaDeclVal declb
, max_min) (fun () ->
1712 X.distrf_decl ida declb
1713 ) >>= (fun ida declb
->
1714 return ((mckstart
, allminus
,
1715 (A.MetaDecl
(ida
, keep
, inherited
))+> A.rewrap decla
),
1717 | _
, (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
)) ->
1718 onedecl allminus decla
(var
,iiptvirgb
,iisto
) >>=
1719 (fun decla
(var
,iiptvirgb
,iisto
)->
1720 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1722 (mckstart
, allminus
, decla
),
1723 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1726 | _
, (B.DeclList
(xs
, iiptvirgb
::iifakestart
::iisto
)) ->
1728 let rec loop n
= function
1730 | x
::xs
-> (n
,x
)::(loop (n
+1) xs
) in
1732 let rec repln n vl cur
= function
1735 if n
= cur
then vl
:: xs
else x
:: (repln n vl
(cur
+1) xs
) in
1736 if X.mode
=*= PatternMode
|| A.get_safe_decl decla
1738 (indexify xs
) +> List.fold_left
(fun acc
(n
,var
) ->
1739 (* consider all possible matches *)
1740 acc
>||> (function tin
-> (
1741 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1742 onedecl allminus decla
(var
, iiptvirgb
, iisto
) >>=
1743 (fun decla
(var
, iiptvirgb
, iisto
) ->
1745 (mckstart
, allminus
, decla
),
1746 (* adjust the variable that was chosen *)
1747 (B.DeclList
(repln n var
0 xs
,
1748 iiptvirgb
::iifakestart
::iisto
))
1752 failwith
"More that one variable in decl. Have to split to transform. Check that there is no transformation on the type or the ;"
1754 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
), B.MacroDecl
((sb
,ebs
),ii
) ->
1755 let (iisb
, lpb
, rpb
, iiendb
, iifakestart
, iistob
) =
1757 | iisb
::lpb
::rpb
::iiendb
::iifakestart
::iisto
->
1758 (iisb
,lpb
,rpb
,iiendb
, iifakestart
,iisto
)
1759 | _
-> raise Impossible
1762 then minusize_list iistob
1763 else return ((), iistob
)
1764 ) >>= (fun () iistob
->
1766 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1767 ident DontKnow sa
(sb
, iisb
) >>= (fun sa
(sb
, iisb
) ->
1768 tokenf lpa lpb
>>= (fun lpa lpb
->
1769 tokenf rpa rpb
>>= (fun rpa rpb
->
1770 tokenf enda iiendb
>>= (fun enda iiendb
->
1771 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
1772 let eas = redots
eas easundots
in
1775 (mckstart
, allminus
,
1776 (A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
)) +> A.rewrap decla
),
1777 (B.MacroDecl
((sb
,ebs
),
1778 [iisb
;lpb
;rpb
;iiendb
;iifakestart
] ++ iistob
))
1781 | _
, (B.MacroDecl _
|B.DeclList _
) -> fail
1784 and onedecl
= fun allminus decla
(declb
, iiptvirgb
, iistob
) ->
1785 X.all_bound
(A.get_inherited decla
) >&&>
1786 match A.unwrap decla
, declb
with
1788 (* kind of typedef iso, we must unfold, it's for the case
1789 * T { }; that we want to match against typedef struct { } xx_t;
1792 | A.TyDecl
(tya0
, ptvirga
),
1793 ({B.v_namei
= Some
(nameidb
, None
);
1795 B.v_storage
= (B.StoTypedef
, inl
);
1798 B.v_type_bis
= typb0bis
;
1801 (match A.unwrap tya0
, typb0
with
1802 | A.Type
(cv1
,tya1
), ((qu
,il
),typb1
) ->
1804 (match A.unwrap tya1
, typb1
with
1805 | A.StructUnionDef
(tya2
, lba
, declsa
, rba
),
1806 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
1808 let (iisub
, iisbopt
, lbb
, rbb
) =
1811 let (iisub
, lbb
, rbb
) = tuple_of_list3 ii
in
1812 (iisub
, [], lbb
, rbb
)
1815 "warning: both a typedef (%s) and struct name introduction (%s)"
1816 (Ast_c.str_of_name nameidb
) s
1818 pr2 "warning: I will consider only the typedef";
1819 let (iisub
, iisb
, lbb
, rbb
) = tuple_of_list4 ii
in
1820 (iisub
, [iisb
], lbb
, rbb
)
1823 structdef_to_struct_name
1824 (Ast_c.nQ
, (B.StructUnion
(sub
, sbopt
, declsb
), ii
))
1827 Ast_c.nQ
,((B.TypeName
(nameidb
, Some
1828 (Lib_parsing_c.al_type
structnameb))), [])
1831 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1832 tokenf lba lbb
>>= (fun lba lbb
->
1833 tokenf rba rbb
>>= (fun rba rbb
->
1834 struct_fields
(A.undots declsa
) declsb
>>=(fun undeclsa declsb
->
1835 let declsa = redots
declsa undeclsa
in
1837 (match A.unwrap tya2
with
1838 | A.Type
(cv3
, tya3
) ->
1839 (match A.unwrap tya3
with
1840 | A.MetaType
(ida
,keep
, inherited
) ->
1842 fullType tya2
fake_typeb >>= (fun tya2
fake_typeb ->
1844 A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1 in
1845 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1848 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1849 [iisub
] @ iisbopt
@ [lbb
;rbb
] in
1850 let typb0 = ((qu
, il
), typb1) in
1852 match fake_typeb with
1853 | _nQ
, ((B.TypeName
(nameidb
, _typ
)),[]) ->
1856 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1857 (({B.v_namei
= Some
(nameidb
, None
);
1859 B.v_storage
= (B.StoTypedef
, inl
);
1862 B.v_type_bis
= typb0bis
;
1864 iivirg
),iiptvirgb
,iistob
)
1866 | _
-> raise Impossible
1869 (* do we need EnumName here too? *)
1870 | A.StructUnionName
(sua
, sa
) ->
1871 fullType tya2
structnameb >>= (fun tya2
structnameb ->
1873 let tya1 = A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1
1875 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1877 match structnameb with
1878 | _nQ
, (B.StructUnionName
(sub
, s), [iisub
;iisbopt
]) ->
1880 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1881 [iisub
;iisbopt
;lbb
;rbb
] in
1882 let typb0 = ((qu
, il
), typb1) in
1885 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1886 (({B.v_namei
= Some
(nameidb
, None
);
1888 B.v_storage
= (B.StoTypedef
, inl
);
1891 B.v_type_bis
= typb0bis
;
1893 iivirg
),iiptvirgb
,iistob
)
1895 | _
-> raise Impossible
1897 | _
-> raise Impossible
1906 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1907 ({B.v_namei
= Some
(nameidb
, _
);B.v_storage
= (B.StoTypedef
,_
);}, iivirg
)
1910 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1911 ({B.v_namei
=Some
(nameidb
, _
);B.v_storage
=(B.StoTypedef
,_
);}, iivirg
)
1916 (* could handle iso here but handled in standard.iso *)
1917 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1918 ({B.v_namei
= Some
(nameidb
, None
);
1923 B.v_type_bis
= typbbis
;
1925 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1926 fullType typa typb
>>= (fun typa typb
->
1927 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1928 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1929 (fun stoa
(stob
, iistob
) ->
1931 (A.UnInit
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
1932 (({B.v_namei
= Some
(nameidb
, None
);
1937 B.v_type_bis
= typbbis
;
1942 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1943 ({B.v_namei
= Some
(nameidb
, Some
(iieqb
, inib
));
1948 B.v_type_bis
= typbbis
;
1951 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1952 tokenf eqa iieqb
>>= (fun eqa iieqb
->
1953 fullType typa typb
>>= (fun typa typb
->
1954 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1955 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1956 (fun stoa
(stob
, iistob
) ->
1957 initialiser inia inib
>>= (fun inia inib
->
1959 (A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
)) +> A.rewrap decla
,
1960 (({B.v_namei
= Some
(nameidb
, Some
(iieqb
, inib
));
1965 B.v_type_bis
= typbbis
;
1970 (* do iso-by-absence here ? allow typedecl and var ? *)
1971 | A.TyDecl
(typa
, ptvirga
),
1972 ({B.v_namei
= None
; B.v_type
= typb
;
1976 B.v_type_bis
= typbbis
;
1979 if stob
=*= (B.NoSto
, false)
1981 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1982 fullType typa typb
>>= (fun typa typb
->
1984 (A.TyDecl
(typa
, ptvirga
)) +> A.rewrap decla
,
1985 (({B.v_namei
= None
;
1990 B.v_type_bis
= typbbis
;
1991 }, iivirg
), iiptvirgb
, iistob
)
1996 | A.Typedef
(stoa
, typa
, ida
, ptvirga
),
1997 ({B.v_namei
= Some
(nameidb
, None
);
1999 B.v_storage
= (B.StoTypedef
,inline
);
2002 B.v_type_bis
= typbbis
;
2005 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2006 fullType typa typb
>>= (fun typa typb
->
2009 tokenf stoa iitypedef
>>= (fun stoa iitypedef
->
2010 return (stoa
, [iitypedef
])
2012 | _
-> failwith
"weird, have both typedef and inline or nothing";
2013 ) >>= (fun stoa iistob
->
2014 (match A.unwrap ida
with
2015 | A.MetaType
(_
,_
,_
) ->
2018 Ast_c.nQ
, ((B.TypeName
(nameidb
, Ast_c.noTypedefDef
())), [])
2020 fullTypebis ida
fake_typeb >>= (fun ida
fake_typeb ->
2021 match fake_typeb with
2022 | _nQ
, ((B.TypeName
(nameidb
, _typ
)), []) ->
2023 return (ida
, nameidb
)
2024 | _
-> raise Impossible
2029 | B.RegularName
(sb
, iidb
) ->
2030 let iidb1 = tuple_of_list1 iidb
in
2034 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
2036 (A.TypeName sa
) +> A.rewrap ida
,
2037 B.RegularName
(sb
, [iidb1])
2041 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
2045 | _
-> raise Impossible
2047 ) >>= (fun ida nameidb
->
2049 (A.Typedef
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
2050 (({B.v_namei
= Some
(nameidb
, None
);
2052 B.v_storage
= (B.StoTypedef
,inline
);
2055 B.v_type_bis
= typbbis
;
2063 | _
, ({B.v_namei
= None
;}, _
) ->
2064 (* old: failwith "no variable in this declaration, weird" *)
2069 | A.DisjDecl declas
, declb
->
2070 declas
+> List.fold_left
(fun acc decla
->
2072 (* (declaration (mckstart, allminus, decla) declb) *)
2073 (onedecl allminus decla
(declb
,iiptvirgb
, iistob
))
2078 (* only in struct type decls *)
2079 | A.Ddots
(dots
,whencode
), _
->
2082 | A.OptDecl _
, _
| A.UniqueDecl _
, _
->
2083 failwith
"not handling Opt/Unique Decl"
2085 | _
, ({B.v_namei
=Some _
}, _
) ->
2091 (* ------------------------------------------------------------------------- *)
2093 and (initialiser
: (A.initialiser
, Ast_c.initialiser
) matcher
) = fun ia ib
->
2094 X.all_bound
(A.get_inherited ia
) >&&>
2095 match (A.unwrap ia
,ib
) with
2097 | (A.MetaInit
(ida
,keep
,inherited
), ib
) ->
2099 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_ini ib
) in
2100 X.envf keep inherited
(ida
, Ast_c.MetaInitVal ib
, max_min)
2102 X.distrf_ini ida ib
>>= (fun ida ib
->
2104 A.MetaInit
(ida
,keep
,inherited
) +> A.rewrap ia
,
2109 | (A.InitExpr expa
, ib
) ->
2110 (match A.unwrap expa
, ib
with
2111 | A.Edots
(mcode, None
), ib
->
2112 X.distrf_ini
(dots2metavar mcode) ib
>>= (fun mcode ib
->
2115 (A.Edots
(metavar2dots mcode, None
) +> A.rewrap expa
)
2120 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
2122 | _
, (B.InitExpr expb
, ii
) ->
2124 expression expa expb
>>= (fun expa expb
->
2126 (A.InitExpr expa
) +> A.rewrap ia
,
2127 (B.InitExpr expb
, ii
)
2132 | (A.ArInitList
(ia1
, ias
, ia2
), (B.InitList ibs
, ii
)) ->
2134 | ib1::ib2
::iicommaopt
->
2135 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2136 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2137 ar_initialisers
(A.undots ias
) (ibs
, iicommaopt
) >>=
2138 (fun iasundots
(ibs
,iicommaopt
) ->
2140 (A.ArInitList
(ia1
, redots ias iasundots
, ia2
)) +> A.rewrap ia
,
2141 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2144 | _
-> raise Impossible
2147 | (A.StrInitList
(allminus
, ia1
, ias
, ia2
, []), (B.InitList ibs
, ii
)) ->
2149 | ib1::ib2
::iicommaopt
->
2150 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2151 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2152 str_initialisers allminus ias
(ibs
, iicommaopt
) >>=
2153 (fun ias
(ibs
,iicommaopt
) ->
2155 (A.StrInitList
(allminus
, ia1
, ias
, ia2
, [])) +> A.rewrap ia
,
2156 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2159 | _
-> raise Impossible
2162 | (A.StrInitList
(allminus
, i1
, ias
, i2
, whencode
),
2163 (B.InitList ibs
, _ii
)) ->
2164 failwith
"TODO: not handling whencode in initialisers"
2167 | (A.InitGccExt
(designatorsa
, ia2
, inia
),
2168 (B.InitDesignators
(designatorsb
, inib
), ii2
))->
2170 let iieq = tuple_of_list1 ii2
in
2172 tokenf ia2
iieq >>= (fun ia2
iieq ->
2173 designators designatorsa designatorsb
>>=
2174 (fun designatorsa designatorsb
->
2175 initialiser inia inib
>>= (fun inia inib
->
2177 (A.InitGccExt
(designatorsa
, ia2
, inia
)) +> A.rewrap ia
,
2178 (B.InitDesignators
(designatorsb
, inib
), [iieq])
2184 | (A.InitGccName
(ida
, ia1
, inia
), (B.InitFieldOld
(idb
, inib
), ii
)) ->
2187 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2188 initialiser inia inib
>>= (fun inia inib
->
2189 tokenf ia1 iicolon
>>= (fun ia1 iicolon
->
2191 (A.InitGccName
(ida
, ia1
, inia
)) +> A.rewrap ia
,
2192 (B.InitFieldOld
(idb
, inib
), [iidb
;iicolon
])
2199 | A.IComma
(comma
), _
->
2202 | A.UniqueIni _
,_
| A.OptIni _
,_
->
2203 failwith
"not handling Opt/Unique on initialisers"
2205 | _
, (B.InitIndexOld
(_
, _
), _
) -> fail
2206 | _
, (B.InitFieldOld
(_
, _
), _
) -> fail
2208 | _
, ((B.InitDesignators
(_
, _
)|B.InitList _
|B.InitExpr _
), _
)
2211 and designators dla dlb
=
2212 match (dla
,dlb
) with
2213 ([],[]) -> return ([], [])
2214 | ([],_
) | (_
,[]) -> fail
2215 | (da
::dla
,db
::dlb
) ->
2216 designator da db
>>= (fun da db
->
2217 designators dla dlb
>>= (fun dla dlb
->
2218 return (da
::dla
, db
::dlb
)))
2220 and designator da db
=
2222 (A.DesignatorField
(ia1
, ida
), (B.DesignatorField idb
,ii1
)) ->
2224 let (iidot
, iidb
) = tuple_of_list2 ii1
in
2225 tokenf ia1 iidot
>>= (fun ia1 iidot
->
2226 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2228 A.DesignatorField
(ia1
, ida
),
2229 (B.DesignatorField idb
, [iidot
;iidb
])
2232 | (A.DesignatorIndex
(ia1
,ea
,ia2
), (B.DesignatorIndex eb
, ii1
)) ->
2234 let (ib1, ib2
) = tuple_of_list2 ii1
in
2235 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2236 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2237 expression ea eb
>>= (fun ea eb
->
2239 A.DesignatorIndex
(ia1
,ea
,ia2
),
2240 (B.DesignatorIndex eb
, [ib1;ib2
])
2243 | (A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2244 (B.DesignatorRange
(e1b
, e2b
), ii1
)) ->
2246 let (ib1, ib2
, ib3
) = tuple_of_list3 ii1
in
2247 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2248 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2249 tokenf ia3 ib3
>>= (fun ia3 ib3
->
2250 expression e1a e1b
>>= (fun e1a e1b
->
2251 expression e2a e2b
>>= (fun e2a e2b
->
2253 A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2254 (B.DesignatorRange
(e1b
, e2b
), [ib1;ib2
;ib3
])
2256 | (_
, ((B.DesignatorField _
|B.DesignatorIndex _
|B.DesignatorRange _
), _
)) ->
2259 and str_initialisers
= fun allminus ias
(ibs
, iicomma
) ->
2260 let ias_unsplit = unsplit_icomma ias
in
2261 let ibs_split = resplit_initialiser ibs iicomma
in
2263 if need_unordered_initialisers ibs
2264 then initialisers_unordered2 allminus
ias_unsplit ibs_split >>=
2265 (fun ias_unsplit ibs_split ->
2267 split_icomma ias_unsplit,
2268 unsplit_initialiser ibs_split))
2271 and ar_initialisers
= fun ias
(ibs
, iicomma
) ->
2272 (* this doesn't check need_unordered_initialisers because ... can be
2273 implemented as ordered, even if it matches unordered initializers *)
2274 let ibs = resplit_initialiser ibs iicomma
in
2277 (List.map
(function (elem
,comma
) -> [Left elem
; Right
[comma
]]) ibs) in
2278 initialisers_ordered2 ias
ibs >>=
2279 (fun ias
ibs_split ->
2281 match List.rev
ibs_split with
2282 (Right comma
)::rest
-> (Ast_c.unsplit_comma
(List.rev rest
),comma
)
2283 | (Left _
)::_
-> (Ast_c.unsplit_comma
ibs_split,[]) (* possible *)
2285 return (ias
, (ibs,iicomma
)))
2287 and initialisers_ordered2
= fun ias
ibs ->
2289 match A.unwrap ea
with
2290 A.Idots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2292 let build_dots (mcode, optexpr
) = A.Idots
(mcode, optexpr
) in
2293 let match_comma ea
=
2294 match A.unwrap ea
with
2295 A.IComma ia1
-> Some ia1
2297 let build_comma ia1
= A.IComma ia1
in
2298 let match_metalist ea
= None
in
2299 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
2300 let mktermval v
= failwith
"not possible" in
2301 let special_cases ea
eas ebs
= None
in
2302 let no_ii x
= failwith
"not possible" in
2303 list_matcher match_dots build_dots match_comma build_comma
2304 match_metalist build_metalist mktermval
2305 special_cases initialiser
X.distrf_inis
no_ii ias
ibs
2308 and initialisers_unordered2
= fun allminus ias
ibs ->
2313 let rec loop = function
2314 [] -> return ([],[])
2315 | (ib
,comma
)::ibs ->
2316 X.distrf_ini
minusizer ib
>>= (fun _ ib
->
2317 tokenf minusizer comma
>>= (fun _ comma
->
2318 loop ibs >>= (fun l
ibs ->
2319 return(l
,(ib
,comma
)::ibs)))) in
2321 else return ([], ys
)
2323 let permut = Common.uncons_permut_lazy ys
in
2324 permut +> List.fold_left
(fun acc
((e
, pos
), rest
) ->
2326 (initialiser_comma x e
2328 let rest = Lazy.force
rest in
2329 initialisers_unordered2 allminus xs
rest >>= (fun xs
rest ->
2332 Common.insert_elem_pos
(e
, pos
) rest
2336 and initialiser_comma
(x
,xcomma
) (y
, commay
) =
2337 match A.unwrap xcomma
with
2339 tokenf commax commay
>>= (fun commax commay
->
2340 initialiser x y
>>= (fun x y
->
2342 (x
, (A.IComma commax
) +> A.rewrap xcomma
),
2344 | _
-> raise Impossible
(* unsplit_iicomma wrong *)
2346 (* ------------------------------------------------------------------------- *)
2347 and (struct_fields
: (A.declaration list
, B.field list
) matcher
) =
2350 match A.unwrap ea
with
2351 A.Ddots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2353 let build_dots (mcode, optexpr
) = A.Ddots
(mcode, optexpr
) in
2354 let match_comma ea
= None
in
2355 let build_comma ia1
= failwith
"not possible" in
2356 let match_metalist ea
= None
in
2357 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
2358 let mktermval v
= failwith
"not possible" in
2359 let special_cases ea
eas ebs
= None
in
2360 let no_ii x
= failwith
"not possible" in
2361 let make_ebs ebs
= List.map
(function x
-> Left x
) ebs
in
2362 let unmake_ebs ebs
=
2363 List.map
(function Left x
-> x
| Right x
-> failwith
"no right") ebs
in
2364 let distrf mcode startxs =
2365 let startxs = unmake_ebs startxs in
2366 X.distrf_struct_fields
mcode startxs >>=
2367 (fun mcode startxs -> return (mcode,make_ebs startxs)) in
2368 list_matcher match_dots build_dots match_comma build_comma
2369 match_metalist build_metalist mktermval
2370 special_cases struct_field
distrf no_ii eas (make_ebs ebs
) >>=
2371 (fun eas ebs
-> return (eas,unmake_ebs ebs
))
2373 and (struct_field
: (A.declaration
, B.field
) matcher
) = fun fa fb
->
2375 match A.unwrap fa
,fb
with
2376 | A.MetaField
(ida
,keep
,inherited
), _
->
2378 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_field fb
) in
2379 X.envf keep inherited
(ida
, Ast_c.MetaFieldVal fb
, max_min) (fun () ->
2380 X.distrf_field ida fb
2381 ) >>= (fun ida fb
->
2382 return ((A.MetaField
(ida
, keep
, inherited
))+> A.rewrap fa
,
2384 | _
,B.DeclarationField
(B.FieldDeclList
(onefield_multivars
,iiptvirg
)) ->
2386 let iiptvirgb = tuple_of_list1 iiptvirg
in
2388 (match onefield_multivars
with
2389 | [] -> raise Impossible
2390 | [onevar
,iivirg
] ->
2391 assert (null iivirg
);
2393 | B.BitField
(sopt
, typb
, _
, expr
) ->
2394 pr2_once
"warning: bitfield not handled by ast_cocci";
2396 | B.Simple
(None
, typb
) ->
2397 pr2_once
"warning: unamed struct field not handled by ast_cocci";
2399 | B.Simple
(Some nameidb
, typb
) ->
2401 (* build a declaration from a struct field *)
2402 let allminus = false in
2404 let stob = B.NoSto
, false in
2406 ({B.v_namei
= Some
(nameidb
, None
);
2409 B.v_local
= Ast_c.NotLocalDecl
;
2410 B.v_attr
= Ast_c.noattr
;
2411 B.v_type_bis
= ref None
;
2412 (* the struct field should also get expanded ? no it's not
2413 * important here, we will rematch very soon *)
2417 onedecl
allminus fa
(fake_var,iiptvirgb,iisto) >>=
2418 (fun fa
(var
,iiptvirgb,iisto) ->
2421 | ({B.v_namei
= Some
(nameidb
, None
);
2426 let onevar = B.Simple
(Some nameidb
, typb
) in
2430 ((B.DeclarationField
2431 (B.FieldDeclList
([onevar, iivirg
], [iiptvirgb])))
2434 | _
-> raise Impossible
2439 pr2_once
"PB: More that one variable in decl. Have to split";
2442 | _
,B.EmptyField _iifield
->
2445 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
),B.MacroDeclField
((sb
,ebs
),ii
) ->
2447 | _
,B.MacroDeclField
((sb
,ebs
),ii
) -> fail
2449 | _
,B.CppDirectiveStruct directive
-> fail
2450 | _
,B.IfdefStruct directive
-> fail
2453 and enum_fields
= fun eas ebs
->
2455 match A.unwrap ea
with
2456 A.Edots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2458 let build_dots (mcode, optexpr
) = A.Edots
(mcode, optexpr
) in
2459 let match_comma ea
=
2460 match A.unwrap ea
with
2461 A.EComma ia1
-> Some ia1
2463 let build_comma ia1
= A.EComma ia1
in
2464 let match_metalist ea
= None
in
2465 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
2466 let mktermval v
= failwith
"not possible" in
2467 let special_cases ea
eas ebs
= None
in
2468 list_matcher match_dots build_dots match_comma build_comma
2469 match_metalist build_metalist mktermval
2470 special_cases enum_field
X.distrf_enum_fields
2471 Lib_parsing_c.ii_of_enum_fields
eas ebs
2473 and enum_field ida idb
=
2474 X.all_bound
(A.get_inherited ida
) >&&>
2475 match A.unwrap ida
, idb
with
2476 A.Ident
(id
),(nameidb
,None
) ->
2477 ident_cpp DontKnow id nameidb
>>= (fun id nameidb
->
2478 return ((A.Ident id
) +> A.rewrap ida
, (nameidb
,None
)))
2479 | A.Assignment
(ea1
,opa
,ea2
,init
),(nameidb
,Some
(opbi,eb2
)) ->
2480 (match A.unwrap ea1
with
2482 ident_cpp DontKnow id nameidb
>>= (fun id nameidb
->
2483 expression ea2 eb2
>>= (fun ea2 eb2
->
2484 tokenf opa
opbi >>= (fun opa
opbi -> (* only one kind of assignop *)
2486 (A.Assignment
((A.Ident
(id
))+>A.rewrap ea1
,opa
,ea2
,init
)) +>
2488 (nameidb
,Some
(opbi,eb2
))))))
2489 | _
-> failwith
"not possible")
2490 | _
-> failwith
"not possible"
2492 (* ------------------------------------------------------------------------- *)
2493 and (fullType
: (A.fullType
, Ast_c.fullType
) matcher
) =
2495 X.optional_qualifier_flag
(fun optional_qualifier
->
2496 X.all_bound
(A.get_inherited typa
) >&&>
2497 match A.unwrap typa
, typb
with
2498 | A.Type
(cv
,ty1
), ((qu
,il
),ty2
) ->
2500 if qu
.B.const
&& qu
.B.volatile
2503 ("warning: the type is both const & volatile but cocci " ^
2504 "does not handle that");
2506 (* Drop out the const/volatile part that has been matched.
2507 * This is because a SP can contain const T v; in which case
2508 * later in match_t_t when we encounter a T, we must not add in
2509 * the environment the whole type.
2514 (* "iso-by-absence" *)
2517 fullTypebis ty1
((qu
,il
), ty2
) >>= (fun ty1 fullty2
->
2519 (A.Type
(None
, ty1
)) +> A.rewrap typa
,
2523 (match optional_qualifier
, qu
.B.const
|| qu
.B.volatile
with
2524 | false, false -> do_stuff ()
2525 | false, true -> fail
2526 | true, false -> do_stuff ()
2529 then pr2_once
"USING optional_qualifier builtin isomorphism";
2535 (* todo: can be __const__ ? can be const & volatile so
2536 * should filter instead ?
2538 (match term x
, il
with
2539 | A.Const
, [i1
] when qu
.B.const
->
2541 tokenf x i1
>>= (fun x i1
->
2542 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2544 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2548 | A.Volatile
, [i1
] when qu
.B.volatile
->
2549 tokenf x i1
>>= (fun x i1
->
2550 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2552 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2560 | A.DisjType typas
, typb
->
2562 List.fold_left
(fun acc typa
-> acc
>|+|> (fullType typa typb
)) fail
2564 | A.OptType
(_
), _
| A.UniqueType
(_
), _
2565 -> failwith
"not handling Opt/Unique on type"
2570 * Why not (A.typeC, Ast_c.typeC) matcher ?
2571 * because when there is MetaType, we want that T record the whole type,
2572 * including the qualifier, and so this type (and the new_il function in
2573 * preceding function).
2576 and (fullTypebis
: (A.typeC
, Ast_c.fullType
) matcher
) =
2578 X.all_bound
(A.get_inherited ta
) >&&>
2579 match A.unwrap ta
, tb
with
2582 | A.MetaType
(ida
,keep
, inherited
), typb
->
2584 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
2585 X.envf keep inherited
(ida
, B.MetaTypeVal typb
, max_min) (fun () ->
2586 X.distrf_type ida typb
>>= (fun ida typb
->
2588 A.MetaType
(ida
,keep
, inherited
) +> A.rewrap ta
,
2592 | unwrap
, (qub
, typb
) ->
2593 typeC ta typb
>>= (fun ta typb
->
2594 return (ta
, (qub
, typb
))
2597 and simulate_signed ta basea stringsa signaopt tb baseb ii rebuilda
=
2598 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2599 * And even if in baseb we have a Signed Int, that does not mean
2600 * that ii is of length 2, cos Signed is the default, so if in signa
2601 * we have Signed explicitely ? we cant "accrocher" this mcode to
2602 * something :( So for the moment when there is signed in cocci,
2603 * we force that there is a signed in c too (done in pattern.ml).
2605 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2608 (* handle some iso on type ? (cf complex C rule for possible implicit
2610 match basea
, baseb
with
2611 | A.VoidType
, B.Void
2612 | A.FloatType
, B.FloatType
(B.CFloat
)
2613 | A.DoubleType
, B.FloatType
(B.CDouble
)
2614 | A.SizeType
, B.SizeType
2615 | A.SSizeType
, B.SSizeType
2616 | A.PtrDiffType
,B.PtrDiffType
->
2617 assert (signaopt
=*= None
);
2618 let stringa = tuple_of_list1 stringsa
in
2619 let (ibaseb
) = tuple_of_list1 ii
in
2620 tokenf stringa ibaseb
>>= (fun stringa ibaseb
->
2622 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2623 (B.BaseType baseb
, [ibaseb
])
2626 | A.CharType
, B.IntType
B.CChar
when signaopt
=*= None
->
2627 let stringa = tuple_of_list1 stringsa
in
2628 let ibaseb = tuple_of_list1 ii
in
2629 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2631 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2632 (B.BaseType
(B.IntType
B.CChar
), [ibaseb])
2635 | A.CharType
,B.IntType
(B.Si
(_sign
, B.CChar2
)) when signaopt
<> None
->
2636 let stringa = tuple_of_list1 stringsa
in
2637 let ibaseb = tuple_of_list1 iibaseb
in
2638 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2639 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2641 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2642 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2645 | A.ShortType
, B.IntType
(B.Si
(_
, B.CShort
))
2646 | A.IntType
, B.IntType
(B.Si
(_
, B.CInt
))
2647 | A.LongType
, B.IntType
(B.Si
(_
, B.CLong
)) ->
2648 let stringa = tuple_of_list1 stringsa
in
2651 (* iso-by-presence ? *)
2652 (* when unsigned int in SP, allow have just unsigned in C ? *)
2653 if mcode_contain_plus (mcodekind stringa)
2657 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2659 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2660 (B.BaseType
(baseb
), iisignbopt
++ [])
2666 "warning: long int or short int not handled by ast_cocci";
2670 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2671 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2673 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2674 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2676 | _
-> raise Impossible
2681 | A.LongLongType
, B.IntType
(B.Si
(_
, B.CLongLong
)) ->
2682 let (string1a
,string2a
) = tuple_of_list2 stringsa
in
2684 [ibase1b
;ibase2b
] ->
2685 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2686 tokenf string1a ibase1b
>>= (fun base1a ibase1b
->
2687 tokenf string2a ibase2b
>>= (fun base2a ibase2b
->
2689 (rebuilda
([base1a
;base2a
], signaopt
)) +> A.rewrap ta
,
2690 (B.BaseType
(baseb
), iisignbopt
++ [ibase1b
;ibase2b
])
2692 | [] -> fail (* should something be done in this case? *)
2693 | _
-> raise Impossible
)
2696 | _
, B.FloatType
B.CLongDouble
2699 "warning: long double not handled by ast_cocci";
2702 | _
, (B.Void
|B.FloatType _
|B.IntType _
2703 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
2705 and simulate_signed_meta ta basea signaopt tb baseb ii rebuilda
=
2706 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2707 * And even if in baseb we have a Signed Int, that does not mean
2708 * that ii is of length 2, cos Signed is the default, so if in signa
2709 * we have Signed explicitely ? we cant "accrocher" this mcode to
2710 * something :( So for the moment when there is signed in cocci,
2711 * we force that there is a signed in c too (done in pattern.ml).
2713 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2715 let match_to_type rebaseb
=
2716 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2717 let fta = A.rewrap basea
(A.Type
(None
,basea
)) in
2718 let ftb = Ast_c.nQ
,(B.BaseType
(rebaseb
), iibaseb
) in
2719 fullType
fta ftb >>= (fun fta (_
,tb
) ->
2720 (match A.unwrap
fta,tb
with
2721 A.Type
(_
,basea
), (B.BaseType baseb
, ii
) ->
2723 (rebuilda
(basea
, signaopt
)) +> A.rewrap ta
,
2724 (B.BaseType
(baseb
), iisignbopt
++ ii
)
2726 | _
-> failwith
"not possible"))) in
2728 (* handle some iso on type ? (cf complex C rule for possible implicit
2731 | B.IntType
(B.Si
(_sign
, B.CChar2
)) ->
2732 match_to_type (B.IntType
B.CChar
)
2734 | B.IntType
(B.Si
(_
, ty
)) ->
2736 | [] -> fail (* metavariable has to match something *)
2738 | _
-> match_to_type (B.IntType
(B.Si
(B.Signed
, ty
)))
2742 | (B.Void
|B.FloatType _
|B.IntType _
2743 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
2745 and (typeC
: (A.typeC
, Ast_c.typeC
) matcher
) =
2747 match A.unwrap ta
, tb
with
2748 | A.BaseType
(basea
,stringsa
), (B.BaseType baseb
, ii
) ->
2749 simulate_signed ta basea stringsa None tb baseb ii
2750 (function (stringsa
, signaopt
) -> A.BaseType
(basea
,stringsa
))
2751 | A.SignedT
(signaopt
, Some basea
), (B.BaseType baseb
, ii
) ->
2752 (match A.unwrap basea
with
2753 A.BaseType
(basea1
,strings1
) ->
2754 simulate_signed ta basea1 strings1
(Some signaopt
) tb baseb ii
2755 (function (strings1
, Some signaopt
) ->
2758 Some
(A.rewrap basea
(A.BaseType
(basea1
,strings1
))))
2759 | _
-> failwith
"not possible")
2760 | A.MetaType
(ida
,keep
,inherited
) ->
2761 simulate_signed_meta ta basea
(Some signaopt
) tb baseb ii
2762 (function (basea
, Some signaopt
) ->
2763 A.SignedT
(signaopt
,Some basea
)
2764 | _
-> failwith
"not possible")
2765 | _
-> failwith
"not possible")
2766 | A.SignedT
(signa
,None
), (B.BaseType baseb
, ii
) ->
2767 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2768 (match iibaseb
, baseb
with
2769 | [], B.IntType
(B.Si
(_sign
, B.CInt
)) ->
2770 sign
(Some signa
) signbopt >>= (fun signaopt iisignbopt
->
2772 | None
-> raise Impossible
2775 (A.SignedT
(signa
,None
)) +> A.rewrap ta
,
2776 (B.BaseType baseb
, iisignbopt
)
2784 (* todo? iso with array *)
2785 | A.Pointer
(typa
, iamult
), (B.Pointer typb
, ii
) ->
2786 let (ibmult
) = tuple_of_list1 ii
in
2787 fullType typa typb
>>= (fun typa typb
->
2788 tokenf iamult ibmult
>>= (fun iamult ibmult
->
2790 (A.Pointer
(typa
, iamult
)) +> A.rewrap ta
,
2791 (B.Pointer typb
, [ibmult
])
2794 | A.FunctionType
(allminus,tyaopt
,lpa
,paramsa
,rpa
),
2795 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
) ->
2797 let (lpb
, rpb
) = tuple_of_list2 ii
in
2801 ("Not handling well variable length arguments func. "^
2802 "You have been warned");
2803 tokenf lpa lpb
>>= (fun lpa lpb
->
2804 tokenf rpa rpb
>>= (fun rpa rpb
->
2805 fullType_optional_allminus
allminus tyaopt tyb
>>= (fun tyaopt tyb
->
2806 parameters
(seqstyle paramsa
) (A.undots paramsa
) paramsb
>>=
2807 (fun paramsaundots paramsb
->
2808 let paramsa = redots
paramsa paramsaundots
in
2810 (A.FunctionType
(allminus,tyaopt
,lpa
,paramsa,rpa
) +> A.rewrap ta
,
2811 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), [lpb
;rpb
])
2819 | A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
),
2820 (B.ParenType t1
, ii
) ->
2821 let (lp1b
, rp1b
) = tuple_of_list2 ii
in
2822 let (qu1b
, t1b
) = t1
in
2824 | B.Pointer t2
, ii
->
2825 let (starb
) = tuple_of_list1 ii
in
2826 let (qu2b
, t2b
) = t2
in
2828 | B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
->
2829 let (lp2b
, rp2b
) = tuple_of_list2 ii
in
2834 ("Not handling well variable length arguments func. "^
2835 "You have been warned");
2837 fullType tya tyb
>>= (fun tya tyb
->
2838 tokenf lp1a lp1b
>>= (fun lp1a lp1b
->
2839 tokenf rp1a rp1b
>>= (fun rp1a rp1b
->
2840 tokenf lp2a lp2b
>>= (fun lp2a lp2b
->
2841 tokenf rp2a rp2b
>>= (fun rp2a rp2b
->
2842 tokenf stara starb
>>= (fun stara starb
->
2843 parameters
(seqstyle paramsa) (A.undots
paramsa) paramsb
>>=
2844 (fun paramsaundots paramsb
->
2845 let paramsa = redots
paramsa paramsaundots
in
2849 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))),
2854 (B.Pointer
t2, [starb
]))
2858 (A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
))
2860 (B.ParenType
t1, [lp1b
;rp1b
])
2873 (* todo: handle the iso on optionnal size specifification ? *)
2874 | A.Array
(typa
, ia1
, eaopt
, ia2
), (B.Array
(ebopt
, typb
), ii
) ->
2875 let (ib1, ib2
) = tuple_of_list2 ii
in
2876 fullType typa typb
>>= (fun typa typb
->
2877 option expression eaopt ebopt
>>= (fun eaopt ebopt
->
2878 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2879 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2881 (A.Array
(typa
, ia1
, eaopt
, ia2
)) +> A.rewrap ta
,
2882 (B.Array
(ebopt
, typb
), [ib1;ib2
])
2886 (* todo: could also match a Struct that has provided a name *)
2887 (* This is for the case where the SmPL code contains "struct x", without
2888 a definition. In this case, the name field is always present.
2889 This case is also called from the case for A.StructUnionDef when
2890 a name is present in the C code. *)
2891 | A.StructUnionName
(sua
, Some sa
), (B.StructUnionName
(sub
, sb
), ii
) ->
2892 (* sa is now an ident, not an mcode, old: ... && (term sa) =$= sb *)
2893 let (ib1, ib2
) = tuple_of_list2 ii
in
2894 if equal_structUnion (term sua
) sub
2896 ident DontKnow sa
(sb
, ib2
) >>= (fun sa
(sb
, ib2
) ->
2897 tokenf sua
ib1 >>= (fun sua
ib1 ->
2899 (A.StructUnionName
(sua
, Some sa
)) +> A.rewrap ta
,
2900 (B.StructUnionName
(sub
, sb
), [ib1;ib2
])
2905 | A.StructUnionDef
(ty
, lba
, declsa, rba
),
2906 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
2908 let (ii_sub_sb
, lbb
, rbb
) =
2910 [iisub
; lbb
; rbb
] -> (Common.Left iisub
,lbb
,rbb
)
2911 | [iisub
; iisb
; lbb
; rbb
] -> (Common.Right
(iisub
,iisb
),lbb
,rbb
)
2912 | _
-> failwith
"list of length 3 or 4 expected" in
2915 match (sbopt
,ii_sub_sb
) with
2916 (None
,Common.Left iisub
) ->
2917 (* the following doesn't reconstruct the complete SP code, just
2918 the part that matched *)
2920 match A.unwrap
s with
2922 (match A.unwrap ty
with
2923 A.StructUnionName
(sua
, None
) ->
2924 (match (term sua
, sub
) with
2926 | (A.Union
,B.Union
) -> return ((),())
2929 tokenf sua iisub
>>= (fun sua iisub
->
2932 A.StructUnionName
(sua
, None
) +> A.rewrap
ty)
2934 return (ty,[iisub
])))
2936 | A.DisjType
(disjs
) ->
2938 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
2942 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
2944 (* build a StructUnionName from a StructUnion *)
2945 let fake_su = B.nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) in
2947 fullType
ty fake_su >>= (fun ty fake_su ->
2949 | _nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) ->
2950 return (ty, [iisub
; iisb
])
2951 | _
-> raise Impossible
)
2955 >>= (fun ty ii_sub_sb
->
2957 tokenf lba lbb
>>= (fun lba lbb
->
2958 tokenf rba rbb
>>= (fun rba rbb
->
2959 struct_fields
(A.undots
declsa) declsb
>>=(fun undeclsa declsb
->
2960 let declsa = redots
declsa undeclsa
in
2963 (A.StructUnionDef
(ty, lba
, declsa, rba
)) +> A.rewrap ta
,
2964 (B.StructUnion
(sub
, sbopt
, declsb
),ii_sub_sb
@[lbb
;rbb
])
2968 (* todo? handle isomorphisms ? because Unsigned Int can be match on a
2969 * uint in the C code. But some CEs consists in renaming some types,
2970 * so we don't want apply isomorphisms every time.
2972 | A.TypeName sa
, (B.TypeName
(nameb
, typb
), noii
) ->
2976 | B.RegularName
(sb
, iidb
) ->
2977 let iidb1 = tuple_of_list1 iidb
in
2981 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
2983 (A.TypeName sa
) +> A.rewrap ta
,
2984 (B.TypeName
(B.RegularName
(sb
, [iidb1]), typb
), noii
)
2988 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
2993 | _
, (B.NoType
, ii
) -> fail
2994 | _
, (B.TypeOfExpr e
, ii
) -> fail
2995 | _
, (B.TypeOfType e
, ii
) -> fail
2997 | _
, (B.ParenType e
, ii
) -> fail (* todo ?*)
2998 | A.EnumName
(en
,Some namea
), (B.EnumName nameb
, ii
) ->
2999 let (ib1,ib2
) = tuple_of_list2 ii
in
3000 ident DontKnow namea
(nameb
, ib2
) >>= (fun namea
(nameb
, ib2
) ->
3001 tokenf en
ib1 >>= (fun en
ib1 ->
3003 (A.EnumName
(en
, Some namea
)) +> A.rewrap ta
,
3004 (B.EnumName nameb
, [ib1;ib2
])
3007 | A.EnumDef
(ty, lba
, idsa
, rba
),
3008 (B.Enum
(sbopt
, idsb
), ii
) ->
3010 let (ii_sub_sb
, lbb
, rbb
, comma_opt
) =
3012 [iisub
; lbb
; rbb
; comma_opt
] ->
3013 (Common.Left iisub
,lbb
,rbb
,comma_opt
)
3014 | [iisub
; iisb
; lbb
; rbb
; comma_opt
] ->
3015 (Common.Right
(iisub
,iisb
),lbb
,rbb
,comma_opt
)
3016 | _
-> failwith
"list of length 4 or 5 expected" in
3019 match (sbopt
,ii_sub_sb
) with
3020 (None
,Common.Left iisub
) ->
3021 (* the following doesn't reconstruct the complete SP code, just
3022 the part that matched *)
3024 match A.unwrap
s with
3026 (match A.unwrap
ty with
3027 A.EnumName
(sua
, None
) ->
3028 tokenf sua iisub
>>= (fun sua iisub
->
3030 A.Type
(None
,A.EnumName
(sua
, None
) +> A.rewrap
ty)
3032 return (ty,[iisub
]))
3034 | A.DisjType
(disjs
) ->
3036 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
3040 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
3042 (* build an EnumName from an Enum *)
3043 let fake_su = B.nQ
, (B.EnumName sb
, [iisub
;iisb
]) in
3045 fullType
ty fake_su >>= (fun ty fake_su ->
3047 | _nQ
, (B.EnumName sb
, [iisub
;iisb
]) ->
3048 return (ty, [iisub
; iisb
])
3049 | _
-> raise Impossible
)
3053 >>= (fun ty ii_sub_sb
->
3055 tokenf lba lbb
>>= (fun lba lbb
->
3056 tokenf rba rbb
>>= (fun rba rbb
->
3057 let idsb = resplit_initialiser idsb [comma_opt
] in
3061 (function (elem
,comma
) -> [Left elem
; Right
[comma
]])
3063 enum_fields
(A.undots idsa
) idsb >>= (fun unidsa
idsb ->
3064 let idsa = redots
idsa unidsa
in
3066 match List.rev
idsb with
3067 (Right comma
)::rest ->
3068 (Ast_c.unsplit_comma
(List.rev
rest),comma
)
3069 | (Left _
)::_
-> (Ast_c.unsplit_comma
idsb,[]) (* possible *)
3072 (A.EnumDef
(ty, lba
, idsa, rba
)) +> A.rewrap ta
,
3073 (B.Enum
(sbopt
, idsb),ii_sub_sb
@[lbb
;rbb
]@iicomma
)
3077 | _
, (B.Enum _
, _
) -> fail (* todo cocci ?*)
3080 ((B.TypeName _
| B.StructUnionName
(_
, _
) | B.EnumName _
|
3081 B.StructUnion
(_
, _
, _
) |
3082 B.FunctionType _
| B.Array
(_
, _
) | B.Pointer _
|
3088 (* todo: iso on sign, if not mentioned then free. tochange?
3089 * but that require to know if signed int because explicit
3090 * signed int, or because implicit signed int.
3093 and sign signa signb
=
3094 match signa
, signb
with
3095 | None
, None
-> return (None
, [])
3096 | Some signa
, Some
(signb
, ib
) ->
3097 if equal_sign (term signa
) signb
3098 then tokenf signa ib
>>= (fun signa ib
->
3099 return (Some signa
, [ib
])
3105 and minusize_list iixs
=
3106 iixs
+> List.fold_left
(fun acc ii
->
3107 acc
>>= (fun xs ys
->
3108 tokenf minusizer ii
>>= (fun minus ii
->
3109 return (minus
::xs
, ii
::ys
)
3110 ))) (return ([],[]))
3111 >>= (fun _xsminys ys
->
3112 return ((), List.rev ys
)
3115 and storage_optional_allminus
allminus stoa
(stob, iistob
) =
3116 (* "iso-by-absence" for storage, and return type. *)
3117 X.optional_storage_flag
(fun optional_storage
->
3118 match stoa
, stob with
3119 | None
, (stobis
, inline
) ->
3123 minusize_list iistob
>>= (fun () iistob
->
3124 return (None
, (stob, iistob
))
3126 else return (None
, (stob, iistob
))
3129 (match optional_storage
, stobis
with
3130 | false, B.NoSto
-> do_minus ()
3132 | true, B.NoSto
-> do_minus ()
3135 then pr2_once
"USING optional_storage builtin isomorphism";
3139 | Some x
, ((stobis
, inline
)) ->
3140 if equal_storage (term x
) stobis
3142 let rec loop acc
= function
3145 let str = B.str_of_info i1
in
3147 "static" | "extern" | "auto" | "register" ->
3148 (* not very elegant, but tokenf doesn't know what token to
3150 tokenf x i1
>>= (fun x i1
->
3151 let rebuilt = (List.rev acc
) @ i1
:: iistob
in
3152 return (Some x
, ((stobis
, inline
), rebuilt)))
3153 | _
-> loop (i1
::acc
) iistob
) in
3158 and inline_optional_allminus
allminus inla
(stob, iistob
) =
3159 (* "iso-by-absence" for storage, and return type. *)
3160 X.optional_storage_flag
(fun optional_storage
->
3161 match inla
, stob with
3162 | None
, (stobis
, inline
) ->
3166 minusize_list iistob
>>= (fun () iistob
->
3167 return (None
, (stob, iistob
))
3169 else return (None
, (stob, iistob
))
3178 then pr2_once
"USING optional_storage builtin isomorphism";
3181 else fail (* inline not in SP and present in C code *)
3184 | Some x
, ((stobis
, inline
)) ->
3187 let rec loop acc
= function
3190 let str = B.str_of_info i1
in
3193 (* not very elegant, but tokenf doesn't know what token to
3195 tokenf x i1
>>= (fun x i1
->
3196 let rebuilt = (List.rev acc
) @ i1
:: iistob
in
3197 return (Some x
, ((stobis
, inline
), rebuilt)))
3198 | _
-> loop (i1
::acc
) iistob
) in
3200 else fail (* SP has inline, but the C code does not *)
3203 and fullType_optional_allminus
allminus tya retb
=
3208 X.distrf_type
minusizer retb
>>= (fun _x retb
->
3212 else return (None
, retb
)
3214 fullType tya retb
>>= (fun tya retb
->
3215 return (Some tya
, retb
)
3220 (*---------------------------------------------------------------------------*)
3222 and compatible_base_type a signa b
=
3223 let ok = return ((),()) in
3226 | Type_cocci.VoidType
, B.Void
3227 | Type_cocci.SizeType
, B.SizeType
3228 | Type_cocci.SSizeType
, B.SSizeType
3229 | Type_cocci.PtrDiffType
, B.PtrDiffType
->
3230 assert (signa
=*= None
);
3232 | Type_cocci.CharType
, B.IntType
B.CChar
when signa
=*= None
->
3234 | Type_cocci.CharType
, B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3235 compatible_sign signa signb
3236 | Type_cocci.ShortType
, B.IntType
(B.Si
(signb
, B.CShort
)) ->
3237 compatible_sign signa signb
3238 | Type_cocci.IntType
, B.IntType
(B.Si
(signb
, B.CInt
)) ->
3239 compatible_sign signa signb
3240 | Type_cocci.LongType
, B.IntType
(B.Si
(signb
, B.CLong
)) ->
3241 compatible_sign signa signb
3242 | _
, B.IntType
(B.Si
(signb
, B.CLongLong
)) ->
3243 pr2_once
"no longlong in cocci";
3245 | Type_cocci.FloatType
, B.FloatType
B.CFloat
->
3246 assert (signa
=*= None
);
3248 | Type_cocci.DoubleType
, B.FloatType
B.CDouble
->
3249 assert (signa
=*= None
);
3251 | _
, B.FloatType
B.CLongDouble
->
3252 pr2_once
"no longdouble in cocci";
3254 | Type_cocci.BoolType
, _
-> failwith
"no booltype in C"
3256 | _
, (B.Void
|B.FloatType _
|B.IntType _
3257 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
3259 and compatible_base_type_meta a signa qua b ii
local =
3261 | Type_cocci.MetaType
(ida
,keep
,inherited
),
3262 B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3263 compatible_sign signa signb
>>= fun _ _
->
3264 let newb = ((qua
, (B.BaseType
(B.IntType
B.CChar
),ii
)),local) in
3265 compatible_type a
newb
3266 | Type_cocci.MetaType
(ida
,keep
,inherited
), B.IntType
(B.Si
(signb
, ty)) ->
3267 compatible_sign signa signb
>>= fun _ _
->
3269 ((qua
, (B.BaseType
(B.IntType
(B.Si
(B.Signed
, ty))),ii
)),local) in
3270 compatible_type a
newb
3271 | _
, B.FloatType
B.CLongDouble
->
3272 pr2_once
"no longdouble in cocci";
3275 | _
, (B.Void
|B.FloatType _
|B.IntType _
3276 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
3279 and compatible_type a
(b
,local) =
3280 let ok = return ((),()) in
3282 let rec loop = function
3283 | _
, (qua
, (B.NoType
, _
)) ->
3284 failwith
"compatible_type: matching with NoType"
3285 | Type_cocci.BaseType a
, (qua
, (B.BaseType b
,ii
)) ->
3286 compatible_base_type a None b
3288 | Type_cocci.SignedT
(signa
,None
), (qua
, (B.BaseType b
,ii
)) ->
3289 compatible_base_type
Type_cocci.IntType
(Some signa
) b
3291 | Type_cocci.SignedT
(signa
,Some
ty), (qua
, (B.BaseType b
,ii
)) ->
3293 Type_cocci.BaseType
ty ->
3294 compatible_base_type
ty (Some signa
) b
3295 | Type_cocci.MetaType
(ida
,keep
,inherited
) ->
3296 compatible_base_type_meta
ty (Some signa
) qua b ii
local
3297 | _
-> failwith
"not possible")
3299 | Type_cocci.Pointer a
, (qub
, (B.Pointer b
, ii
)) ->
3301 | Type_cocci.FunctionPointer a
, _
->
3303 "TODO: function pointer type doesn't store enough information to determine compatability"
3304 | Type_cocci.Array a
, (qub
, (B.Array
(eopt
, b
),ii
)) ->
3305 (* no size info for cocci *)
3307 | Type_cocci.StructUnionName
(sua
, name
),
3308 (qub
, (B.StructUnionName
(sub
, sb
),ii
)) ->
3309 if equal_structUnion_type_cocci sua sub
3310 then structure_type_name name sb ii
3312 | Type_cocci.EnumName
(name
),
3313 (qub
, (B.EnumName
(sb
),ii
)) -> structure_type_name name sb ii
3314 | Type_cocci.TypeName sa
, (qub
, (B.TypeName
(namesb
, _typb
),noii
)) ->
3315 let sb = Ast_c.str_of_name namesb
in
3320 | Type_cocci.ConstVol
(qua
, a
), (qub
, b
) ->
3321 if (fst qub
).B.const
&& (fst qub
).B.volatile
3324 pr2_once
("warning: the type is both const & volatile but cocci " ^
3325 "does not handle that");
3331 | Type_cocci.Const
-> (fst qub
).B.const
3332 | Type_cocci.Volatile
-> (fst qub
).B.volatile
3334 then loop (a
,(Ast_c.nQ
, b
))
3337 | Type_cocci.MetaType
(ida
,keep
,inherited
), typb
->
3339 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
3340 X.envf keep inherited
(A.make_mcode ida
, B.MetaTypeVal typb
, max_min)
3344 (* subtil: must be after the MetaType case *)
3345 | a
, (qub
, (B.TypeName
(_namesb
, Some b
), noii
)) ->
3346 (* kind of typedef iso *)
3349 (* for metavariables of type expression *^* *)
3350 | Type_cocci.Unknown
, _
-> ok
3355 B.TypeOfType _
|B.TypeOfExpr _
|B.ParenType _
|
3356 B.EnumName _
|B.StructUnion
(_
, _
, _
)|B.Enum
(_
, _
)
3363 B.StructUnionName
(_
, _
)|
3365 B.Array
(_
, _
)|B.Pointer _
|B.TypeName _
|
3370 and structure_type_name nm
sb ii
=
3372 Type_cocci.NoName
-> ok
3373 | Type_cocci.Name sa
->
3377 | Type_cocci.MV
(ida
,keep
,inherited
) ->
3378 (* degenerate version of MetaId, no transformation possible *)
3379 let (ib1, ib2
) = tuple_of_list2 ii
in
3380 let max_min _
= Lib_parsing_c.lin_col_by_pos
[ib2
] in
3381 let mida = A.make_mcode ida
in
3382 X.envf keep inherited
(mida, B.MetaIdVal
(sb,[]), max_min)
3388 and compatible_sign signa signb
=
3389 let ok = return ((),()) in
3390 match signa
, signb
with
3392 | Some
Type_cocci.Signed
, B.Signed
3393 | Some
Type_cocci.Unsigned
, B.UnSigned
3398 and equal_structUnion_type_cocci a b
=
3400 | Type_cocci.Struct
, B.Struct
-> true
3401 | Type_cocci.Union
, B.Union
-> true
3402 | _
, (B.Struct
| B.Union
) -> false
3406 (*---------------------------------------------------------------------------*)
3407 and inc_file
(a
, before_after
) (b
, h_rel_pos
) =
3409 let rec aux_inc (ass
, bss
) passed
=
3413 let passed = List.rev
passed in
3415 (match before_after
, !h_rel_pos
with
3416 | IncludeNothing
, _
-> true
3417 | IncludeMcodeBefore
, Some x
->
3418 List.mem
passed (x
.Ast_c.first_of
)
3420 | IncludeMcodeAfter
, Some x
->
3421 List.mem
passed (x
.Ast_c.last_of
)
3423 (* no info, maybe cos of a #include <xx.h> that was already in a .h *)
3427 | (A.IncPath x
)::xs
, y
::ys
-> x
=$
= y
&& aux_inc (xs
, ys
) (x
::passed)
3428 | _
-> failwith
"IncDots not in last place or other pb"
3433 | A.Local ass
, B.Local bss
->
3434 aux_inc (ass
, bss
) []
3435 | A.NonLocal ass
, B.NonLocal bss
->
3436 aux_inc (ass
, bss
) []
3441 (*---------------------------------------------------------------------------*)
3443 and (define_params
: sequence
->
3444 (A.define_param list
, (string B.wrap
) B.wrap2 list
) matcher
) =
3445 fun seqstyle eas ebs
->
3447 | Unordered
-> failwith
"not handling ooo"
3449 define_paramsbis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
3450 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
3453 (* todo? facto code with argument and parameters ? *)
3454 and define_paramsbis
= fun eas ebs
->
3456 match A.unwrap ea
with
3457 A.DPdots
(mcode) -> Some
(mcode, None
)
3459 let build_dots (mcode, _optexpr
) = A.DPdots
(mcode) in
3460 let match_comma ea
=
3461 match A.unwrap ea
with
3462 A.DPComma ia1
-> Some ia1
3464 let build_comma ia1
= A.DPComma ia1
in
3465 let match_metalist ea
= None
in
3466 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
3467 let mktermval v
= failwith
"not possible" in
3468 let special_cases ea
eas ebs
= None
in
3469 let no_ii x
= failwith
"not possible" in
3470 list_matcher match_dots build_dots match_comma build_comma
3471 match_metalist build_metalist mktermval
3472 special_cases define_parameter
X.distrf_define_params
no_ii eas ebs
3474 and define_parameter
= fun parama paramb
->
3475 match A.unwrap parama
, paramb
with
3476 A.DParam ida
, (idb
, ii
) ->
3477 let ib1 = tuple_of_list1 ii
in
3478 ident DontKnow ida
(idb
, ib1) >>= (fun ida
(idb
, ib1) ->
3479 return ((A.DParam ida
)+> A.rewrap parama
,(idb
, [ib1])))
3480 | (A.OptDParam _
| A.UniqueDParam _
), _
->
3481 failwith
"handling Opt/Unique for define parameters"
3482 | A.DPcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
3485 (*****************************************************************************)
3487 (*****************************************************************************)
3489 (* no global solution for positions here, because for a statement metavariable
3490 we want a MetaStmtVal, and for the others, it's not clear what we want *)
3492 let rec (rule_elem_node
: (A.rule_elem
, Control_flow_c.node
) matcher
) =
3495 x
>>= (fun a b
-> return (A.rewrap re a
, F.rewrap node b
))
3497 X.all_bound
(A.get_inherited re
) >&&>
3500 match A.unwrap re
, F.unwrap node
with
3502 (* note: the order of the clauses is important. *)
3504 | _
, F.Enter
| _
, F.Exit
| _
, F.ErrorExit
-> fail2()
3506 (* the metaRuleElem contains just '-' information. We dont need to add
3507 * stuff in the environment. If we need stuff in environment, because
3508 * there is a + S somewhere, then this will be done via MetaStmt, not
3510 * Can match TrueNode/FalseNode/... so must be placed before those cases.
3513 | A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
->
3514 let default = A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
in
3515 (match unwrap_node
with
3517 | F.TrueNode
| F.FalseNode
| F.AfterNode
3518 | F.LoopFallThroughNode
| F.FallThroughNode
3520 if X.mode
=*= PatternMode
3523 if mcode_contain_plus (mcodekind mcode)
3524 then failwith
"try add stuff on fake node"
3525 (* minusize or contextize a fake node is ok *)
3528 | F.EndStatement None
->
3529 if X.mode
=*= PatternMode
then return default
3531 (* DEAD CODE NOW ? only useful in -no_cocci_vs_c_3 ?
3532 if mcode_contain_plus (mcodekind mcode)
3534 let fake_info = Ast_c.fakeInfo() in
3535 distrf distrf_node (mcodekind mcode)
3536 (F.EndStatement (Some fake_info))
3537 else return unwrap_node
3541 | F.EndStatement
(Some i1
) ->
3542 tokenf mcode i1
>>= (fun mcode i1
->
3544 A.MetaRuleElem
(mcode,keep
, inherited
),
3545 F.EndStatement
(Some i1
)
3549 if X.mode
=*= PatternMode
then return default
3550 else failwith
"a MetaRuleElem can't transform a headfunc"
3552 if X.mode
=*= PatternMode
then return default
3554 X.distrf_node
(generalize_mcode mcode) node
>>= (fun mcode node
->
3556 A.MetaRuleElem
(mcode,keep
, inherited
),
3562 (* rene cant have found that a state containing a fake/exit/... should be
3564 * TODO: and F.Fake ?
3566 | _
, F.EndStatement _
| _
, F.CaseNode _
3567 | _
, F.TrueNode
| _
, F.FalseNode
| _
, F.AfterNode
3568 | _
, F.FallThroughNode
| _
, F.LoopFallThroughNode
3569 | _
, F.InLoopNode
-> fail2()
3571 (* really ? diff between pattern.ml and transformation.ml *)
3572 | _
, F.Fake
-> fail2()
3575 (* cas general: a Meta can match everything. It matches only
3576 * "header"-statement. We transform only MetaRuleElem, not MetaStmt.
3577 * So can't have been called in transform.
3579 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), F.Decl
(_
) -> fail
3581 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), unwrap_node
->
3582 (* todo: should not happen in transform mode *)
3584 (match Control_flow_c.extract_fullstatement node
with
3587 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_stmt stb
) in
3588 X.envf keep inherited
(ida
, Ast_c.MetaStmtVal stb
, max_min)
3590 (* no need tag ida, we can't be called in transform-mode *)
3592 A.MetaStmt
(ida
, keep
, metainfoMaybeTodo
, inherited
),
3600 | A.MetaStmtList _
, _
->
3601 failwith
"not handling MetaStmtList"
3603 | A.TopExp ea
, F.DefineExpr eb
->
3604 expression ea eb
>>= (fun ea eb
->
3610 | A.TopExp ea
, F.DefineType eb
->
3611 (match A.unwrap ea
with
3613 fullType ft eb
>>= (fun ft eb
->
3615 A.TopExp
(A.rewrap ea
(A.TypeExp
(ft
))),
3622 (* It is important to put this case before the one that fails because
3623 * of the lack of the counter part of a C construct in SmPL (for instance
3624 * there is not yet a CaseRange in SmPL). Even if SmPL don't handle
3625 * yet certain constructs, those constructs may contain expression
3626 * that we still want and can transform.
3629 | A.Exp exp
, nodeb
->
3631 (* kind of iso, initialisation vs affectation *)
3633 match A.unwrap exp
, nodeb
with
3634 | A.Assignment
(ea
, op
, eb
, true), F.Decl decl
->
3635 initialisation_to_affectation decl
+> F.rewrap node
3640 (* Now keep fullstatement inside the control flow node,
3641 * so that can then get in a MetaStmtVar the fullstatement to later
3642 * pp back when the S is in a +. But that means that
3643 * Exp will match an Ifnode even if there is no such exp
3644 * inside the condition of the Ifnode (because the exp may
3645 * be deeper, in the then branch). So have to not visit
3646 * all inside a node anymore.
3648 * update: j'ai choisi d'accrocher au noeud du CFG Ã la
3649 * fois le fullstatement et le partialstatement et appeler le
3650 * visiteur que sur le partialstatement.
3653 match Ast_cocci.get_pos re
with
3654 | None
-> expression
3658 Lib_parsing_c.max_min_by_pos
(Lib_parsing_c.ii_of_expr eb
) in
3659 let keep = Type_cocci.Unitary
in
3660 let inherited = false in
3661 let max_min _
= failwith
"no pos" in
3662 X.envf
keep inherited (pos
, B.MetaPosVal
(min
,max
), max_min)
3668 X.cocciExp
expfn exp
node >>= (fun exp
node ->
3676 X.cocciTy fullType
ty node >>= (fun ty node ->
3683 | A.TopInit init
, nodeb
->
3684 X.cocciInit initialiser init
node >>= (fun init
node ->
3692 | A.FunHeader
(mckstart
, allminus, fninfoa
, ida
, oparen
, paramsa, cparen
),
3693 F.FunHeader
({B.f_name
= nameidb
;
3694 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3698 f_old_c_style
= oldstyle
;
3703 then pr2 "OLD STYLE DECL NOT WELL SUPPORTED";
3706 (* fninfoa records the order in which the SP specified the various
3707 information, but this isn't taken into account in the matching.
3708 Could this be a problem for transformation? *)
3711 List.filter
(function A.FStorage
(s) -> true | _
-> false) fninfoa
3712 with [A.FStorage
(s)] -> Some
s | _
-> None
in
3714 match List.filter
(function A.FType
(s) -> true | _
-> false) fninfoa
3715 with [A.FType
(t
)] -> Some t
| _
-> None
in
3718 match List.filter
(function A.FInline
(i
) -> true | _
-> false) fninfoa
3719 with [A.FInline
(i
)] -> Some i
| _
-> None
in
3721 (match List.filter
(function A.FAttr
(a
) -> true | _
-> false) fninfoa
3722 with [A.FAttr
(a
)] -> failwith
"not checking attributes" | _
-> ());
3725 | ioparenb
::icparenb
::iifakestart
::iistob
->
3727 (* maybe important to put ident as the first tokens to transform.
3728 * It's related to transform_proto. So don't change order
3731 ident_cpp LocalFunction ida nameidb
>>= (fun ida nameidb
->
3732 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
3733 tokenf oparen ioparenb
>>= (fun oparen ioparenb
->
3734 tokenf cparen icparenb
>>= (fun cparen icparenb
->
3735 parameters
(seqstyle paramsa)
3736 (A.undots
paramsa) paramsb
>>=
3737 (fun paramsaundots paramsb
->
3738 let paramsa = redots
paramsa paramsaundots
in
3739 inline_optional_allminus
allminus
3740 inla (stob, iistob
) >>= (fun inla (stob, iistob
) ->
3741 storage_optional_allminus
allminus
3742 stoa (stob, iistob
) >>= (fun stoa (stob, iistob
) ->
3747 ("Not handling well variable length arguments func. "^
3748 "You have been warned");
3750 then minusize_list iidotsb
3751 else return ((),iidotsb
)
3752 ) >>= (fun () iidotsb
->
3754 fullType_optional_allminus
allminus tya retb
>>= (fun tya retb
->
3757 (match stoa with Some st
-> [A.FStorage st
] | None
-> []) ++
3758 (match inla with Some i
-> [A.FInline i
] | None
-> []) ++
3759 (match tya with Some t
-> [A.FType t
] | None
-> [])
3764 A.FunHeader
(mckstart
,allminus,fninfoa,ida
,oparen
,
3766 F.FunHeader
({B.f_name
= nameidb
;
3767 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3771 f_old_c_style
= oldstyle
; (* TODO *)
3773 ioparenb
::icparenb
::iifakestart
::iistob
)
3776 | _
-> raise Impossible
3784 | A.Decl
(mckstart
,allminus,decla
), F.Decl declb
->
3785 declaration
(mckstart
,allminus,decla
) declb
>>=
3786 (fun (mckstart
,allminus,decla
) declb
->
3788 A.Decl
(mckstart
,allminus,decla
),
3793 | A.SeqStart
mcode, F.SeqStart
(st
, level
, i1
) ->
3794 tokenf mcode i1
>>= (fun mcode i1
->
3797 F.SeqStart
(st
, level
, i1
)
3800 | A.SeqEnd
mcode, F.SeqEnd
(level
, i1
) ->
3801 tokenf mcode i1
>>= (fun mcode i1
->
3804 F.SeqEnd
(level
, i1
)
3807 | A.ExprStatement
(ea
, ia1
), F.ExprStatement
(st
, (Some eb
, ii
)) ->
3808 let ib1 = tuple_of_list1 ii
in
3809 expression ea eb
>>= (fun ea eb
->
3810 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3812 A.ExprStatement
(ea
, ia1
),
3813 F.ExprStatement
(st
, (Some eb
, [ib1]))
3818 | A.IfHeader
(ia1
,ia2
, ea
, ia3
), F.IfHeader
(st
, (eb
,ii
)) ->
3819 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3820 expression ea eb
>>= (fun ea eb
->
3821 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3822 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3823 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3825 A.IfHeader
(ia1
, ia2
, ea
, ia3
),
3826 F.IfHeader
(st
, (eb
,[ib1;ib2
;ib3
]))
3829 | A.Else ia
, F.Else ib
->
3830 tokenf ia ib
>>= (fun ia ib
->
3831 return (A.Else ia
, F.Else ib
)
3834 | A.WhileHeader
(ia1
, ia2
, ea
, ia3
), F.WhileHeader
(st
, (eb
, ii
)) ->
3835 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3836 expression ea eb
>>= (fun ea eb
->
3837 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3838 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3839 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3841 A.WhileHeader
(ia1
, ia2
, ea
, ia3
),
3842 F.WhileHeader
(st
, (eb
, [ib1;ib2
;ib3
]))
3845 | A.DoHeader ia
, F.DoHeader
(st
, ib
) ->
3846 tokenf ia ib
>>= (fun ia ib
->
3851 | A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
), F.DoWhileTail
(eb
, ii
) ->
3852 let (ib1, ib2
, ib3
, ib4
) = tuple_of_list4 ii
in
3853 expression ea eb
>>= (fun ea eb
->
3854 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3855 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3856 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3857 tokenf ia4 ib4
>>= (fun ia4 ib4
->
3859 A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
),
3860 F.DoWhileTail
(eb
, [ib1;ib2
;ib3
;ib4
])
3862 | A.IteratorHeader
(ia1
, ia2
, eas, ia3
), F.MacroIterHeader
(st
, ((s,ebs
),ii
))
3864 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3866 ident DontKnow ia1
(s, ib1) >>= (fun ia1
(s, ib1) ->
3867 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3868 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3869 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
3870 let eas = redots
eas easundots
in
3872 A.IteratorHeader
(ia1
, ia2
, eas, ia3
),
3873 F.MacroIterHeader
(st
, ((s,ebs
), [ib1;ib2
;ib3
]))
3878 | A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3879 F.ForHeader
(st
, (((eb1opt
,ib3s
), (eb2opt
,ib4s
), (eb3opt
,ib4vide
)), ii
))
3881 assert (null ib4vide
);
3882 let (ib1, ib2
, ib5
) = tuple_of_list3 ii
in
3883 let ib3 = tuple_of_list1 ib3s
in
3884 let ib4 = tuple_of_list1 ib4s
in
3886 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3887 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3888 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3889 tokenf ia4
ib4 >>= (fun ia4
ib4 ->
3890 tokenf ia5 ib5
>>= (fun ia5 ib5
->
3891 option expression ea1opt eb1opt
>>= (fun ea1opt eb1opt
->
3892 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
3893 option expression ea3opt eb3opt
>>= (fun ea3opt eb3opt
->
3895 A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3896 F.ForHeader
(st
, (((eb1opt
,[ib3]), (eb2opt
,[ib4]), (eb3opt
,[])),
3902 | A.SwitchHeader
(ia1
,ia2
,ea
,ia3
), F.SwitchHeader
(st
, (eb
,ii
)) ->
3903 let (ib1, ib2
, ib3) = tuple_of_list3 ii
in
3904 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3905 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3906 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3907 expression ea eb
>>= (fun ea eb
->
3909 A.SwitchHeader
(ia1
,ia2
,ea
,ia3
),
3910 F.SwitchHeader
(st
, (eb
,[ib1;ib2
;ib3]))
3913 | A.Break
(ia1
, ia2
), F.Break
(st
, ((),ii
)) ->
3914 let (ib1, ib2
) = tuple_of_list2 ii
in
3915 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3916 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3919 F.Break
(st
, ((),[ib1;ib2
]))
3922 | A.Continue
(ia1
, ia2
), F.Continue
(st
, ((),ii
)) ->
3923 let (ib1, ib2
) = tuple_of_list2 ii
in
3924 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3925 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3927 A.Continue
(ia1
, ia2
),
3928 F.Continue
(st
, ((),[ib1;ib2
]))
3931 | A.Return
(ia1
, ia2
), F.Return
(st
, ((),ii
)) ->
3932 let (ib1, ib2
) = tuple_of_list2 ii
in
3933 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3934 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3936 A.Return
(ia1
, ia2
),
3937 F.Return
(st
, ((),[ib1;ib2
]))
3940 | A.ReturnExpr
(ia1
, ea
, ia2
), F.ReturnExpr
(st
, (eb
, ii
)) ->
3941 let (ib1, ib2
) = tuple_of_list2 ii
in
3942 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3943 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3944 expression ea eb
>>= (fun ea eb
->
3946 A.ReturnExpr
(ia1
, ea
, ia2
),
3947 F.ReturnExpr
(st
, (eb
, [ib1;ib2
]))
3952 | A.Include
(incla
,filea
),
3953 F.Include
{B.i_include
= (fileb
, ii
);
3954 B.i_rel_pos
= h_rel_pos
;
3955 B.i_is_in_ifdef
= inifdef
;
3958 assert (copt
=*= None
);
3960 let include_requirment =
3961 match mcodekind incla
, mcodekind filea
with
3962 | A.CONTEXT
(_
, A.BEFORE _
), _
->
3964 | _
, A.CONTEXT
(_
, A.AFTER _
) ->
3970 let (inclb
, iifileb
) = tuple_of_list2 ii
in
3971 if inc_file
(term filea
, include_requirment) (fileb
, h_rel_pos
)
3973 tokenf incla inclb
>>= (fun incla inclb
->
3974 tokenf filea iifileb
>>= (fun filea iifileb
->
3976 A.Include
(incla
, filea
),
3977 F.Include
{B.i_include
= (fileb
, [inclb
;iifileb
]);
3978 B.i_rel_pos
= h_rel_pos
;
3979 B.i_is_in_ifdef
= inifdef
;
3985 | A.Undef
(undefa
,ida
), F.DefineHeader
((idb
, ii
), B.Undef
) ->
3986 let (defineb
, iidb
, ieol
) = tuple_of_list3 ii
in
3987 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
3988 tokenf undefa defineb
>>= (fun undefa defineb
->
3990 A.Undef
(undefa
,ida
),
3991 F.DefineHeader
((idb
,[defineb
;iidb
;ieol
]),B.Undef
)
3996 | A.DefineHeader
(definea
,ida
,params
), F.DefineHeader
((idb
, ii
), defkind
) ->
3997 let (defineb
, iidb
, ieol
) = tuple_of_list3 ii
in
3998 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
3999 tokenf definea defineb
>>= (fun definea defineb
->
4000 (match A.unwrap params
, defkind
with
4001 | A.NoParams
, B.DefineVar
->
4003 A.NoParams
+> A.rewrap params
,
4006 | A.DParams
(lpa
,eas,rpa
), (B.DefineFunc
(ebs
, ii
)) ->
4007 let (lpb
, rpb
) = tuple_of_list2 ii
in
4008 tokenf lpa lpb
>>= (fun lpa lpb
->
4009 tokenf rpa rpb
>>= (fun rpa rpb
->
4011 define_params
(seqstyle eas) (A.undots
eas) ebs
>>=
4012 (fun easundots ebs
->
4013 let eas = redots
eas easundots
in
4015 A.DParams
(lpa
,eas,rpa
) +> A.rewrap params
,
4016 B.DefineFunc
(ebs
,[lpb
;rpb
])
4020 ) >>= (fun params defkind
->
4022 A.DefineHeader
(definea
, ida
, params
),
4023 F.DefineHeader
((idb
,[defineb
;iidb
;ieol
]),defkind
)
4028 | A.Default
(def
,colon
), F.Default
(st
, ((),ii
)) ->
4029 let (ib1, ib2
) = tuple_of_list2 ii
in
4030 tokenf def
ib1 >>= (fun def
ib1 ->
4031 tokenf colon ib2
>>= (fun colon ib2
->
4033 A.Default
(def
,colon
),
4034 F.Default
(st
, ((),[ib1;ib2
]))
4039 | A.Case
(case
,ea
,colon
), F.Case
(st
, (eb
,ii
)) ->
4040 let (ib1, ib2
) = tuple_of_list2 ii
in
4041 tokenf case
ib1 >>= (fun case
ib1 ->
4042 expression ea eb
>>= (fun ea eb
->
4043 tokenf colon ib2
>>= (fun colon ib2
->
4045 A.Case
(case
,ea
,colon
),
4046 F.Case
(st
, (eb
,[ib1;ib2
]))
4049 (* only occurs in the predicates generated by asttomember *)
4050 | A.DisjRuleElem
eas, _
->
4052 List.fold_left
(fun acc ea
-> acc
>|+|> (rule_elem_node ea
node)) fail)
4053 >>= (fun ea eb
-> return (A.unwrap ea
,F.unwrap eb
))
4055 | _
, F.ExprStatement
(_
, (None
, ii
)) -> fail (* happen ? *)
4057 | A.Label
(id
,dd
), F.Label
(st
, nameb
, ((),ii
)) ->
4058 let (ib2
) = tuple_of_list1 ii
in
4059 ident_cpp DontKnow id nameb
>>= (fun ida nameb
->
4060 tokenf dd ib2
>>= (fun dd ib2
->
4063 F.Label
(st
,nameb
, ((),[ib2
]))
4066 | A.Goto
(goto
,id
,sem
), F.Goto
(st
,nameb
, ((),ii
)) ->
4067 let (ib1,ib3) = tuple_of_list2 ii
in
4068 tokenf goto
ib1 >>= (fun goto
ib1 ->
4069 ident_cpp DontKnow id nameb
>>= (fun id nameb
->
4070 tokenf sem
ib3 >>= (fun sem
ib3 ->
4072 A.Goto
(goto
,id
,sem
),
4073 F.Goto
(st
,nameb
, ((),[ib1;ib3]))
4076 (* have not a counter part in coccinelle, for the moment *)
4077 (* todo?: print a warning at least ? *)
4083 | _
, (F.IfdefEndif _
|F.IfdefElse _
|F.IfdefHeader _
)
4087 (F.MacroStmt
(_
, _
)| F.DefineDoWhileZeroHeader _
| F.EndNode
|F.TopNode
)
4090 (F.Label
(_
, _
, _
)|F.Break
(_
, _
)|F.Continue
(_
, _
)|F.Default
(_
, _
)|
4091 F.Case
(_
, _
)|F.Include _
|F.Goto _
|F.ExprStatement _
|
4092 F.DefineType _
|F.DefineExpr _
|F.DefineTodo
|
4093 F.DefineHeader
(_
, _
)|F.ReturnExpr
(_
, _
)|F.Return
(_
, _
)|
4094 F.MacroIterHeader
(_
, _
)|
4095 F.SwitchHeader
(_
, _
)|F.ForHeader
(_
, _
)|F.DoWhileTail _
|F.DoHeader
(_
, _
)|
4096 F.WhileHeader
(_
, _
)|F.Else _
|F.IfHeader
(_
, _
)|
4097 F.SeqEnd
(_
, _
)|F.SeqStart
(_
, _
, _
)|
4098 F.Decl _
|F.FunHeader _
)