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 | B.ValInit
(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 _
,_
),_
)
1364 | _
, ((B.Delete _
,_
),_
)
1369 (((B.Cast
(_
, _
)|B.ParenExpr _
|B.SizeOfType _
|B.SizeOfExpr _
|
1370 B.RecordPtAccess
(_
, _
)|
1371 B.RecordAccess
(_
, _
)|B.ArrayAccess
(_
, _
)|
1372 B.Binary
(_
, _
, _
)|B.Unary
(_
, _
)|
1373 B.Infix
(_
, _
)|B.Postfix
(_
, _
)|
1374 B.Assignment
(_
, _
, _
)|B.CondExpr
(_
, _
, _
)|
1375 B.FunCall
(_
, _
)|B.Constant _
|B.Ident _
),
1383 (* ------------------------------------------------------------------------- *)
1384 and (ident_cpp
: info_ident
-> (A.ident, B.name
) matcher
) =
1385 fun infoidb ida idb
->
1387 | B.RegularName
(s, iis) ->
1388 let iis = tuple_of_list1
iis in
1389 ident infoidb ida
(s, iis) >>= (fun ida
(s,iis) ->
1392 (B.RegularName
(s, [iis]))
1394 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
1396 (* This should be moved to the Id case of ident. Metavariables
1397 should be allowed to be bound to such variables. But doing so
1398 would require implementing an appropriate distr function *)
1401 and (ident: info_ident
-> (A.ident, string * Ast_c.info
) matcher
) =
1402 fun infoidb ida
((idb
, iib
) as ib
) -> (* (idb, iib) as ib *)
1403 let check_constraints constraints idb
=
1404 let meta_id_val l x
= Ast_c.MetaIdVal
(x
,l
) in
1405 match constraints
with
1406 A.IdNoConstraint
-> return (meta_id_val [],())
1407 | A.IdNegIdSet
(str
,meta
) ->
1408 X.check_idconstraint
satisfies_iconstraint str idb
1409 (fun () -> return (meta_id_val meta
,()))
1410 | A.IdRegExpConstraint re
->
1411 X.check_idconstraint
satisfies_regexpconstraint re idb
1412 (fun () -> return (meta_id_val [],())) in
1413 X.all_bound
(A.get_inherited ida
) >&&>
1414 match A.unwrap ida
with
1416 if (term sa
) =$
= idb
then
1417 tokenf sa iib
>>= (fun sa iib
->
1419 ((A.Id sa
)) +> A.rewrap ida
,
1424 | A.MetaId
(mida
,constraints
,keep
,inherited
) ->
1425 check_constraints constraints idb
>>=
1427 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1428 (* use drop_pos for ids so that the pos is not added a second time in
1429 the call to tokenf *)
1430 X.envf keep inherited
(A.drop_pos mida
, wrapper idb
, max_min)
1432 tokenf mida iib
>>= (fun mida iib
->
1434 ((A.MetaId
(mida
, constraints
, keep
, inherited
)) +> A.rewrap ida
,
1439 | A.MetaFunc
(mida
,constraints
,keep
,inherited
) ->
1441 check_constraints constraints idb
>>=
1443 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1444 X.envf keep inherited
(A.drop_pos mida
,Ast_c.MetaFuncVal idb
,max_min)
1446 tokenf mida iib
>>= (fun mida iib
->
1448 ((A.MetaFunc
(mida
,constraints
,keep
,inherited
)))+>A.rewrap ida
,
1453 | LocalFunction
| Function
-> is_function()
1455 failwith
"MetaFunc, need more semantic info about id"
1456 (* the following implementation could possibly be useful, if one
1457 follows the convention that a macro is always in capital letters
1458 and that a macro is not a function.
1459 (if idb =~ "^[A-Z_][A-Z_0-9]*$" then fail else is_function())*)
1462 | A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
) ->
1465 check_constraints constraints idb
>>=
1467 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1468 X.envf keep inherited
1469 (A.drop_pos mida
,Ast_c.MetaLocalFuncVal idb
, max_min)
1471 tokenf mida iib
>>= (fun mida iib
->
1473 ((A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
)))
1479 | DontKnow
-> failwith
"MetaLocalFunc, need more semantic info about id"
1482 (* not clear why disj things are needed, after disjdistr? *)
1484 ias
+> List.fold_left
(fun acc ia
-> acc
>|+|> (ident infoidb ia ib
)) fail
1486 | A.OptIdent _
| A.UniqueIdent _
->
1487 failwith
"not handling Opt/Unique for ident"
1489 (* ------------------------------------------------------------------------- *)
1490 and (arguments
: sequence
->
1491 (A.expression list
, Ast_c.argument
Ast_c.wrap2 list
) matcher
) =
1492 fun seqstyle eas ebs
->
1494 | Unordered
-> failwith
"not handling ooo"
1496 arguments_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1497 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1499 (* because '...' can match nothing, need to take care when have
1500 * ', ...' or '...,' as in f(..., X, Y, ...). It must match
1501 * f(1,2) for instance.
1502 * So I have added special cases such as (if startxs = []) and code
1503 * in the Ecomma matching rule.
1505 * old: Must do some try, for instance when f(...,X,Y,...) have to
1506 * test the transfo for all the combinaitions and if multiple transfo
1507 * possible ? pb ? => the type is to return a expression option ? use
1508 * some combinators to help ?
1509 * update: with the tag-SP approach, no more a problem.
1512 and arguments_bis
= fun eas ebs
->
1514 match A.unwrap ea
with
1515 A.Edots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
1517 let build_dots (mcode, optexpr
) = A.Edots
(mcode, optexpr
) in
1518 let match_comma ea
=
1519 match A.unwrap ea
with
1520 A.EComma ia1
-> Some ia1
1522 let build_comma ia1
= A.EComma ia1
in
1523 let match_metalist ea
=
1524 match A.unwrap ea
with
1525 A.MetaExprList
(ida
,leninfo
,keep
,inherited
) ->
1526 Some
(ida
,leninfo
,keep
,inherited
)
1528 let build_metalist (ida
,leninfo
,keep
,inherited
) =
1529 A.MetaExprList
(ida
,leninfo
,keep
,inherited
) in
1530 let mktermval v
= Ast_c.MetaExprListVal v
in
1531 let special_cases ea
eas ebs
= None
in
1532 list_matcher match_dots build_dots match_comma build_comma
1533 match_metalist build_metalist mktermval
1534 special_cases argument
X.distrf_args
1535 Lib_parsing_c.ii_of_args
eas ebs
1537 and argument arga argb
=
1538 X.all_bound
(A.get_inherited arga
) >&&>
1539 match A.unwrap arga
, argb
with
1541 Right
(B.ArgType
{B.p_register
=b
,iib
; p_namei
=sopt
;p_type
=tyb
}) ->
1542 if b
|| sopt
<> None
1544 (* failwith "the argument have a storage and ast_cocci does not have"*)
1547 (* b = false and sopt = None *)
1548 fullType tya tyb
>>= (fun tya tyb
->
1550 (A.TypeExp tya
) +> A.rewrap arga
,
1551 (Right
(B.ArgType
{B.p_register
=(b
,iib
);
1556 | A.TypeExp tya
, _
-> fail
1557 | _
, Right
(B.ArgType _
) -> fail
1559 expression arga argb
>>= (fun arga argb
->
1560 return (arga
, Left argb
)
1562 | _
, Right
(B.ArgAction y
) -> fail
1565 (* ------------------------------------------------------------------------- *)
1566 (* todo? facto code with argument ? *)
1567 and (parameters
: sequence
->
1568 (A.parameterTypeDef list
, Ast_c.parameterType
Ast_c.wrap2 list
)
1570 fun seqstyle eas ebs
->
1572 | Unordered
-> failwith
"not handling ooo"
1574 parameters_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1575 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1579 and parameters_bis
eas ebs
=
1581 match A.unwrap ea
with
1582 A.Pdots
(mcode) -> Some
(mcode, None
)
1584 let build_dots (mcode, _optexpr
) = A.Pdots
(mcode) in
1585 let match_comma ea
=
1586 match A.unwrap ea
with
1587 A.PComma ia1
-> Some ia1
1589 let build_comma ia1
= A.PComma ia1
in
1590 let match_metalist ea
=
1591 match A.unwrap ea
with
1592 A.MetaParamList
(ida
,leninfo
,keep
,inherited
) ->
1593 Some
(ida
,leninfo
,keep
,inherited
)
1595 let build_metalist (ida
,leninfo
,keep
,inherited
) =
1596 A.MetaParamList
(ida
,leninfo
,keep
,inherited
) in
1597 let mktermval v
= Ast_c.MetaParamListVal v
in
1598 let special_cases ea
eas ebs
=
1599 (* a case where one smpl parameter matches a list of C parameters *)
1600 match A.unwrap ea
,ebs
with
1601 A.VoidParam ta
, ys
->
1603 (match eas, ebs
with
1605 let {B.p_register
=(hasreg
,iihasreg
);
1607 p_type
=tb
; } = eb
in
1609 if idbopt
=*= None
&& not hasreg
1612 | (qub
, (B.BaseType
B.Void
,_
)) ->
1613 fullType ta tb
>>= (fun ta tb
->
1615 [(A.VoidParam ta
) +> A.rewrap ea
],
1616 [Left
{B.p_register
=(hasreg
, iihasreg
);
1624 list_matcher match_dots build_dots match_comma build_comma
1625 match_metalist build_metalist mktermval
1626 special_cases parameter
X.distrf_params
1627 Lib_parsing_c.ii_of_params
eas ebs
1630 let split_register_param = fun (hasreg, idb, ii_b_s) ->
1631 match hasreg, idb, ii_b_s with
1632 | false, Some s, [i1] -> Left (s, [], i1)
1633 | true, Some s, [i1;i2] -> Left (s, [i1], i2)
1634 | _, None, ii -> Right ii
1635 | _ -> raise Impossible
1639 and parameter
= fun parama paramb
->
1640 match A.unwrap parama
, paramb
with
1641 A.MetaParam
(ida
,keep
,inherited
), eb
->
1642 (* todo: use quaopt, hasreg ? *)
1644 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_param eb
) in
1645 X.envf keep inherited
(ida
,Ast_c.MetaParamVal eb
,max_min) (fun () ->
1646 X.distrf_param ida eb
1647 ) >>= (fun ida eb
->
1648 return (A.MetaParam
(ida
,keep
,inherited
)+> A.rewrap parama
,eb
))
1649 | A.Param
(typa
, idaopt
), eb
->
1650 let {B.p_register
= (hasreg
,iihasreg
);
1651 p_namei
= nameidbopt
;
1652 p_type
= typb
;} = paramb
in
1654 fullType typa typb
>>= (fun typa typb
->
1655 match idaopt
, nameidbopt
with
1656 | Some ida
, Some nameidb
->
1657 (* todo: if minus on ida, should also minus the iihasreg ? *)
1658 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1660 A.Param
(typa
, Some ida
)+> A.rewrap parama
,
1661 {B.p_register
= (hasreg
, iihasreg
);
1662 p_namei
= Some
(nameidb
);
1668 A.Param
(typa
, None
)+> A.rewrap parama
,
1669 {B.p_register
=(hasreg
,iihasreg
);
1673 (* why handle this case ? because of transform_proto ? we may not
1674 * have an ident in the proto.
1675 * If have some plus on ida ? do nothing about ida ?
1677 (* not anymore !!! now that julia is handling the proto.
1678 | _, Right iihasreg ->
1681 ((hasreg, None, typb), iihasreg)
1685 | Some _
, None
-> fail
1686 | None
, Some _
-> fail)
1687 | (A.OptParam _
| A.UniqueParam _
), _
->
1688 failwith
"not handling Opt/Unique for Param"
1689 | A.Pcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
1692 (* ------------------------------------------------------------------------- *)
1693 and (declaration
: (A.mcodekind * bool * A.declaration
,B.declaration
) matcher
) =
1694 fun (mckstart
, allminus
, decla
) declb
->
1695 X.all_bound
(A.get_inherited decla
) >&&>
1696 match A.unwrap decla
, declb
with
1698 (* Un MetaDecl est introduit dans l'asttoctl pour sauter au dessus
1699 * de toutes les declarations qui sont au debut d'un fonction et
1700 * commencer le reste du match au premier statement. Alors, ca matche
1701 * n'importe quelle declaration. On n'a pas besoin d'ajouter
1702 * quoi que ce soit dans l'environnement. C'est une sorte de DDots.
1704 * When the SP want to remove the whole function, the minus is not
1705 * on the MetaDecl but on the MetaRuleElem. So there should
1706 * be no transform of MetaDecl, just matching are allowed.
1709 | A.MetaDecl
(ida
,keep
,inherited
), _
->
1711 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_decl declb
) in
1712 X.envf keep inherited
(ida
, Ast_c.MetaDeclVal declb
, max_min) (fun () ->
1713 X.distrf_decl ida declb
1714 ) >>= (fun ida declb
->
1715 return ((mckstart
, allminus
,
1716 (A.MetaDecl
(ida
, keep
, inherited
))+> A.rewrap decla
),
1718 | _
, (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
)) ->
1719 onedecl allminus decla
(var
,iiptvirgb
,iisto
) >>=
1720 (fun decla
(var
,iiptvirgb
,iisto
)->
1721 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1723 (mckstart
, allminus
, decla
),
1724 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1727 | _
, (B.DeclList
(xs
, iiptvirgb
::iifakestart
::iisto
)) ->
1729 let rec loop n
= function
1731 | x
::xs
-> (n
,x
)::(loop (n
+1) xs
) in
1733 let rec repln n vl cur
= function
1736 if n
= cur
then vl
:: xs
else x
:: (repln n vl
(cur
+1) xs
) in
1737 if X.mode
=*= PatternMode
|| A.get_safe_decl decla
1739 (indexify xs
) +> List.fold_left
(fun acc
(n
,var
) ->
1740 (* consider all possible matches *)
1741 acc
>||> (function tin
-> (
1742 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1743 onedecl allminus decla
(var
, iiptvirgb
, iisto
) >>=
1744 (fun decla
(var
, iiptvirgb
, iisto
) ->
1746 (mckstart
, allminus
, decla
),
1747 (* adjust the variable that was chosen *)
1748 (B.DeclList
(repln n var
0 xs
,
1749 iiptvirgb
::iifakestart
::iisto
))
1753 failwith
"More that one variable in decl. Have to split to transform. Check that there is no transformation on the type or the ;"
1755 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
), B.MacroDecl
((sb
,ebs
),ii
) ->
1756 let (iisb
, lpb
, rpb
, iiendb
, iifakestart
, iistob
) =
1758 | iisb
::lpb
::rpb
::iiendb
::iifakestart
::iisto
->
1759 (iisb
,lpb
,rpb
,iiendb
, iifakestart
,iisto
)
1760 | _
-> raise Impossible
1763 then minusize_list iistob
1764 else return ((), iistob
)
1765 ) >>= (fun () iistob
->
1767 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1768 ident DontKnow sa
(sb
, iisb
) >>= (fun sa
(sb
, iisb
) ->
1769 tokenf lpa lpb
>>= (fun lpa lpb
->
1770 tokenf rpa rpb
>>= (fun rpa rpb
->
1771 tokenf enda iiendb
>>= (fun enda iiendb
->
1772 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
1773 let eas = redots
eas easundots
in
1776 (mckstart
, allminus
,
1777 (A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
)) +> A.rewrap decla
),
1778 (B.MacroDecl
((sb
,ebs
),
1779 [iisb
;lpb
;rpb
;iiendb
;iifakestart
] ++ iistob
))
1782 | _
, (B.MacroDecl _
|B.DeclList _
) -> fail
1785 and onedecl
= fun allminus decla
(declb
, iiptvirgb
, iistob
) ->
1786 X.all_bound
(A.get_inherited decla
) >&&>
1787 match A.unwrap decla
, declb
with
1789 (* kind of typedef iso, we must unfold, it's for the case
1790 * T { }; that we want to match against typedef struct { } xx_t;
1793 | A.TyDecl
(tya0
, ptvirga
),
1794 ({B.v_namei
= Some
(nameidb
, B.NoInit
);
1796 B.v_storage
= (B.StoTypedef
, inl
);
1799 B.v_type_bis
= typb0bis
;
1802 (match A.unwrap tya0
, typb0
with
1803 | A.Type
(cv1
,tya1
), ((qu
,il
),typb1
) ->
1805 (match A.unwrap tya1
, typb1
with
1806 | A.StructUnionDef
(tya2
, lba
, declsa
, rba
),
1807 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
1809 let (iisub
, iisbopt
, lbb
, rbb
) =
1812 let (iisub
, lbb
, rbb
) = tuple_of_list3 ii
in
1813 (iisub
, [], lbb
, rbb
)
1816 "warning: both a typedef (%s) and struct name introduction (%s)"
1817 (Ast_c.str_of_name nameidb
) s
1819 pr2 "warning: I will consider only the typedef";
1820 let (iisub
, iisb
, lbb
, rbb
) = tuple_of_list4 ii
in
1821 (iisub
, [iisb
], lbb
, rbb
)
1824 structdef_to_struct_name
1825 (Ast_c.nQ
, (B.StructUnion
(sub
, sbopt
, declsb
), ii
))
1828 Ast_c.nQ
,((B.TypeName
(nameidb
, Some
1829 (Lib_parsing_c.al_type
structnameb))), [])
1832 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1833 tokenf lba lbb
>>= (fun lba lbb
->
1834 tokenf rba rbb
>>= (fun rba rbb
->
1835 struct_fields
(A.undots declsa
) declsb
>>=(fun undeclsa declsb
->
1836 let declsa = redots
declsa undeclsa
in
1838 (match A.unwrap tya2
with
1839 | A.Type
(cv3
, tya3
) ->
1840 (match A.unwrap tya3
with
1841 | A.MetaType
(ida
,keep
, inherited
) ->
1843 fullType tya2
fake_typeb >>= (fun tya2
fake_typeb ->
1845 A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1 in
1846 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1849 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1850 [iisub
] @ iisbopt
@ [lbb
;rbb
] in
1851 let typb0 = ((qu
, il
), typb1) in
1853 match fake_typeb with
1854 | _nQ
, ((B.TypeName
(nameidb
, _typ
)),[]) ->
1857 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1858 (({B.v_namei
= Some
(nameidb
, B.NoInit
);
1860 B.v_storage
= (B.StoTypedef
, inl
);
1863 B.v_type_bis
= typb0bis
;
1865 iivirg
),iiptvirgb
,iistob
)
1867 | _
-> raise Impossible
1870 (* do we need EnumName here too? *)
1871 | A.StructUnionName
(sua
, sa
) ->
1872 fullType tya2
structnameb >>= (fun tya2
structnameb ->
1874 let tya1 = A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1
1876 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1878 match structnameb with
1879 | _nQ
, (B.StructUnionName
(sub
, s), [iisub
;iisbopt
]) ->
1881 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1882 [iisub
;iisbopt
;lbb
;rbb
] in
1883 let typb0 = ((qu
, il
), typb1) in
1886 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1887 (({B.v_namei
= Some
(nameidb
, B.NoInit
);
1889 B.v_storage
= (B.StoTypedef
, inl
);
1892 B.v_type_bis
= typb0bis
;
1894 iivirg
),iiptvirgb
,iistob
)
1896 | _
-> raise Impossible
1898 | _
-> raise Impossible
1907 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1908 ({B.v_namei
= Some
(nameidb
, _
);B.v_storage
= (B.StoTypedef
,_
);}, iivirg
)
1911 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1912 ({B.v_namei
=Some
(nameidb
, _
);B.v_storage
=(B.StoTypedef
,_
);}, iivirg
)
1917 (* could handle iso here but handled in standard.iso *)
1918 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1919 ({B.v_namei
= Some
(nameidb
, B.NoInit
);
1924 B.v_type_bis
= typbbis
;
1926 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1927 fullType typa typb
>>= (fun typa typb
->
1928 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1929 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1930 (fun stoa
(stob
, iistob
) ->
1932 (A.UnInit
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
1933 (({B.v_namei
= Some
(nameidb
, B.NoInit
);
1938 B.v_type_bis
= typbbis
;
1943 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1944 ({B.v_namei
= Some
(nameidb
, B.ValInit
(iieqb
, inib
));
1949 B.v_type_bis
= typbbis
;
1952 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1953 tokenf eqa iieqb
>>= (fun eqa iieqb
->
1954 fullType typa typb
>>= (fun typa typb
->
1955 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1956 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1957 (fun stoa
(stob
, iistob
) ->
1958 initialiser inia inib
>>= (fun inia inib
->
1960 (A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
)) +> A.rewrap decla
,
1961 (({B.v_namei
= Some
(nameidb
, B.ValInit
(iieqb
, inib
));
1966 B.v_type_bis
= typbbis
;
1971 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1972 ({B.v_namei
= Some
(nameidb
, B.ConstrInit _
);
1977 B.v_type_bis
= typbbis
;
1979 -> fail (* C++ constructor declaration not supported in SmPL *)
1981 (* do iso-by-absence here ? allow typedecl and var ? *)
1982 | A.TyDecl
(typa
, ptvirga
),
1983 ({B.v_namei
= None
; B.v_type
= typb
;
1987 B.v_type_bis
= typbbis
;
1990 if stob
=*= (B.NoSto
, false)
1992 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1993 fullType typa typb
>>= (fun typa typb
->
1995 (A.TyDecl
(typa
, ptvirga
)) +> A.rewrap decla
,
1996 (({B.v_namei
= None
;
2001 B.v_type_bis
= typbbis
;
2002 }, iivirg
), iiptvirgb
, iistob
)
2007 | A.Typedef
(stoa
, typa
, ida
, ptvirga
),
2008 ({B.v_namei
= Some
(nameidb
, B.NoInit
);
2010 B.v_storage
= (B.StoTypedef
,inline
);
2013 B.v_type_bis
= typbbis
;
2016 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2017 fullType typa typb
>>= (fun typa typb
->
2020 tokenf stoa iitypedef
>>= (fun stoa iitypedef
->
2021 return (stoa
, [iitypedef
])
2023 | _
-> failwith
"weird, have both typedef and inline or nothing";
2024 ) >>= (fun stoa iistob
->
2025 (match A.unwrap ida
with
2026 | A.MetaType
(_
,_
,_
) ->
2029 Ast_c.nQ
, ((B.TypeName
(nameidb
, Ast_c.noTypedefDef
())), [])
2031 fullTypebis ida
fake_typeb >>= (fun ida
fake_typeb ->
2032 match fake_typeb with
2033 | _nQ
, ((B.TypeName
(nameidb
, _typ
)), []) ->
2034 return (ida
, nameidb
)
2035 | _
-> raise Impossible
2040 | B.RegularName
(sb
, iidb
) ->
2041 let iidb1 = tuple_of_list1 iidb
in
2045 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
2047 (A.TypeName sa
) +> A.rewrap ida
,
2048 B.RegularName
(sb
, [iidb1])
2052 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
2056 | _
-> raise Impossible
2058 ) >>= (fun ida nameidb
->
2060 (A.Typedef
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
2061 (({B.v_namei
= Some
(nameidb
, B.NoInit
);
2063 B.v_storage
= (B.StoTypedef
,inline
);
2066 B.v_type_bis
= typbbis
;
2074 | _
, ({B.v_namei
= None
;}, _
) ->
2075 (* old: failwith "no variable in this declaration, weird" *)
2080 | A.DisjDecl declas
, declb
->
2081 declas
+> List.fold_left
(fun acc decla
->
2083 (* (declaration (mckstart, allminus, decla) declb) *)
2084 (onedecl allminus decla
(declb
,iiptvirgb
, iistob
))
2089 (* only in struct type decls *)
2090 | A.Ddots
(dots
,whencode
), _
->
2093 | A.OptDecl _
, _
| A.UniqueDecl _
, _
->
2094 failwith
"not handling Opt/Unique Decl"
2096 | _
, ({B.v_namei
=Some _
}, _
) ->
2102 (* ------------------------------------------------------------------------- *)
2104 and (initialiser
: (A.initialiser
, Ast_c.initialiser
) matcher
) = fun ia ib
->
2105 X.all_bound
(A.get_inherited ia
) >&&>
2106 match (A.unwrap ia
,ib
) with
2108 | (A.MetaInit
(ida
,keep
,inherited
), ib
) ->
2110 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_ini ib
) in
2111 X.envf keep inherited
(ida
, Ast_c.MetaInitVal ib
, max_min)
2113 X.distrf_ini ida ib
>>= (fun ida ib
->
2115 A.MetaInit
(ida
,keep
,inherited
) +> A.rewrap ia
,
2120 | (A.InitExpr expa
, ib
) ->
2121 (match A.unwrap expa
, ib
with
2122 | A.Edots
(mcode, None
), ib
->
2123 X.distrf_ini
(dots2metavar mcode) ib
>>= (fun mcode ib
->
2126 (A.Edots
(metavar2dots mcode, None
) +> A.rewrap expa
)
2131 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
2133 | _
, (B.InitExpr expb
, ii
) ->
2135 expression expa expb
>>= (fun expa expb
->
2137 (A.InitExpr expa
) +> A.rewrap ia
,
2138 (B.InitExpr expb
, ii
)
2143 | (A.ArInitList
(ia1
, ias
, ia2
), (B.InitList ibs
, ii
)) ->
2145 | ib1::ib2
::iicommaopt
->
2146 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2147 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2148 ar_initialisers
(A.undots ias
) (ibs
, iicommaopt
) >>=
2149 (fun iasundots
(ibs
,iicommaopt
) ->
2151 (A.ArInitList
(ia1
, redots ias iasundots
, ia2
)) +> A.rewrap ia
,
2152 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2155 | _
-> raise Impossible
2158 | (A.StrInitList
(allminus
, ia1
, ias
, ia2
, []), (B.InitList ibs
, ii
)) ->
2160 | ib1::ib2
::iicommaopt
->
2161 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2162 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2163 str_initialisers allminus ias
(ibs
, iicommaopt
) >>=
2164 (fun ias
(ibs
,iicommaopt
) ->
2166 (A.StrInitList
(allminus
, ia1
, ias
, ia2
, [])) +> A.rewrap ia
,
2167 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2170 | _
-> raise Impossible
2173 | (A.StrInitList
(allminus
, i1
, ias
, i2
, whencode
),
2174 (B.InitList ibs
, _ii
)) ->
2175 failwith
"TODO: not handling whencode in initialisers"
2178 | (A.InitGccExt
(designatorsa
, ia2
, inia
),
2179 (B.InitDesignators
(designatorsb
, inib
), ii2
))->
2181 let iieq = tuple_of_list1 ii2
in
2183 tokenf ia2
iieq >>= (fun ia2
iieq ->
2184 designators designatorsa designatorsb
>>=
2185 (fun designatorsa designatorsb
->
2186 initialiser inia inib
>>= (fun inia inib
->
2188 (A.InitGccExt
(designatorsa
, ia2
, inia
)) +> A.rewrap ia
,
2189 (B.InitDesignators
(designatorsb
, inib
), [iieq])
2195 | (A.InitGccName
(ida
, ia1
, inia
), (B.InitFieldOld
(idb
, inib
), ii
)) ->
2198 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2199 initialiser inia inib
>>= (fun inia inib
->
2200 tokenf ia1 iicolon
>>= (fun ia1 iicolon
->
2202 (A.InitGccName
(ida
, ia1
, inia
)) +> A.rewrap ia
,
2203 (B.InitFieldOld
(idb
, inib
), [iidb
;iicolon
])
2210 | A.IComma
(comma
), _
->
2213 | A.UniqueIni _
,_
| A.OptIni _
,_
->
2214 failwith
"not handling Opt/Unique on initialisers"
2216 | _
, (B.InitIndexOld
(_
, _
), _
) -> fail
2217 | _
, (B.InitFieldOld
(_
, _
), _
) -> fail
2219 | _
, ((B.InitDesignators
(_
, _
)|B.InitList _
|B.InitExpr _
), _
)
2222 and designators dla dlb
=
2223 match (dla
,dlb
) with
2224 ([],[]) -> return ([], [])
2225 | ([],_
) | (_
,[]) -> fail
2226 | (da
::dla
,db
::dlb
) ->
2227 designator da db
>>= (fun da db
->
2228 designators dla dlb
>>= (fun dla dlb
->
2229 return (da
::dla
, db
::dlb
)))
2231 and designator da db
=
2233 (A.DesignatorField
(ia1
, ida
), (B.DesignatorField idb
,ii1
)) ->
2235 let (iidot
, iidb
) = tuple_of_list2 ii1
in
2236 tokenf ia1 iidot
>>= (fun ia1 iidot
->
2237 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2239 A.DesignatorField
(ia1
, ida
),
2240 (B.DesignatorField idb
, [iidot
;iidb
])
2243 | (A.DesignatorIndex
(ia1
,ea
,ia2
), (B.DesignatorIndex eb
, ii1
)) ->
2245 let (ib1, ib2
) = tuple_of_list2 ii1
in
2246 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2247 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2248 expression ea eb
>>= (fun ea eb
->
2250 A.DesignatorIndex
(ia1
,ea
,ia2
),
2251 (B.DesignatorIndex eb
, [ib1;ib2
])
2254 | (A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2255 (B.DesignatorRange
(e1b
, e2b
), ii1
)) ->
2257 let (ib1, ib2
, ib3
) = tuple_of_list3 ii1
in
2258 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2259 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2260 tokenf ia3 ib3
>>= (fun ia3 ib3
->
2261 expression e1a e1b
>>= (fun e1a e1b
->
2262 expression e2a e2b
>>= (fun e2a e2b
->
2264 A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2265 (B.DesignatorRange
(e1b
, e2b
), [ib1;ib2
;ib3
])
2267 | (_
, ((B.DesignatorField _
|B.DesignatorIndex _
|B.DesignatorRange _
), _
)) ->
2270 and str_initialisers
= fun allminus ias
(ibs
, iicomma
) ->
2271 let ias_unsplit = unsplit_icomma ias
in
2272 let ibs_split = resplit_initialiser ibs iicomma
in
2274 if need_unordered_initialisers ibs
2275 then initialisers_unordered2 allminus
ias_unsplit ibs_split >>=
2276 (fun ias_unsplit ibs_split ->
2278 split_icomma ias_unsplit,
2279 unsplit_initialiser ibs_split))
2282 and ar_initialisers
= fun ias
(ibs
, iicomma
) ->
2283 (* this doesn't check need_unordered_initialisers because ... can be
2284 implemented as ordered, even if it matches unordered initializers *)
2285 let ibs = resplit_initialiser ibs iicomma
in
2288 (List.map
(function (elem
,comma
) -> [Left elem
; Right
[comma
]]) ibs) in
2289 initialisers_ordered2 ias
ibs >>=
2290 (fun ias
ibs_split ->
2292 match List.rev
ibs_split with
2293 (Right comma
)::rest
-> (Ast_c.unsplit_comma
(List.rev rest
),comma
)
2294 | (Left _
)::_
-> (Ast_c.unsplit_comma
ibs_split,[]) (* possible *)
2296 return (ias
, (ibs,iicomma
)))
2298 and initialisers_ordered2
= fun ias
ibs ->
2300 match A.unwrap ea
with
2301 A.Idots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2303 let build_dots (mcode, optexpr
) = A.Idots
(mcode, optexpr
) in
2304 let match_comma ea
=
2305 match A.unwrap ea
with
2306 A.IComma ia1
-> Some ia1
2308 let build_comma ia1
= A.IComma ia1
in
2309 let match_metalist ea
= None
in
2310 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
2311 let mktermval v
= failwith
"not possible" in
2312 let special_cases ea
eas ebs
= None
in
2313 let no_ii x
= failwith
"not possible" in
2314 list_matcher match_dots build_dots match_comma build_comma
2315 match_metalist build_metalist mktermval
2316 special_cases initialiser
X.distrf_inis
no_ii ias
ibs
2319 and initialisers_unordered2
= fun allminus ias
ibs ->
2324 let rec loop = function
2325 [] -> return ([],[])
2326 | (ib
,comma
)::ibs ->
2327 X.distrf_ini
minusizer ib
>>= (fun _ ib
->
2328 tokenf minusizer comma
>>= (fun _ comma
->
2329 loop ibs >>= (fun l
ibs ->
2330 return(l
,(ib
,comma
)::ibs)))) in
2332 else return ([], ys
)
2334 let permut = Common.uncons_permut_lazy ys
in
2335 permut +> List.fold_left
(fun acc
((e
, pos
), rest
) ->
2337 (initialiser_comma x e
2339 let rest = Lazy.force
rest in
2340 initialisers_unordered2 allminus xs
rest >>= (fun xs
rest ->
2343 Common.insert_elem_pos
(e
, pos
) rest
2347 and initialiser_comma
(x
,xcomma
) (y
, commay
) =
2348 match A.unwrap xcomma
with
2350 tokenf commax commay
>>= (fun commax commay
->
2351 initialiser x y
>>= (fun x y
->
2353 (x
, (A.IComma commax
) +> A.rewrap xcomma
),
2355 | _
-> raise Impossible
(* unsplit_iicomma wrong *)
2357 (* ------------------------------------------------------------------------- *)
2358 and (struct_fields
: (A.declaration list
, B.field list
) matcher
) =
2361 match A.unwrap ea
with
2362 A.Ddots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2364 let build_dots (mcode, optexpr
) = A.Ddots
(mcode, optexpr
) in
2365 let match_comma ea
= None
in
2366 let build_comma ia1
= failwith
"not possible" in
2367 let match_metalist ea
= None
in
2368 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
2369 let mktermval v
= failwith
"not possible" in
2370 let special_cases ea
eas ebs
= None
in
2371 let no_ii x
= failwith
"not possible" in
2372 let make_ebs ebs
= List.map
(function x
-> Left x
) ebs
in
2373 let unmake_ebs ebs
=
2374 List.map
(function Left x
-> x
| Right x
-> failwith
"no right") ebs
in
2375 let distrf mcode startxs =
2376 let startxs = unmake_ebs startxs in
2377 X.distrf_struct_fields
mcode startxs >>=
2378 (fun mcode startxs -> return (mcode,make_ebs startxs)) in
2379 list_matcher match_dots build_dots match_comma build_comma
2380 match_metalist build_metalist mktermval
2381 special_cases struct_field
distrf no_ii eas (make_ebs ebs
) >>=
2382 (fun eas ebs
-> return (eas,unmake_ebs ebs
))
2384 and (struct_field
: (A.declaration
, B.field
) matcher
) = fun fa fb
->
2386 match A.unwrap fa
,fb
with
2387 | A.MetaField
(ida
,keep
,inherited
), _
->
2389 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_field fb
) in
2390 X.envf keep inherited
(ida
, Ast_c.MetaFieldVal fb
, max_min) (fun () ->
2391 X.distrf_field ida fb
2392 ) >>= (fun ida fb
->
2393 return ((A.MetaField
(ida
, keep
, inherited
))+> A.rewrap fa
,
2395 | _
,B.DeclarationField
(B.FieldDeclList
(onefield_multivars
,iiptvirg
)) ->
2397 let iiptvirgb = tuple_of_list1 iiptvirg
in
2399 (match onefield_multivars
with
2400 | [] -> raise Impossible
2401 | [onevar
,iivirg
] ->
2402 assert (null iivirg
);
2404 | B.BitField
(sopt
, typb
, _
, expr
) ->
2405 pr2_once
"warning: bitfield not handled by ast_cocci";
2407 | B.Simple
(None
, typb
) ->
2408 pr2_once
"warning: unamed struct field not handled by ast_cocci";
2410 | B.Simple
(Some nameidb
, typb
) ->
2412 (* build a declaration from a struct field *)
2413 let allminus = false in
2415 let stob = B.NoSto
, false in
2417 ({B.v_namei
= Some
(nameidb
, B.NoInit
);
2420 B.v_local
= Ast_c.NotLocalDecl
;
2421 B.v_attr
= Ast_c.noattr
;
2422 B.v_type_bis
= ref None
;
2423 (* the struct field should also get expanded ? no it's not
2424 * important here, we will rematch very soon *)
2428 onedecl
allminus fa
(fake_var,iiptvirgb,iisto) >>=
2429 (fun fa
(var
,iiptvirgb,iisto) ->
2432 | ({B.v_namei
= Some
(nameidb
, B.NoInit
);
2437 let onevar = B.Simple
(Some nameidb
, typb
) in
2441 ((B.DeclarationField
2442 (B.FieldDeclList
([onevar, iivirg
], [iiptvirgb])))
2445 | _
-> raise Impossible
2450 pr2_once
"PB: More that one variable in decl. Have to split";
2453 | _
,B.EmptyField _iifield
->
2456 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
),B.MacroDeclField
((sb
,ebs
),ii
) ->
2458 | _
,B.MacroDeclField
((sb
,ebs
),ii
) -> fail
2460 | _
,B.CppDirectiveStruct directive
-> fail
2461 | _
,B.IfdefStruct directive
-> fail
2464 and enum_fields
= fun eas ebs
->
2466 match A.unwrap ea
with
2467 A.Edots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2469 let build_dots (mcode, optexpr
) = A.Edots
(mcode, optexpr
) in
2470 let match_comma ea
=
2471 match A.unwrap ea
with
2472 A.EComma ia1
-> Some ia1
2474 let build_comma ia1
= A.EComma ia1
in
2475 let match_metalist ea
= None
in
2476 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
2477 let mktermval v
= failwith
"not possible" in
2478 let special_cases ea
eas ebs
= None
in
2479 list_matcher match_dots build_dots match_comma build_comma
2480 match_metalist build_metalist mktermval
2481 special_cases enum_field
X.distrf_enum_fields
2482 Lib_parsing_c.ii_of_enum_fields
eas ebs
2484 and enum_field ida idb
=
2485 X.all_bound
(A.get_inherited ida
) >&&>
2486 match A.unwrap ida
, idb
with
2487 A.Ident
(id
),(nameidb
,None
) ->
2488 ident_cpp DontKnow id nameidb
>>= (fun id nameidb
->
2489 return ((A.Ident id
) +> A.rewrap ida
, (nameidb
,None
)))
2490 | A.Assignment
(ea1
,opa
,ea2
,init
),(nameidb
,Some
(opbi,eb2
)) ->
2491 (match A.unwrap ea1
with
2493 ident_cpp DontKnow id nameidb
>>= (fun id nameidb
->
2494 expression ea2 eb2
>>= (fun ea2 eb2
->
2495 tokenf opa
opbi >>= (fun opa
opbi -> (* only one kind of assignop *)
2497 (A.Assignment
((A.Ident
(id
))+>A.rewrap ea1
,opa
,ea2
,init
)) +>
2499 (nameidb
,Some
(opbi,eb2
))))))
2500 | _
-> failwith
"not possible")
2501 | _
-> failwith
"not possible"
2503 (* ------------------------------------------------------------------------- *)
2504 and (fullType
: (A.fullType
, Ast_c.fullType
) matcher
) =
2506 X.optional_qualifier_flag
(fun optional_qualifier
->
2507 X.all_bound
(A.get_inherited typa
) >&&>
2508 match A.unwrap typa
, typb
with
2509 | A.Type
(cv
,ty1
), ((qu
,il
),ty2
) ->
2511 if qu
.B.const
&& qu
.B.volatile
2514 ("warning: the type is both const & volatile but cocci " ^
2515 "does not handle that");
2517 (* Drop out the const/volatile part that has been matched.
2518 * This is because a SP can contain const T v; in which case
2519 * later in match_t_t when we encounter a T, we must not add in
2520 * the environment the whole type.
2525 (* "iso-by-absence" *)
2528 fullTypebis ty1
((qu
,il
), ty2
) >>= (fun ty1 fullty2
->
2530 (A.Type
(None
, ty1
)) +> A.rewrap typa
,
2534 (match optional_qualifier
, qu
.B.const
|| qu
.B.volatile
with
2535 | false, false -> do_stuff ()
2536 | false, true -> fail
2537 | true, false -> do_stuff ()
2540 then pr2_once
"USING optional_qualifier builtin isomorphism";
2546 (* todo: can be __const__ ? can be const & volatile so
2547 * should filter instead ?
2549 (match term x
, il
with
2550 | A.Const
, [i1
] when qu
.B.const
->
2552 tokenf x i1
>>= (fun x i1
->
2553 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2555 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2559 | A.Volatile
, [i1
] when qu
.B.volatile
->
2560 tokenf x i1
>>= (fun x i1
->
2561 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2563 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2571 | A.DisjType typas
, typb
->
2573 List.fold_left
(fun acc typa
-> acc
>|+|> (fullType typa typb
)) fail
2575 | A.OptType
(_
), _
| A.UniqueType
(_
), _
2576 -> failwith
"not handling Opt/Unique on type"
2581 * Why not (A.typeC, Ast_c.typeC) matcher ?
2582 * because when there is MetaType, we want that T record the whole type,
2583 * including the qualifier, and so this type (and the new_il function in
2584 * preceding function).
2587 and (fullTypebis
: (A.typeC
, Ast_c.fullType
) matcher
) =
2589 X.all_bound
(A.get_inherited ta
) >&&>
2590 match A.unwrap ta
, tb
with
2593 | A.MetaType
(ida
,keep
, inherited
), typb
->
2595 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
2596 X.envf keep inherited
(ida
, B.MetaTypeVal typb
, max_min) (fun () ->
2597 X.distrf_type ida typb
>>= (fun ida typb
->
2599 A.MetaType
(ida
,keep
, inherited
) +> A.rewrap ta
,
2603 | unwrap
, (qub
, typb
) ->
2604 typeC ta typb
>>= (fun ta typb
->
2605 return (ta
, (qub
, typb
))
2608 and simulate_signed ta basea stringsa signaopt tb baseb ii rebuilda
=
2609 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2610 * And even if in baseb we have a Signed Int, that does not mean
2611 * that ii is of length 2, cos Signed is the default, so if in signa
2612 * we have Signed explicitely ? we cant "accrocher" this mcode to
2613 * something :( So for the moment when there is signed in cocci,
2614 * we force that there is a signed in c too (done in pattern.ml).
2616 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2619 (* handle some iso on type ? (cf complex C rule for possible implicit
2621 match basea
, baseb
with
2622 | A.VoidType
, B.Void
2623 | A.FloatType
, B.FloatType
(B.CFloat
)
2624 | A.DoubleType
, B.FloatType
(B.CDouble
)
2625 | A.SizeType
, B.SizeType
2626 | A.SSizeType
, B.SSizeType
2627 | A.PtrDiffType
,B.PtrDiffType
->
2628 assert (signaopt
=*= None
);
2629 let stringa = tuple_of_list1 stringsa
in
2630 let (ibaseb
) = tuple_of_list1 ii
in
2631 tokenf stringa ibaseb
>>= (fun stringa ibaseb
->
2633 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2634 (B.BaseType baseb
, [ibaseb
])
2637 | A.CharType
, B.IntType
B.CChar
when signaopt
=*= None
->
2638 let stringa = tuple_of_list1 stringsa
in
2639 let ibaseb = tuple_of_list1 ii
in
2640 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2642 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2643 (B.BaseType
(B.IntType
B.CChar
), [ibaseb])
2646 | A.CharType
,B.IntType
(B.Si
(_sign
, B.CChar2
)) when signaopt
<> None
->
2647 let stringa = tuple_of_list1 stringsa
in
2648 let ibaseb = tuple_of_list1 iibaseb
in
2649 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2650 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2652 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2653 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2656 | A.ShortType
, B.IntType
(B.Si
(_
, B.CShort
))
2657 | A.IntType
, B.IntType
(B.Si
(_
, B.CInt
))
2658 | A.LongType
, B.IntType
(B.Si
(_
, B.CLong
)) ->
2659 let stringa = tuple_of_list1 stringsa
in
2662 (* iso-by-presence ? *)
2663 (* when unsigned int in SP, allow have just unsigned in C ? *)
2664 if mcode_contain_plus (mcodekind stringa)
2668 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2670 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2671 (B.BaseType
(baseb
), iisignbopt
++ [])
2677 "warning: long int or short int not handled by ast_cocci";
2681 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2682 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2684 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2685 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2687 | _
-> raise Impossible
2692 | A.LongLongType
, B.IntType
(B.Si
(_
, B.CLongLong
)) ->
2693 let (string1a
,string2a
) = tuple_of_list2 stringsa
in
2695 [ibase1b
;ibase2b
] ->
2696 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2697 tokenf string1a ibase1b
>>= (fun base1a ibase1b
->
2698 tokenf string2a ibase2b
>>= (fun base2a ibase2b
->
2700 (rebuilda
([base1a
;base2a
], signaopt
)) +> A.rewrap ta
,
2701 (B.BaseType
(baseb
), iisignbopt
++ [ibase1b
;ibase2b
])
2703 | [] -> fail (* should something be done in this case? *)
2704 | _
-> raise Impossible
)
2707 | _
, B.FloatType
B.CLongDouble
2710 "warning: long double not handled by ast_cocci";
2713 | _
, (B.Void
|B.FloatType _
|B.IntType _
2714 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
2716 and simulate_signed_meta ta basea signaopt tb baseb ii rebuilda
=
2717 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2718 * And even if in baseb we have a Signed Int, that does not mean
2719 * that ii is of length 2, cos Signed is the default, so if in signa
2720 * we have Signed explicitely ? we cant "accrocher" this mcode to
2721 * something :( So for the moment when there is signed in cocci,
2722 * we force that there is a signed in c too (done in pattern.ml).
2724 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2726 let match_to_type rebaseb
=
2727 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2728 let fta = A.rewrap basea
(A.Type
(None
,basea
)) in
2729 let ftb = Ast_c.nQ
,(B.BaseType
(rebaseb
), iibaseb
) in
2730 fullType
fta ftb >>= (fun fta (_
,tb
) ->
2731 (match A.unwrap
fta,tb
with
2732 A.Type
(_
,basea
), (B.BaseType baseb
, ii
) ->
2734 (rebuilda
(basea
, signaopt
)) +> A.rewrap ta
,
2735 (B.BaseType
(baseb
), iisignbopt
++ ii
)
2737 | _
-> failwith
"not possible"))) in
2739 (* handle some iso on type ? (cf complex C rule for possible implicit
2742 | B.IntType
(B.Si
(_sign
, B.CChar2
)) ->
2743 match_to_type (B.IntType
B.CChar
)
2745 | B.IntType
(B.Si
(_
, ty
)) ->
2747 | [] -> fail (* metavariable has to match something *)
2749 | _
-> match_to_type (B.IntType
(B.Si
(B.Signed
, ty
)))
2753 | (B.Void
|B.FloatType _
|B.IntType _
2754 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
2756 and (typeC
: (A.typeC
, Ast_c.typeC
) matcher
) =
2758 match A.unwrap ta
, tb
with
2759 | A.BaseType
(basea
,stringsa
), (B.BaseType baseb
, ii
) ->
2760 simulate_signed ta basea stringsa None tb baseb ii
2761 (function (stringsa
, signaopt
) -> A.BaseType
(basea
,stringsa
))
2762 | A.SignedT
(signaopt
, Some basea
), (B.BaseType baseb
, ii
) ->
2763 (match A.unwrap basea
with
2764 A.BaseType
(basea1
,strings1
) ->
2765 simulate_signed ta basea1 strings1
(Some signaopt
) tb baseb ii
2766 (function (strings1
, Some signaopt
) ->
2769 Some
(A.rewrap basea
(A.BaseType
(basea1
,strings1
))))
2770 | _
-> failwith
"not possible")
2771 | A.MetaType
(ida
,keep
,inherited
) ->
2772 simulate_signed_meta ta basea
(Some signaopt
) tb baseb ii
2773 (function (basea
, Some signaopt
) ->
2774 A.SignedT
(signaopt
,Some basea
)
2775 | _
-> failwith
"not possible")
2776 | _
-> failwith
"not possible")
2777 | A.SignedT
(signa
,None
), (B.BaseType baseb
, ii
) ->
2778 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2779 (match iibaseb
, baseb
with
2780 | [], B.IntType
(B.Si
(_sign
, B.CInt
)) ->
2781 sign
(Some signa
) signbopt >>= (fun signaopt iisignbopt
->
2783 | None
-> raise Impossible
2786 (A.SignedT
(signa
,None
)) +> A.rewrap ta
,
2787 (B.BaseType baseb
, iisignbopt
)
2795 (* todo? iso with array *)
2796 | A.Pointer
(typa
, iamult
), (B.Pointer typb
, ii
) ->
2797 let (ibmult
) = tuple_of_list1 ii
in
2798 fullType typa typb
>>= (fun typa typb
->
2799 tokenf iamult ibmult
>>= (fun iamult ibmult
->
2801 (A.Pointer
(typa
, iamult
)) +> A.rewrap ta
,
2802 (B.Pointer typb
, [ibmult
])
2805 | A.FunctionType
(allminus,tyaopt
,lpa
,paramsa
,rpa
),
2806 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
) ->
2808 let (lpb
, rpb
) = tuple_of_list2 ii
in
2812 ("Not handling well variable length arguments func. "^
2813 "You have been warned");
2814 tokenf lpa lpb
>>= (fun lpa lpb
->
2815 tokenf rpa rpb
>>= (fun rpa rpb
->
2816 fullType_optional_allminus
allminus tyaopt tyb
>>= (fun tyaopt tyb
->
2817 parameters
(seqstyle paramsa
) (A.undots paramsa
) paramsb
>>=
2818 (fun paramsaundots paramsb
->
2819 let paramsa = redots
paramsa paramsaundots
in
2821 (A.FunctionType
(allminus,tyaopt
,lpa
,paramsa,rpa
) +> A.rewrap ta
,
2822 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), [lpb
;rpb
])
2830 | A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
),
2831 (B.ParenType t1
, ii
) ->
2832 let (lp1b
, rp1b
) = tuple_of_list2 ii
in
2833 let (qu1b
, t1b
) = t1
in
2835 | B.Pointer t2
, ii
->
2836 let (starb
) = tuple_of_list1 ii
in
2837 let (qu2b
, t2b
) = t2
in
2839 | B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
->
2840 let (lp2b
, rp2b
) = tuple_of_list2 ii
in
2845 ("Not handling well variable length arguments func. "^
2846 "You have been warned");
2848 fullType tya tyb
>>= (fun tya tyb
->
2849 tokenf lp1a lp1b
>>= (fun lp1a lp1b
->
2850 tokenf rp1a rp1b
>>= (fun rp1a rp1b
->
2851 tokenf lp2a lp2b
>>= (fun lp2a lp2b
->
2852 tokenf rp2a rp2b
>>= (fun rp2a rp2b
->
2853 tokenf stara starb
>>= (fun stara starb
->
2854 parameters
(seqstyle paramsa) (A.undots
paramsa) paramsb
>>=
2855 (fun paramsaundots paramsb
->
2856 let paramsa = redots
paramsa paramsaundots
in
2860 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))),
2865 (B.Pointer
t2, [starb
]))
2869 (A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
))
2871 (B.ParenType
t1, [lp1b
;rp1b
])
2884 (* todo: handle the iso on optionnal size specifification ? *)
2885 | A.Array
(typa
, ia1
, eaopt
, ia2
), (B.Array
(ebopt
, typb
), ii
) ->
2886 let (ib1, ib2
) = tuple_of_list2 ii
in
2887 fullType typa typb
>>= (fun typa typb
->
2888 option expression eaopt ebopt
>>= (fun eaopt ebopt
->
2889 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2890 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2892 (A.Array
(typa
, ia1
, eaopt
, ia2
)) +> A.rewrap ta
,
2893 (B.Array
(ebopt
, typb
), [ib1;ib2
])
2897 (* todo: could also match a Struct that has provided a name *)
2898 (* This is for the case where the SmPL code contains "struct x", without
2899 a definition. In this case, the name field is always present.
2900 This case is also called from the case for A.StructUnionDef when
2901 a name is present in the C code. *)
2902 | A.StructUnionName
(sua
, Some sa
), (B.StructUnionName
(sub
, sb
), ii
) ->
2903 (* sa is now an ident, not an mcode, old: ... && (term sa) =$= sb *)
2904 let (ib1, ib2
) = tuple_of_list2 ii
in
2905 if equal_structUnion (term sua
) sub
2907 ident DontKnow sa
(sb
, ib2
) >>= (fun sa
(sb
, ib2
) ->
2908 tokenf sua
ib1 >>= (fun sua
ib1 ->
2910 (A.StructUnionName
(sua
, Some sa
)) +> A.rewrap ta
,
2911 (B.StructUnionName
(sub
, sb
), [ib1;ib2
])
2916 | A.StructUnionDef
(ty
, lba
, declsa, rba
),
2917 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
2919 let (ii_sub_sb
, lbb
, rbb
) =
2921 [iisub
; lbb
; rbb
] -> (Common.Left iisub
,lbb
,rbb
)
2922 | [iisub
; iisb
; lbb
; rbb
] -> (Common.Right
(iisub
,iisb
),lbb
,rbb
)
2923 | _
-> failwith
"list of length 3 or 4 expected" in
2926 match (sbopt
,ii_sub_sb
) with
2927 (None
,Common.Left iisub
) ->
2928 (* the following doesn't reconstruct the complete SP code, just
2929 the part that matched *)
2931 match A.unwrap
s with
2933 (match A.unwrap ty
with
2934 A.StructUnionName
(sua
, None
) ->
2935 (match (term sua
, sub
) with
2937 | (A.Union
,B.Union
) -> return ((),())
2940 tokenf sua iisub
>>= (fun sua iisub
->
2943 A.StructUnionName
(sua
, None
) +> A.rewrap
ty)
2945 return (ty,[iisub
])))
2947 | A.DisjType
(disjs
) ->
2949 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
2953 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
2955 (* build a StructUnionName from a StructUnion *)
2956 let fake_su = B.nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) in
2958 fullType
ty fake_su >>= (fun ty fake_su ->
2960 | _nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) ->
2961 return (ty, [iisub
; iisb
])
2962 | _
-> raise Impossible
)
2966 >>= (fun ty ii_sub_sb
->
2968 tokenf lba lbb
>>= (fun lba lbb
->
2969 tokenf rba rbb
>>= (fun rba rbb
->
2970 struct_fields
(A.undots
declsa) declsb
>>=(fun undeclsa declsb
->
2971 let declsa = redots
declsa undeclsa
in
2974 (A.StructUnionDef
(ty, lba
, declsa, rba
)) +> A.rewrap ta
,
2975 (B.StructUnion
(sub
, sbopt
, declsb
),ii_sub_sb
@[lbb
;rbb
])
2979 (* todo? handle isomorphisms ? because Unsigned Int can be match on a
2980 * uint in the C code. But some CEs consists in renaming some types,
2981 * so we don't want apply isomorphisms every time.
2983 | A.TypeName sa
, (B.TypeName
(nameb
, typb
), noii
) ->
2987 | B.RegularName
(sb
, iidb
) ->
2988 let iidb1 = tuple_of_list1 iidb
in
2992 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
2994 (A.TypeName sa
) +> A.rewrap ta
,
2995 (B.TypeName
(B.RegularName
(sb
, [iidb1]), typb
), noii
)
2999 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
3004 | _
, (B.NoType
, ii
) -> fail
3005 | _
, (B.TypeOfExpr e
, ii
) -> fail
3006 | _
, (B.TypeOfType e
, ii
) -> fail
3008 | _
, (B.ParenType e
, ii
) -> fail (* todo ?*)
3009 | A.EnumName
(en
,Some namea
), (B.EnumName nameb
, ii
) ->
3010 let (ib1,ib2
) = tuple_of_list2 ii
in
3011 ident DontKnow namea
(nameb
, ib2
) >>= (fun namea
(nameb
, ib2
) ->
3012 tokenf en
ib1 >>= (fun en
ib1 ->
3014 (A.EnumName
(en
, Some namea
)) +> A.rewrap ta
,
3015 (B.EnumName nameb
, [ib1;ib2
])
3018 | A.EnumDef
(ty, lba
, idsa
, rba
),
3019 (B.Enum
(sbopt
, idsb
), ii
) ->
3021 let (ii_sub_sb
, lbb
, rbb
, comma_opt
) =
3023 [iisub
; lbb
; rbb
; comma_opt
] ->
3024 (Common.Left iisub
,lbb
,rbb
,comma_opt
)
3025 | [iisub
; iisb
; lbb
; rbb
; comma_opt
] ->
3026 (Common.Right
(iisub
,iisb
),lbb
,rbb
,comma_opt
)
3027 | _
-> failwith
"list of length 4 or 5 expected" in
3030 match (sbopt
,ii_sub_sb
) with
3031 (None
,Common.Left iisub
) ->
3032 (* the following doesn't reconstruct the complete SP code, just
3033 the part that matched *)
3035 match A.unwrap
s with
3037 (match A.unwrap
ty with
3038 A.EnumName
(sua
, None
) ->
3039 tokenf sua iisub
>>= (fun sua iisub
->
3041 A.Type
(None
,A.EnumName
(sua
, None
) +> A.rewrap
ty)
3043 return (ty,[iisub
]))
3045 | A.DisjType
(disjs
) ->
3047 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
3051 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
3053 (* build an EnumName from an Enum *)
3054 let fake_su = B.nQ
, (B.EnumName sb
, [iisub
;iisb
]) in
3056 fullType
ty fake_su >>= (fun ty fake_su ->
3058 | _nQ
, (B.EnumName sb
, [iisub
;iisb
]) ->
3059 return (ty, [iisub
; iisb
])
3060 | _
-> raise Impossible
)
3064 >>= (fun ty ii_sub_sb
->
3066 tokenf lba lbb
>>= (fun lba lbb
->
3067 tokenf rba rbb
>>= (fun rba rbb
->
3068 let idsb = resplit_initialiser idsb [comma_opt
] in
3072 (function (elem
,comma
) -> [Left elem
; Right
[comma
]])
3074 enum_fields
(A.undots idsa
) idsb >>= (fun unidsa
idsb ->
3075 let idsa = redots
idsa unidsa
in
3077 match List.rev
idsb with
3078 (Right comma
)::rest ->
3079 (Ast_c.unsplit_comma
(List.rev
rest),comma
)
3080 | (Left _
)::_
-> (Ast_c.unsplit_comma
idsb,[]) (* possible *)
3083 (A.EnumDef
(ty, lba
, idsa, rba
)) +> A.rewrap ta
,
3084 (B.Enum
(sbopt
, idsb),ii_sub_sb
@[lbb
;rbb
]@iicomma
)
3088 | _
, (B.Enum _
, _
) -> fail (* todo cocci ?*)
3091 ((B.TypeName _
| B.StructUnionName
(_
, _
) | B.EnumName _
|
3092 B.StructUnion
(_
, _
, _
) |
3093 B.FunctionType _
| B.Array
(_
, _
) | B.Pointer _
|
3099 (* todo: iso on sign, if not mentioned then free. tochange?
3100 * but that require to know if signed int because explicit
3101 * signed int, or because implicit signed int.
3104 and sign signa signb
=
3105 match signa
, signb
with
3106 | None
, None
-> return (None
, [])
3107 | Some signa
, Some
(signb
, ib
) ->
3108 if equal_sign (term signa
) signb
3109 then tokenf signa ib
>>= (fun signa ib
->
3110 return (Some signa
, [ib
])
3116 and minusize_list iixs
=
3117 iixs
+> List.fold_left
(fun acc ii
->
3118 acc
>>= (fun xs ys
->
3119 tokenf minusizer ii
>>= (fun minus ii
->
3120 return (minus
::xs
, ii
::ys
)
3121 ))) (return ([],[]))
3122 >>= (fun _xsminys ys
->
3123 return ((), List.rev ys
)
3126 and storage_optional_allminus
allminus stoa
(stob, iistob
) =
3127 (* "iso-by-absence" for storage, and return type. *)
3128 X.optional_storage_flag
(fun optional_storage
->
3129 match stoa
, stob with
3130 | None
, (stobis
, inline
) ->
3134 minusize_list iistob
>>= (fun () iistob
->
3135 return (None
, (stob, iistob
))
3137 else return (None
, (stob, iistob
))
3140 (match optional_storage
, stobis
with
3141 | false, B.NoSto
-> do_minus ()
3143 | true, B.NoSto
-> do_minus ()
3146 then pr2_once
"USING optional_storage builtin isomorphism";
3150 | Some x
, ((stobis
, inline
)) ->
3151 if equal_storage (term x
) stobis
3153 let rec loop acc
= function
3156 let str = B.str_of_info i1
in
3158 "static" | "extern" | "auto" | "register" ->
3159 (* not very elegant, but tokenf doesn't know what token to
3161 tokenf x i1
>>= (fun x i1
->
3162 let rebuilt = (List.rev acc
) @ i1
:: iistob
in
3163 return (Some x
, ((stobis
, inline
), rebuilt)))
3164 | _
-> loop (i1
::acc
) iistob
) in
3169 and inline_optional_allminus
allminus inla
(stob, iistob
) =
3170 (* "iso-by-absence" for storage, and return type. *)
3171 X.optional_storage_flag
(fun optional_storage
->
3172 match inla
, stob with
3173 | None
, (stobis
, inline
) ->
3177 minusize_list iistob
>>= (fun () iistob
->
3178 return (None
, (stob, iistob
))
3180 else return (None
, (stob, iistob
))
3189 then pr2_once
"USING optional_storage builtin isomorphism";
3192 else fail (* inline not in SP and present in C code *)
3195 | Some x
, ((stobis
, inline
)) ->
3198 let rec loop acc
= function
3201 let str = B.str_of_info i1
in
3204 (* not very elegant, but tokenf doesn't know what token to
3206 tokenf x i1
>>= (fun x i1
->
3207 let rebuilt = (List.rev acc
) @ i1
:: iistob
in
3208 return (Some x
, ((stobis
, inline
), rebuilt)))
3209 | _
-> loop (i1
::acc
) iistob
) in
3211 else fail (* SP has inline, but the C code does not *)
3214 and fullType_optional_allminus
allminus tya retb
=
3219 X.distrf_type
minusizer retb
>>= (fun _x retb
->
3223 else return (None
, retb
)
3225 fullType tya retb
>>= (fun tya retb
->
3226 return (Some tya
, retb
)
3231 (*---------------------------------------------------------------------------*)
3233 and compatible_base_type a signa b
=
3234 let ok = return ((),()) in
3237 | Type_cocci.VoidType
, B.Void
3238 | Type_cocci.SizeType
, B.SizeType
3239 | Type_cocci.SSizeType
, B.SSizeType
3240 | Type_cocci.PtrDiffType
, B.PtrDiffType
->
3241 assert (signa
=*= None
);
3243 | Type_cocci.CharType
, B.IntType
B.CChar
when signa
=*= None
->
3245 | Type_cocci.CharType
, B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3246 compatible_sign signa signb
3247 | Type_cocci.ShortType
, B.IntType
(B.Si
(signb
, B.CShort
)) ->
3248 compatible_sign signa signb
3249 | Type_cocci.IntType
, B.IntType
(B.Si
(signb
, B.CInt
)) ->
3250 compatible_sign signa signb
3251 | Type_cocci.LongType
, B.IntType
(B.Si
(signb
, B.CLong
)) ->
3252 compatible_sign signa signb
3253 | _
, B.IntType
(B.Si
(signb
, B.CLongLong
)) ->
3254 pr2_once
"no longlong in cocci";
3256 | Type_cocci.FloatType
, B.FloatType
B.CFloat
->
3257 assert (signa
=*= None
);
3259 | Type_cocci.DoubleType
, B.FloatType
B.CDouble
->
3260 assert (signa
=*= None
);
3262 | _
, B.FloatType
B.CLongDouble
->
3263 pr2_once
"no longdouble in cocci";
3265 | Type_cocci.BoolType
, _
-> failwith
"no booltype in C"
3267 | _
, (B.Void
|B.FloatType _
|B.IntType _
3268 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
3270 and compatible_base_type_meta a signa qua b ii
local =
3272 | Type_cocci.MetaType
(ida
,keep
,inherited
),
3273 B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3274 compatible_sign signa signb
>>= fun _ _
->
3275 let newb = ((qua
, (B.BaseType
(B.IntType
B.CChar
),ii
)),local) in
3276 compatible_type a
newb
3277 | Type_cocci.MetaType
(ida
,keep
,inherited
), B.IntType
(B.Si
(signb
, ty)) ->
3278 compatible_sign signa signb
>>= fun _ _
->
3280 ((qua
, (B.BaseType
(B.IntType
(B.Si
(B.Signed
, ty))),ii
)),local) in
3281 compatible_type a
newb
3282 | _
, B.FloatType
B.CLongDouble
->
3283 pr2_once
"no longdouble in cocci";
3286 | _
, (B.Void
|B.FloatType _
|B.IntType _
3287 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
3290 and compatible_type a
(b
,local) =
3291 let ok = return ((),()) in
3293 let rec loop = function
3294 | _
, (qua
, (B.NoType
, _
)) ->
3295 failwith
"compatible_type: matching with NoType"
3296 | Type_cocci.BaseType a
, (qua
, (B.BaseType b
,ii
)) ->
3297 compatible_base_type a None b
3299 | Type_cocci.SignedT
(signa
,None
), (qua
, (B.BaseType b
,ii
)) ->
3300 compatible_base_type
Type_cocci.IntType
(Some signa
) b
3302 | Type_cocci.SignedT
(signa
,Some
ty), (qua
, (B.BaseType b
,ii
)) ->
3304 Type_cocci.BaseType
ty ->
3305 compatible_base_type
ty (Some signa
) b
3306 | Type_cocci.MetaType
(ida
,keep
,inherited
) ->
3307 compatible_base_type_meta
ty (Some signa
) qua b ii
local
3308 | _
-> failwith
"not possible")
3310 | Type_cocci.Pointer a
, (qub
, (B.Pointer b
, ii
)) ->
3312 | Type_cocci.FunctionPointer a
, _
->
3314 "TODO: function pointer type doesn't store enough information to determine compatability"
3315 | Type_cocci.Array a
, (qub
, (B.Array
(eopt
, b
),ii
)) ->
3316 (* no size info for cocci *)
3318 | Type_cocci.StructUnionName
(sua
, name
),
3319 (qub
, (B.StructUnionName
(sub
, sb
),ii
)) ->
3320 if equal_structUnion_type_cocci sua sub
3321 then structure_type_name name sb ii
3323 | Type_cocci.EnumName
(name
),
3324 (qub
, (B.EnumName
(sb
),ii
)) -> structure_type_name name sb ii
3325 | Type_cocci.TypeName sa
, (qub
, (B.TypeName
(namesb
, _typb
),noii
)) ->
3326 let sb = Ast_c.str_of_name namesb
in
3331 | Type_cocci.ConstVol
(qua
, a
), (qub
, b
) ->
3332 if (fst qub
).B.const
&& (fst qub
).B.volatile
3335 pr2_once
("warning: the type is both const & volatile but cocci " ^
3336 "does not handle that");
3342 | Type_cocci.Const
-> (fst qub
).B.const
3343 | Type_cocci.Volatile
-> (fst qub
).B.volatile
3345 then loop (a
,(Ast_c.nQ
, b
))
3348 | Type_cocci.MetaType
(ida
,keep
,inherited
), typb
->
3350 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
3351 X.envf keep inherited
(A.make_mcode ida
, B.MetaTypeVal typb
, max_min)
3355 (* subtil: must be after the MetaType case *)
3356 | a
, (qub
, (B.TypeName
(_namesb
, Some b
), noii
)) ->
3357 (* kind of typedef iso *)
3360 (* for metavariables of type expression *^* *)
3361 | Type_cocci.Unknown
, _
-> ok
3366 B.TypeOfType _
|B.TypeOfExpr _
|B.ParenType _
|
3367 B.EnumName _
|B.StructUnion
(_
, _
, _
)|B.Enum
(_
, _
)
3374 B.StructUnionName
(_
, _
)|
3376 B.Array
(_
, _
)|B.Pointer _
|B.TypeName _
|
3381 and structure_type_name nm
sb ii
=
3383 Type_cocci.NoName
-> ok
3384 | Type_cocci.Name sa
->
3388 | Type_cocci.MV
(ida
,keep
,inherited
) ->
3389 (* degenerate version of MetaId, no transformation possible *)
3390 let (ib1, ib2
) = tuple_of_list2 ii
in
3391 let max_min _
= Lib_parsing_c.lin_col_by_pos
[ib2
] in
3392 let mida = A.make_mcode ida
in
3393 X.envf keep inherited
(mida, B.MetaIdVal
(sb,[]), max_min)
3399 and compatible_sign signa signb
=
3400 let ok = return ((),()) in
3401 match signa
, signb
with
3403 | Some
Type_cocci.Signed
, B.Signed
3404 | Some
Type_cocci.Unsigned
, B.UnSigned
3409 and equal_structUnion_type_cocci a b
=
3411 | Type_cocci.Struct
, B.Struct
-> true
3412 | Type_cocci.Union
, B.Union
-> true
3413 | _
, (B.Struct
| B.Union
) -> false
3417 (*---------------------------------------------------------------------------*)
3418 and inc_file
(a
, before_after
) (b
, h_rel_pos
) =
3420 let rec aux_inc (ass
, bss
) passed
=
3424 let passed = List.rev
passed in
3426 (match before_after
, !h_rel_pos
with
3427 | IncludeNothing
, _
-> true
3428 | IncludeMcodeBefore
, Some x
->
3429 List.mem
passed (x
.Ast_c.first_of
)
3431 | IncludeMcodeAfter
, Some x
->
3432 List.mem
passed (x
.Ast_c.last_of
)
3434 (* no info, maybe cos of a #include <xx.h> that was already in a .h *)
3438 | (A.IncPath x
)::xs
, y
::ys
-> x
=$
= y
&& aux_inc (xs
, ys
) (x
::passed)
3439 | _
-> failwith
"IncDots not in last place or other pb"
3444 | A.Local ass
, B.Local bss
->
3445 aux_inc (ass
, bss
) []
3446 | A.NonLocal ass
, B.NonLocal bss
->
3447 aux_inc (ass
, bss
) []
3452 (*---------------------------------------------------------------------------*)
3454 and (define_params
: sequence
->
3455 (A.define_param list
, (string B.wrap
) B.wrap2 list
) matcher
) =
3456 fun seqstyle eas ebs
->
3458 | Unordered
-> failwith
"not handling ooo"
3460 define_paramsbis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
3461 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
3464 (* todo? facto code with argument and parameters ? *)
3465 and define_paramsbis
= fun eas ebs
->
3467 match A.unwrap ea
with
3468 A.DPdots
(mcode) -> Some
(mcode, None
)
3470 let build_dots (mcode, _optexpr
) = A.DPdots
(mcode) in
3471 let match_comma ea
=
3472 match A.unwrap ea
with
3473 A.DPComma ia1
-> Some ia1
3475 let build_comma ia1
= A.DPComma ia1
in
3476 let match_metalist ea
= None
in
3477 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
3478 let mktermval v
= failwith
"not possible" in
3479 let special_cases ea
eas ebs
= None
in
3480 let no_ii x
= failwith
"not possible" in
3481 list_matcher match_dots build_dots match_comma build_comma
3482 match_metalist build_metalist mktermval
3483 special_cases define_parameter
X.distrf_define_params
no_ii eas ebs
3485 and define_parameter
= fun parama paramb
->
3486 match A.unwrap parama
, paramb
with
3487 A.DParam ida
, (idb
, ii
) ->
3488 let ib1 = tuple_of_list1 ii
in
3489 ident DontKnow ida
(idb
, ib1) >>= (fun ida
(idb
, ib1) ->
3490 return ((A.DParam ida
)+> A.rewrap parama
,(idb
, [ib1])))
3491 | (A.OptDParam _
| A.UniqueDParam _
), _
->
3492 failwith
"handling Opt/Unique for define parameters"
3493 | A.DPcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
3496 (*****************************************************************************)
3498 (*****************************************************************************)
3500 (* no global solution for positions here, because for a statement metavariable
3501 we want a MetaStmtVal, and for the others, it's not clear what we want *)
3503 let rec (rule_elem_node
: (A.rule_elem
, Control_flow_c.node
) matcher
) =
3506 x
>>= (fun a b
-> return (A.rewrap re a
, F.rewrap node b
))
3508 X.all_bound
(A.get_inherited re
) >&&>
3511 match A.unwrap re
, F.unwrap node
with
3513 (* note: the order of the clauses is important. *)
3515 | _
, F.Enter
| _
, F.Exit
| _
, F.ErrorExit
-> fail2()
3517 (* the metaRuleElem contains just '-' information. We dont need to add
3518 * stuff in the environment. If we need stuff in environment, because
3519 * there is a + S somewhere, then this will be done via MetaStmt, not
3521 * Can match TrueNode/FalseNode/... so must be placed before those cases.
3524 | A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
->
3525 let default = A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
in
3526 (match unwrap_node
with
3528 | F.TrueNode
| F.FalseNode
| F.AfterNode
3529 | F.LoopFallThroughNode
| F.FallThroughNode
3531 if X.mode
=*= PatternMode
3534 if mcode_contain_plus (mcodekind mcode)
3535 then failwith
"try add stuff on fake node"
3536 (* minusize or contextize a fake node is ok *)
3539 | F.EndStatement None
->
3540 if X.mode
=*= PatternMode
then return default
3542 (* DEAD CODE NOW ? only useful in -no_cocci_vs_c_3 ?
3543 if mcode_contain_plus (mcodekind mcode)
3545 let fake_info = Ast_c.fakeInfo() in
3546 distrf distrf_node (mcodekind mcode)
3547 (F.EndStatement (Some fake_info))
3548 else return unwrap_node
3552 | F.EndStatement
(Some i1
) ->
3553 tokenf mcode i1
>>= (fun mcode i1
->
3555 A.MetaRuleElem
(mcode,keep
, inherited
),
3556 F.EndStatement
(Some i1
)
3560 if X.mode
=*= PatternMode
then return default
3561 else failwith
"a MetaRuleElem can't transform a headfunc"
3563 if X.mode
=*= PatternMode
then return default
3565 X.distrf_node
(generalize_mcode mcode) node
>>= (fun mcode node
->
3567 A.MetaRuleElem
(mcode,keep
, inherited
),
3573 (* rene cant have found that a state containing a fake/exit/... should be
3575 * TODO: and F.Fake ?
3577 | _
, F.EndStatement _
| _
, F.CaseNode _
3578 | _
, F.TrueNode
| _
, F.FalseNode
| _
, F.AfterNode
3579 | _
, F.FallThroughNode
| _
, F.LoopFallThroughNode
3580 | _
, F.InLoopNode
-> fail2()
3582 (* really ? diff between pattern.ml and transformation.ml *)
3583 | _
, F.Fake
-> fail2()
3586 (* cas general: a Meta can match everything. It matches only
3587 * "header"-statement. We transform only MetaRuleElem, not MetaStmt.
3588 * So can't have been called in transform.
3590 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), F.Decl
(_
) -> fail
3592 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), unwrap_node
->
3593 (* todo: should not happen in transform mode *)
3595 (match Control_flow_c.extract_fullstatement node
with
3598 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_stmt stb
) in
3599 X.envf keep inherited
(ida
, Ast_c.MetaStmtVal stb
, max_min)
3601 (* no need tag ida, we can't be called in transform-mode *)
3603 A.MetaStmt
(ida
, keep
, metainfoMaybeTodo
, inherited
),
3611 | A.MetaStmtList _
, _
->
3612 failwith
"not handling MetaStmtList"
3614 | A.TopExp ea
, F.DefineExpr eb
->
3615 expression ea eb
>>= (fun ea eb
->
3621 | A.TopExp ea
, F.DefineType eb
->
3622 (match A.unwrap ea
with
3624 fullType ft eb
>>= (fun ft eb
->
3626 A.TopExp
(A.rewrap ea
(A.TypeExp
(ft
))),
3633 (* It is important to put this case before the one that fails because
3634 * of the lack of the counter part of a C construct in SmPL (for instance
3635 * there is not yet a CaseRange in SmPL). Even if SmPL don't handle
3636 * yet certain constructs, those constructs may contain expression
3637 * that we still want and can transform.
3640 | A.Exp exp
, nodeb
->
3642 (* kind of iso, initialisation vs affectation *)
3644 match A.unwrap exp
, nodeb
with
3645 | A.Assignment
(ea
, op
, eb
, true), F.Decl decl
->
3646 initialisation_to_affectation decl
+> F.rewrap node
3651 (* Now keep fullstatement inside the control flow node,
3652 * so that can then get in a MetaStmtVar the fullstatement to later
3653 * pp back when the S is in a +. But that means that
3654 * Exp will match an Ifnode even if there is no such exp
3655 * inside the condition of the Ifnode (because the exp may
3656 * be deeper, in the then branch). So have to not visit
3657 * all inside a node anymore.
3659 * update: j'ai choisi d'accrocher au noeud du CFG Ã la
3660 * fois le fullstatement et le partialstatement et appeler le
3661 * visiteur que sur le partialstatement.
3664 match Ast_cocci.get_pos re
with
3665 | None
-> expression
3669 Lib_parsing_c.max_min_by_pos
(Lib_parsing_c.ii_of_expr eb
) in
3670 let keep = Type_cocci.Unitary
in
3671 let inherited = false in
3672 let max_min _
= failwith
"no pos" in
3673 X.envf
keep inherited (pos
, B.MetaPosVal
(min
,max
), max_min)
3679 X.cocciExp
expfn exp
node >>= (fun exp
node ->
3687 X.cocciTy fullType
ty node >>= (fun ty node ->
3694 | A.TopInit init
, nodeb
->
3695 X.cocciInit initialiser init
node >>= (fun init
node ->
3703 | A.FunHeader
(mckstart
, allminus, fninfoa
, ida
, oparen
, paramsa, cparen
),
3704 F.FunHeader
({B.f_name
= nameidb
;
3705 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3709 f_old_c_style
= oldstyle
;
3714 then pr2 "OLD STYLE DECL NOT WELL SUPPORTED";
3717 (* fninfoa records the order in which the SP specified the various
3718 information, but this isn't taken into account in the matching.
3719 Could this be a problem for transformation? *)
3722 List.filter
(function A.FStorage
(s) -> true | _
-> false) fninfoa
3723 with [A.FStorage
(s)] -> Some
s | _
-> None
in
3725 match List.filter
(function A.FType
(s) -> true | _
-> false) fninfoa
3726 with [A.FType
(t
)] -> Some t
| _
-> None
in
3729 match List.filter
(function A.FInline
(i
) -> true | _
-> false) fninfoa
3730 with [A.FInline
(i
)] -> Some i
| _
-> None
in
3732 (match List.filter
(function A.FAttr
(a
) -> true | _
-> false) fninfoa
3733 with [A.FAttr
(a
)] -> failwith
"not checking attributes" | _
-> ());
3736 | ioparenb
::icparenb
::iifakestart
::iistob
->
3738 (* maybe important to put ident as the first tokens to transform.
3739 * It's related to transform_proto. So don't change order
3742 ident_cpp LocalFunction ida nameidb
>>= (fun ida nameidb
->
3743 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
3744 tokenf oparen ioparenb
>>= (fun oparen ioparenb
->
3745 tokenf cparen icparenb
>>= (fun cparen icparenb
->
3746 parameters
(seqstyle paramsa)
3747 (A.undots
paramsa) paramsb
>>=
3748 (fun paramsaundots paramsb
->
3749 let paramsa = redots
paramsa paramsaundots
in
3750 inline_optional_allminus
allminus
3751 inla (stob, iistob
) >>= (fun inla (stob, iistob
) ->
3752 storage_optional_allminus
allminus
3753 stoa (stob, iistob
) >>= (fun stoa (stob, iistob
) ->
3758 ("Not handling well variable length arguments func. "^
3759 "You have been warned");
3761 then minusize_list iidotsb
3762 else return ((),iidotsb
)
3763 ) >>= (fun () iidotsb
->
3765 fullType_optional_allminus
allminus tya retb
>>= (fun tya retb
->
3768 (match stoa with Some st
-> [A.FStorage st
] | None
-> []) ++
3769 (match inla with Some i
-> [A.FInline i
] | None
-> []) ++
3770 (match tya with Some t
-> [A.FType t
] | None
-> [])
3775 A.FunHeader
(mckstart
,allminus,fninfoa,ida
,oparen
,
3777 F.FunHeader
({B.f_name
= nameidb
;
3778 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3782 f_old_c_style
= oldstyle
; (* TODO *)
3784 ioparenb
::icparenb
::iifakestart
::iistob
)
3787 | _
-> raise Impossible
3795 | A.Decl
(mckstart
,allminus,decla
), F.Decl declb
->
3796 declaration
(mckstart
,allminus,decla
) declb
>>=
3797 (fun (mckstart
,allminus,decla
) declb
->
3799 A.Decl
(mckstart
,allminus,decla
),
3804 | A.SeqStart
mcode, F.SeqStart
(st
, level
, i1
) ->
3805 tokenf mcode i1
>>= (fun mcode i1
->
3808 F.SeqStart
(st
, level
, i1
)
3811 | A.SeqEnd
mcode, F.SeqEnd
(level
, i1
) ->
3812 tokenf mcode i1
>>= (fun mcode i1
->
3815 F.SeqEnd
(level
, i1
)
3818 | A.ExprStatement
(ea
, ia1
), F.ExprStatement
(st
, (Some eb
, ii
)) ->
3819 let ib1 = tuple_of_list1 ii
in
3820 expression ea eb
>>= (fun ea eb
->
3821 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3823 A.ExprStatement
(ea
, ia1
),
3824 F.ExprStatement
(st
, (Some eb
, [ib1]))
3829 | A.IfHeader
(ia1
,ia2
, ea
, ia3
), F.IfHeader
(st
, (eb
,ii
)) ->
3830 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3831 expression ea eb
>>= (fun ea eb
->
3832 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3833 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3834 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3836 A.IfHeader
(ia1
, ia2
, ea
, ia3
),
3837 F.IfHeader
(st
, (eb
,[ib1;ib2
;ib3
]))
3840 | A.Else ia
, F.Else ib
->
3841 tokenf ia ib
>>= (fun ia ib
->
3842 return (A.Else ia
, F.Else ib
)
3845 | A.WhileHeader
(ia1
, ia2
, ea
, ia3
), F.WhileHeader
(st
, (eb
, ii
)) ->
3846 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3847 expression ea eb
>>= (fun ea eb
->
3848 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3849 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3850 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3852 A.WhileHeader
(ia1
, ia2
, ea
, ia3
),
3853 F.WhileHeader
(st
, (eb
, [ib1;ib2
;ib3
]))
3856 | A.DoHeader ia
, F.DoHeader
(st
, ib
) ->
3857 tokenf ia ib
>>= (fun ia ib
->
3862 | A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
), F.DoWhileTail
(eb
, ii
) ->
3863 let (ib1, ib2
, ib3
, ib4
) = tuple_of_list4 ii
in
3864 expression ea eb
>>= (fun ea eb
->
3865 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3866 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3867 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3868 tokenf ia4 ib4
>>= (fun ia4 ib4
->
3870 A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
),
3871 F.DoWhileTail
(eb
, [ib1;ib2
;ib3
;ib4
])
3873 | A.IteratorHeader
(ia1
, ia2
, eas, ia3
), F.MacroIterHeader
(st
, ((s,ebs
),ii
))
3875 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3877 ident DontKnow ia1
(s, ib1) >>= (fun ia1
(s, ib1) ->
3878 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3879 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3880 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
3881 let eas = redots
eas easundots
in
3883 A.IteratorHeader
(ia1
, ia2
, eas, ia3
),
3884 F.MacroIterHeader
(st
, ((s,ebs
), [ib1;ib2
;ib3
]))
3889 | A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3890 F.ForHeader
(st
, (((eb1opt
,ib3s
), (eb2opt
,ib4s
), (eb3opt
,ib4vide
)), ii
))
3892 assert (null ib4vide
);
3893 let (ib1, ib2
, ib5
) = tuple_of_list3 ii
in
3894 let ib3 = tuple_of_list1 ib3s
in
3895 let ib4 = tuple_of_list1 ib4s
in
3897 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3898 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3899 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3900 tokenf ia4
ib4 >>= (fun ia4
ib4 ->
3901 tokenf ia5 ib5
>>= (fun ia5 ib5
->
3902 option expression ea1opt eb1opt
>>= (fun ea1opt eb1opt
->
3903 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
3904 option expression ea3opt eb3opt
>>= (fun ea3opt eb3opt
->
3906 A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3907 F.ForHeader
(st
, (((eb1opt
,[ib3]), (eb2opt
,[ib4]), (eb3opt
,[])),
3913 | A.SwitchHeader
(ia1
,ia2
,ea
,ia3
), F.SwitchHeader
(st
, (eb
,ii
)) ->
3914 let (ib1, ib2
, ib3) = tuple_of_list3 ii
in
3915 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3916 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3917 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3918 expression ea eb
>>= (fun ea eb
->
3920 A.SwitchHeader
(ia1
,ia2
,ea
,ia3
),
3921 F.SwitchHeader
(st
, (eb
,[ib1;ib2
;ib3]))
3924 | A.Break
(ia1
, ia2
), F.Break
(st
, ((),ii
)) ->
3925 let (ib1, ib2
) = tuple_of_list2 ii
in
3926 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3927 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3930 F.Break
(st
, ((),[ib1;ib2
]))
3933 | A.Continue
(ia1
, ia2
), F.Continue
(st
, ((),ii
)) ->
3934 let (ib1, ib2
) = tuple_of_list2 ii
in
3935 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3936 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3938 A.Continue
(ia1
, ia2
),
3939 F.Continue
(st
, ((),[ib1;ib2
]))
3942 | A.Return
(ia1
, ia2
), F.Return
(st
, ((),ii
)) ->
3943 let (ib1, ib2
) = tuple_of_list2 ii
in
3944 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3945 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3947 A.Return
(ia1
, ia2
),
3948 F.Return
(st
, ((),[ib1;ib2
]))
3951 | A.ReturnExpr
(ia1
, ea
, ia2
), F.ReturnExpr
(st
, (eb
, ii
)) ->
3952 let (ib1, ib2
) = tuple_of_list2 ii
in
3953 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3954 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3955 expression ea eb
>>= (fun ea eb
->
3957 A.ReturnExpr
(ia1
, ea
, ia2
),
3958 F.ReturnExpr
(st
, (eb
, [ib1;ib2
]))
3963 | A.Include
(incla
,filea
),
3964 F.Include
{B.i_include
= (fileb
, ii
);
3965 B.i_rel_pos
= h_rel_pos
;
3966 B.i_is_in_ifdef
= inifdef
;
3969 assert (copt
=*= None
);
3971 let include_requirment =
3972 match mcodekind incla
, mcodekind filea
with
3973 | A.CONTEXT
(_
, A.BEFORE _
), _
->
3975 | _
, A.CONTEXT
(_
, A.AFTER _
) ->
3981 let (inclb
, iifileb
) = tuple_of_list2 ii
in
3982 if inc_file
(term filea
, include_requirment) (fileb
, h_rel_pos
)
3984 tokenf incla inclb
>>= (fun incla inclb
->
3985 tokenf filea iifileb
>>= (fun filea iifileb
->
3987 A.Include
(incla
, filea
),
3988 F.Include
{B.i_include
= (fileb
, [inclb
;iifileb
]);
3989 B.i_rel_pos
= h_rel_pos
;
3990 B.i_is_in_ifdef
= inifdef
;
3996 | A.Undef
(undefa
,ida
), F.DefineHeader
((idb
, ii
), B.Undef
) ->
3997 let (defineb
, iidb
, ieol
) = tuple_of_list3 ii
in
3998 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
3999 tokenf undefa defineb
>>= (fun undefa defineb
->
4001 A.Undef
(undefa
,ida
),
4002 F.DefineHeader
((idb
,[defineb
;iidb
;ieol
]),B.Undef
)
4007 | A.DefineHeader
(definea
,ida
,params
), F.DefineHeader
((idb
, ii
), defkind
) ->
4008 let (defineb
, iidb
, ieol
) = tuple_of_list3 ii
in
4009 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
4010 tokenf definea defineb
>>= (fun definea defineb
->
4011 (match A.unwrap params
, defkind
with
4012 | A.NoParams
, B.DefineVar
->
4014 A.NoParams
+> A.rewrap params
,
4017 | A.DParams
(lpa
,eas,rpa
), (B.DefineFunc
(ebs
, ii
)) ->
4018 let (lpb
, rpb
) = tuple_of_list2 ii
in
4019 tokenf lpa lpb
>>= (fun lpa lpb
->
4020 tokenf rpa rpb
>>= (fun rpa rpb
->
4022 define_params
(seqstyle eas) (A.undots
eas) ebs
>>=
4023 (fun easundots ebs
->
4024 let eas = redots
eas easundots
in
4026 A.DParams
(lpa
,eas,rpa
) +> A.rewrap params
,
4027 B.DefineFunc
(ebs
,[lpb
;rpb
])
4031 ) >>= (fun params defkind
->
4033 A.DefineHeader
(definea
, ida
, params
),
4034 F.DefineHeader
((idb
,[defineb
;iidb
;ieol
]),defkind
)
4039 | A.Default
(def
,colon
), F.Default
(st
, ((),ii
)) ->
4040 let (ib1, ib2
) = tuple_of_list2 ii
in
4041 tokenf def
ib1 >>= (fun def
ib1 ->
4042 tokenf colon ib2
>>= (fun colon ib2
->
4044 A.Default
(def
,colon
),
4045 F.Default
(st
, ((),[ib1;ib2
]))
4050 | A.Case
(case
,ea
,colon
), F.Case
(st
, (eb
,ii
)) ->
4051 let (ib1, ib2
) = tuple_of_list2 ii
in
4052 tokenf case
ib1 >>= (fun case
ib1 ->
4053 expression ea eb
>>= (fun ea eb
->
4054 tokenf colon ib2
>>= (fun colon ib2
->
4056 A.Case
(case
,ea
,colon
),
4057 F.Case
(st
, (eb
,[ib1;ib2
]))
4060 (* only occurs in the predicates generated by asttomember *)
4061 | A.DisjRuleElem
eas, _
->
4063 List.fold_left
(fun acc ea
-> acc
>|+|> (rule_elem_node ea
node)) fail)
4064 >>= (fun ea eb
-> return (A.unwrap ea
,F.unwrap eb
))
4066 | _
, F.ExprStatement
(_
, (None
, ii
)) -> fail (* happen ? *)
4068 | A.Label
(id
,dd
), F.Label
(st
, nameb
, ((),ii
)) ->
4069 let (ib2
) = tuple_of_list1 ii
in
4070 ident_cpp DontKnow id nameb
>>= (fun ida nameb
->
4071 tokenf dd ib2
>>= (fun dd ib2
->
4074 F.Label
(st
,nameb
, ((),[ib2
]))
4077 | A.Goto
(goto
,id
,sem
), F.Goto
(st
,nameb
, ((),ii
)) ->
4078 let (ib1,ib3) = tuple_of_list2 ii
in
4079 tokenf goto
ib1 >>= (fun goto
ib1 ->
4080 ident_cpp DontKnow id nameb
>>= (fun id nameb
->
4081 tokenf sem
ib3 >>= (fun sem
ib3 ->
4083 A.Goto
(goto
,id
,sem
),
4084 F.Goto
(st
,nameb
, ((),[ib1;ib3]))
4087 (* have not a counter part in coccinelle, for the moment *)
4088 (* todo?: print a warning at least ? *)
4094 | _
, (F.IfdefEndif _
|F.IfdefElse _
|F.IfdefHeader _
)
4098 (F.MacroStmt
(_
, _
)| F.DefineDoWhileZeroHeader _
| F.EndNode
|F.TopNode
)
4101 (F.Label
(_
, _
, _
)|F.Break
(_
, _
)|F.Continue
(_
, _
)|F.Default
(_
, _
)|
4102 F.Case
(_
, _
)|F.Include _
|F.Goto _
|F.ExprStatement _
|
4103 F.DefineType _
|F.DefineExpr _
|F.DefineTodo
|
4104 F.DefineHeader
(_
, _
)|F.ReturnExpr
(_
, _
)|F.Return
(_
, _
)|
4105 F.MacroIterHeader
(_
, _
)|
4106 F.SwitchHeader
(_
, _
)|F.ForHeader
(_
, _
)|F.DoWhileTail _
|F.DoHeader
(_
, _
)|
4107 F.WhileHeader
(_
, _
)|F.Else _
|F.IfHeader
(_
, _
)|
4108 F.SeqEnd
(_
, _
)|F.SeqStart
(_
, _
, _
)|
4109 F.Decl _
|F.FunHeader _
)