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
46 (Printf.sprintf
"%s: %d: %s"
47 (Ast_c.file_of_info ii
) (Ast_c.line_of_info ii
) str
)
49 (*****************************************************************************)
51 (*****************************************************************************)
53 type sequence
= Ordered
| Unordered
56 match A.unwrap eas
with
58 | A.CIRCLES _
-> Unordered
59 | A.STARS _
-> failwith
"not handling stars"
61 let (redots
: 'a
A.dots
-> 'a list
-> 'a
A.dots
)=fun eas easundots
->
63 match A.unwrap eas
with
64 | A.DOTS _
-> A.DOTS easundots
65 | A.CIRCLES _
-> A.CIRCLES easundots
66 | A.STARS _
-> A.STARS easundots
70 let (need_unordered_initialisers
: B.initialiser
B.wrap2 list
-> bool) =
72 ibs
+> List.exists
(fun (ib
, icomma
) ->
73 match B.unwrap ib
with
82 (* For the #include <linux/...> in the .cocci, need to find where is
83 * the '+' attached to this element, to later find the first concrete
84 * #include <linux/xxx.h> or last one in the series of #includes in the
87 type include_requirement
=
94 (* todo? put in semantic_c.ml *)
97 | LocalFunction
(* entails Function *)
101 let term mc
= A.unwrap_mcode mc
102 let mcodekind mc
= A.get_mcodekind mc
105 let mcode_contain_plus = function
106 | A.CONTEXT
(_
,A.NOTHING
) -> false
107 | A.CONTEXT _
-> true
108 | A.MINUS
(_
,_
,_
,A.NOREPLACEMENT
) -> false
109 | A.MINUS
(_
,_
,_
,A.REPLACEMENT _
) -> true (* repl is nonempty *)
110 | A.PLUS _
-> raise Impossible
112 let mcode_simple_minus = function
113 | A.MINUS
(_
,_
,_
,A.NOREPLACEMENT
) -> true
117 (* In transformation.ml sometime I build some mcodekind myself and
118 * julia has put None for the pos. But there is no possible raise
119 * NoMatch in those cases because it is for the minusall trick or for
120 * the distribute, so either have to build those pos, in fact a range,
121 * because for the distribute have to erase a fullType with one
122 * mcodekind, or add an argument to tag_with_mck such as "safe" that
123 * don't do the check_pos. Hence this DontCarePos constructor. *)
127 {A.line
= 0; A.column
=0; A.strbef
=[]; A.straft
=[];},
128 (A.MINUS
(A.DontCarePos
,[],A.ALLMINUS
,A.NOREPLACEMENT
)),
131 let generalize_mcode ia
=
132 let (s1
, i
, mck
, pos
) = ia
in
135 | A.PLUS _
-> raise Impossible
136 | A.CONTEXT
(A.NoPos
,x
) ->
137 A.CONTEXT
(A.DontCarePos
,x
)
138 | A.MINUS
(A.NoPos
,inst
,adj
,x
) ->
139 A.MINUS
(A.DontCarePos
,inst
,adj
,x
)
141 | A.CONTEXT
((A.FixPos _
|A.DontCarePos
), _
)
142 | A.MINUS
((A.FixPos _
|A.DontCarePos
), _
, _
, _
)
146 (s1
, i
, new_mck, pos
)
150 (*---------------------------------------------------------------------------*)
152 (* 0x0 is equivalent to 0, value format isomorphism *)
153 let equal_c_int s1 s2
=
155 int_of_string s1
=|= int_of_string s2
156 with Failure
("int_of_string") ->
161 (*---------------------------------------------------------------------------*)
162 (* Normally A should reuse some types of Ast_c, so those
163 * functions should not exist.
165 * update: but now Ast_c depends on A, so can't make too
166 * A depends on Ast_c, so have to stay with those equal_xxx
170 let equal_unaryOp a b
=
172 | A.GetRef
, B.GetRef
-> true
173 | A.GetRefLabel
, B.GetRefLabel
-> true
174 | A.DeRef
, B.DeRef
-> true
175 | A.UnPlus
, B.UnPlus
-> true
176 | A.UnMinus
, B.UnMinus
-> true
177 | A.Tilde
, B.Tilde
-> true
178 | A.Not
, B.Not
-> true
179 | _
, (B.Not
|B.Tilde
|B.UnMinus
|B.UnPlus
|B.DeRef
|B.GetRef
|B.GetRefLabel
) ->
184 let equal_arithOp a b
=
186 | A.Plus
, B.Plus
-> true
187 | A.Minus
, B.Minus
-> true
188 | A.Mul
, B.Mul
-> true
189 | A.Div
, B.Div
-> true
190 | A.Mod
, B.Mod
-> true
191 | A.DecLeft
, B.DecLeft
-> true
192 | A.DecRight
, B.DecRight
-> true
193 | A.And
, B.And
-> true
194 | A.Or
, B.Or
-> true
195 | A.Xor
, B.Xor
-> true
196 | _
, (B.Xor
|B.Or
|B.And
|B.DecRight
|B.DecLeft
|B.Mod
|B.Div
|B.Mul
|B.Minus
|B.Plus
)
199 let equal_logicalOp a b
=
201 | A.Inf
, B.Inf
-> true
202 | A.Sup
, B.Sup
-> true
203 | A.InfEq
, B.InfEq
-> true
204 | A.SupEq
, B.SupEq
-> true
205 | A.Eq
, B.Eq
-> true
206 | A.NotEq
, B.NotEq
-> true
207 | A.AndLog
, B.AndLog
-> true
208 | A.OrLog
, B.OrLog
-> true
209 | _
, (B.OrLog
|B.AndLog
|B.NotEq
|B.Eq
|B.SupEq
|B.InfEq
|B.Sup
|B.Inf
)
212 let equal_assignOp a b
=
214 | A.SimpleAssign
, B.SimpleAssign
-> true
215 | A.OpAssign a
, B.OpAssign b
-> equal_arithOp a b
216 | _
, (B.OpAssign _
|B.SimpleAssign
) -> false
218 let equal_fixOp a b
=
220 | A.Dec
, B.Dec
-> true
221 | A.Inc
, B.Inc
-> true
222 | _
, (B.Inc
|B.Dec
) -> false
224 let equal_binaryOp a b
=
226 | A.Arith a
, B.Arith b
-> equal_arithOp a b
227 | A.Logical a
, B.Logical b
-> equal_logicalOp a b
228 | _
, (B.Logical _
| B.Arith _
) -> false
230 let equal_structUnion a b
=
232 | A.Struct
, B.Struct
-> true
233 | A.Union
, B.Union
-> true
234 | _
, (B.Struct
|B.Union
) -> false
238 | A.Signed
, B.Signed
-> true
239 | A.Unsigned
, B.UnSigned
-> true
240 | _
, (B.UnSigned
|B.Signed
) -> false
242 let equal_storage a b
=
244 | A.Static
, B.Sto
B.Static
245 | A.Auto
, B.Sto
B.Auto
246 | A.Register
, B.Sto
B.Register
247 | A.Extern
, B.Sto
B.Extern
249 | _
, (B.NoSto
| B.StoTypedef
) -> false
250 | _
, (B.Sto
(B.Register
|B.Static
|B.Auto
|B.Extern
)) -> false
253 (*---------------------------------------------------------------------------*)
255 let equal_metavarval valu valu'
=
256 match valu
, valu'
with
257 | Ast_c.MetaIdVal
(a
,_
), Ast_c.MetaIdVal
(b
,_
) -> a
=$
= b
258 | Ast_c.MetaFuncVal a
, Ast_c.MetaFuncVal b
-> a
=$
= b
259 | Ast_c.MetaLocalFuncVal a
, Ast_c.MetaLocalFuncVal b
->
260 (* do something more ? *)
263 (* al_expr before comparing !!! and accept when they match.
264 * Note that here we have Astc._expression, so it is a match
265 * modulo isomorphism (there is no metavariable involved here,
266 * just isomorphisms). => TODO call isomorphism_c_c instead of
267 * =*=. Maybe would be easier to transform ast_c in ast_cocci
268 * and call the iso engine of julia. *)
269 | Ast_c.MetaExprVal
(a
,_
), Ast_c.MetaExprVal
(b
,_
) ->
270 Lib_parsing_c.al_expr a
=*= Lib_parsing_c.al_expr b
271 | Ast_c.MetaExprListVal a
, Ast_c.MetaExprListVal b
->
272 Lib_parsing_c.al_arguments a
=*= Lib_parsing_c.al_arguments b
274 | Ast_c.MetaDeclVal a
, Ast_c.MetaDeclVal b
->
275 Lib_parsing_c.al_declaration a
=*= Lib_parsing_c.al_declaration b
276 | Ast_c.MetaFieldVal a
, Ast_c.MetaFieldVal b
->
277 Lib_parsing_c.al_field a
=*= Lib_parsing_c.al_field b
278 | Ast_c.MetaFieldListVal a
, Ast_c.MetaFieldListVal b
->
279 Lib_parsing_c.al_fields a
=*= Lib_parsing_c.al_fields b
280 | Ast_c.MetaStmtVal a
, Ast_c.MetaStmtVal b
->
281 Lib_parsing_c.al_statement a
=*= Lib_parsing_c.al_statement b
282 | Ast_c.MetaInitVal a
, Ast_c.MetaInitVal b
->
283 Lib_parsing_c.al_init a
=*= Lib_parsing_c.al_init b
284 | Ast_c.MetaInitListVal a
, Ast_c.MetaInitListVal b
->
285 Lib_parsing_c.al_inits a
=*= Lib_parsing_c.al_inits b
286 | Ast_c.MetaTypeVal a
, Ast_c.MetaTypeVal b
->
287 (* old: Lib_parsing_c.al_type a =*= Lib_parsing_c.al_type b *)
290 | Ast_c.MetaListlenVal a
, Ast_c.MetaListlenVal b
-> a
=|= b
292 | Ast_c.MetaParamVal a
, Ast_c.MetaParamVal b
->
293 Lib_parsing_c.al_param a
=*= Lib_parsing_c.al_param b
294 | Ast_c.MetaParamListVal a
, Ast_c.MetaParamListVal b
->
295 Lib_parsing_c.al_params a
=*= Lib_parsing_c.al_params b
297 | Ast_c.MetaPosVal
(posa1
,posa2
), Ast_c.MetaPosVal
(posb1
,posb2
) ->
298 Ast_cocci.equal_pos posa1 posb1
&& Ast_cocci.equal_pos posa2 posb2
300 | Ast_c.MetaPosValList l1
, Ast_c.MetaPosValList l2
->
302 (function (fla
,cea
,posa1
,posa2
) ->
304 (function (flb
,ceb
,posb1
,posb2
) ->
305 fla
=$
= flb
&& cea
=$
= ceb
&&
306 Ast_c.equal_posl posa1 posb1
&& Ast_c.equal_posl posa2 posb2
)
310 | (B.MetaPosValList _
|B.MetaListlenVal _
|B.MetaPosVal _
|B.MetaStmtVal _
311 |B.MetaDeclVal _
|B.MetaFieldVal _
|B.MetaFieldListVal _
312 |B.MetaTypeVal _
|B.MetaInitVal _
|B.MetaInitListVal _
313 |B.MetaParamListVal _
|B.MetaParamVal _
|B.MetaExprListVal _
314 |B.MetaExprVal _
|B.MetaLocalFuncVal _
|B.MetaFuncVal _
|B.MetaIdVal _
318 (* probably only one argument needs to be stripped, because inherited
319 metavariables containing expressions are stripped in advance. But don't
320 know which one is which... *)
321 let equal_inh_metavarval valu valu'
=
322 match valu
, valu'
with
323 | Ast_c.MetaIdVal
(a
,_
), Ast_c.MetaIdVal
(b
,_
) -> a
=$
= b
324 | Ast_c.MetaFuncVal a
, Ast_c.MetaFuncVal b
-> a
=$
= b
325 | Ast_c.MetaLocalFuncVal a
, Ast_c.MetaLocalFuncVal b
->
326 (* do something more ? *)
329 (* al_expr before comparing !!! and accept when they match.
330 * Note that here we have Astc._expression, so it is a match
331 * modulo isomorphism (there is no metavariable involved here,
332 * just isomorphisms). => TODO call isomorphism_c_c instead of
333 * =*=. Maybe would be easier to transform ast_c in ast_cocci
334 * and call the iso engine of julia. *)
335 | Ast_c.MetaExprVal
(a
,_
), Ast_c.MetaExprVal
(b
,_
) ->
336 Lib_parsing_c.al_inh_expr a
=*= Lib_parsing_c.al_inh_expr b
337 | Ast_c.MetaExprListVal a
, Ast_c.MetaExprListVal b
->
338 Lib_parsing_c.al_inh_arguments a
=*= Lib_parsing_c.al_inh_arguments b
340 | Ast_c.MetaDeclVal a
, Ast_c.MetaDeclVal b
->
341 Lib_parsing_c.al_inh_declaration a
=*= Lib_parsing_c.al_inh_declaration b
342 | Ast_c.MetaFieldVal a
, Ast_c.MetaFieldVal b
->
343 Lib_parsing_c.al_inh_field a
=*= Lib_parsing_c.al_inh_field b
344 | Ast_c.MetaFieldListVal a
, Ast_c.MetaFieldListVal b
->
345 Lib_parsing_c.al_inh_field_list a
=*= Lib_parsing_c.al_inh_field_list b
346 | Ast_c.MetaStmtVal a
, Ast_c.MetaStmtVal b
->
347 Lib_parsing_c.al_inh_statement a
=*= Lib_parsing_c.al_inh_statement b
348 | Ast_c.MetaInitVal a
, Ast_c.MetaInitVal b
->
349 Lib_parsing_c.al_inh_init a
=*= Lib_parsing_c.al_inh_init b
350 | Ast_c.MetaInitListVal a
, Ast_c.MetaInitListVal b
->
351 Lib_parsing_c.al_inh_inits a
=*= Lib_parsing_c.al_inh_inits b
352 | Ast_c.MetaTypeVal a
, Ast_c.MetaTypeVal b
->
353 (* old: Lib_parsing_c.al_inh_type a =*= Lib_parsing_c.al_inh_type b *)
356 | Ast_c.MetaListlenVal a
, Ast_c.MetaListlenVal b
-> a
=|= b
358 | Ast_c.MetaParamVal a
, Ast_c.MetaParamVal b
->
359 Lib_parsing_c.al_param a
=*= Lib_parsing_c.al_param b
360 | Ast_c.MetaParamListVal a
, Ast_c.MetaParamListVal b
->
361 Lib_parsing_c.al_params a
=*= Lib_parsing_c.al_params b
363 | Ast_c.MetaPosVal
(posa1
,posa2
), Ast_c.MetaPosVal
(posb1
,posb2
) ->
364 Ast_cocci.equal_pos posa1 posb1
&& Ast_cocci.equal_pos posa2 posb2
366 | Ast_c.MetaPosValList l1
, Ast_c.MetaPosValList l2
->
368 (function (fla
,cea
,posa1
,posa2
) ->
370 (function (flb
,ceb
,posb1
,posb2
) ->
371 fla
=$
= flb
&& cea
=$
= ceb
&&
372 Ast_c.equal_posl posa1 posb1
&& Ast_c.equal_posl posa2 posb2
)
376 | (B.MetaPosValList _
|B.MetaListlenVal _
|B.MetaPosVal _
|B.MetaStmtVal _
377 |B.MetaDeclVal _
|B.MetaFieldVal _
|B.MetaFieldListVal _
378 |B.MetaTypeVal _
|B.MetaInitVal _
|B.MetaInitListVal _
379 |B.MetaParamListVal _
|B.MetaParamVal _
|B.MetaExprListVal _
380 |B.MetaExprVal _
|B.MetaLocalFuncVal _
|B.MetaFuncVal _
|B.MetaIdVal _
385 (*---------------------------------------------------------------------------*)
386 (* could put in ast_c.ml, next to the split/unsplit_comma *)
387 let split_signb_baseb_ii (baseb
, ii
) =
388 let iis = ii
+> List.map
(fun info
-> (B.str_of_info info
), info
) in
389 match baseb
, iis with
391 | B.Void
, ["void",i1
] -> None
, [i1
]
393 | B.FloatType
(B.CFloat
),["float",i1
] -> None
, [i1
]
394 | B.FloatType
(B.CDouble
),["double",i1
] -> None
, [i1
]
395 | B.FloatType
(B.CLongDouble
),["long",i1
;"double",i2
] -> None
,[i1
;i2
]
397 | B.IntType
(B.CChar
), ["char",i1
] -> None
, [i1
]
400 | B.IntType
(B.Si
(sign
, base
)), xs
->
404 | (B.Signed
,(("signed",i1
)::rest
)) -> (Some
(B.Signed
,i1
),rest
)
405 | (B.Signed
,rest
) -> (None
,rest
)
406 | (B.UnSigned
,(("unsigned",i1
)::rest
)) -> (Some
(B.UnSigned
,i1
),rest
)
407 | (B.UnSigned
,rest
) -> (* is this case possible? *) (None
,rest
) in
408 (* The original code only allowed explicit signed and unsigned for char,
409 while this code allows char by itself. Not sure that needs to be
410 checked for here. If it does, then add a special case. *)
412 match (base
,rest
) with
413 B.CInt
, ["int",i1
] -> [i1
]
416 | B.CInt
, ["",i1
] -> (* no type is specified at all *)
417 (match i1
.B.pinfo
with
419 | _
-> error [i1
] ("unrecognized signed int: "^
420 (String.concat
" "(List.map fst
iis))))
422 | B.CChar2
, ["char",i2
] -> [i2
]
424 | B.CShort
, ["short",i1
] -> [i1
]
425 | B.CShort
, ["short",i1
;"int",i2
] -> [i1
;i2
]
427 | B.CLong
, ["long",i1
] -> [i1
]
428 | B.CLong
, ["long",i1
;"int",i2
] -> [i1
;i2
]
430 | B.CLongLong
, ["long",i1
;"long",i2
] -> [i1
;i2
]
431 | B.CLongLong
, ["long",i1
;"long",i2
;"int",i3
] -> [i1
;i2
;i3
]
434 error (List.map snd
iis)
435 ("strange type1, maybe because of weird order: "^
436 (String.concat
" " (List.map fst
iis))) in
439 | B.SizeType
, ["size_t",i1
] -> None
, [i1
]
440 | B.SSizeType
, ["ssize_t",i1
] -> None
, [i1
]
441 | B.PtrDiffType
, ["ptrdiff_t",i1
] -> None
, [i1
]
444 error (List.map snd
iis)
445 ("strange type2, maybe because of weird order: "^
446 (String.concat
" " (List.map fst
iis)))
448 (*---------------------------------------------------------------------------*)
450 let rec unsplit_icomma xs
=
454 (match A.unwrap y
with
456 (x
, y
)::unsplit_icomma xs
457 | _
-> failwith
"wrong ast_cocci in initializer"
460 failwith
("wrong ast_cocci in initializer, should have pair " ^
465 let resplit_initialiser ibs iicomma
=
466 match iicomma
, ibs
with
469 failwith
"should have a iicomma, do you generate fakeInfo in parser?"
471 error iicommas
"shouldn't have a iicomma"
472 | [iicomma
], x
::xs
->
473 let elems = List.map fst
(x
::xs
) in
474 let commas = List.map snd
(x
::xs
) +> List.flatten
in
475 let commas = commas @ [iicomma
] in
477 | _
-> raise Impossible
481 let rec split_icomma xs
=
484 | (x
,y
)::xs
-> x
::y
::split_icomma xs
486 let rec unsplit_initialiser ibs_unsplit
=
487 match ibs_unsplit
with
488 | [] -> [], [] (* empty iicomma *)
490 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
491 (x
, [])::xs
, lastcomma
493 and unsplit_initialiser_bis comma_before
= function
494 | [] -> [], [comma_before
]
496 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
497 (x
, [comma_before
])::xs
, lastcomma
502 (*---------------------------------------------------------------------------*)
503 (* coupling: same in type_annotater_c.ml *)
504 let structdef_to_struct_name ty
=
506 | qu
, (B.StructUnion
(su
, sopt
, fields
), iis) ->
508 | Some s
, [i1
;i2
;i3
;i4
] ->
509 qu
, (B.StructUnionName
(su
, s
), [i1
;i2
])
513 | x
-> raise Impossible
515 | _
-> raise Impossible
517 (*---------------------------------------------------------------------------*)
518 let one_initialisation_to_affectation x
=
519 let ({B.v_namei
= var
;
520 B.v_type
= returnType
;
521 B.v_type_bis
= tybis
;
522 B.v_storage
= storage
;
526 | Some
(name
, iniopt
) ->
528 | B.ValInit
(iini
, (B.InitExpr e
, ii_empty2
)) ->
531 Ast_c.NotLocalDecl
-> Ast_c.NotLocalVar
533 Ast_c.LocalVar
(Ast_c.info_of_type returnType
) in
535 (* old: Lib_parsing_c.al_type returnType
536 * but this type has not the typename completed so
537 * instead try to use tybis
540 | Some ty_with_typename_completed
-> ty_with_typename_completed
541 | None
-> raise Impossible
544 let typ = ref (Some
(typexp,local), Ast_c.NotTest
) in
546 let idexpr = Ast_c.mk_e_bis
(B.Ident
ident) typ Ast_c.noii
in
548 Ast_c.mk_e
(B.Assignment
(idexpr,B.SimpleAssign
, e
)) [iini
] in
553 let initialisation_to_affectation decl
=
555 | B.MacroDecl _
-> F.Decl decl
556 | B.DeclList
(xs
, iis) ->
558 (* todo?: should not do that if the variable is an array cos
559 * will have x[] = , mais de toute facon ca sera pas un InitExp
561 let possible_assignment =
565 match prev
,one_initialisation_to_affectation x
with
567 | None
,Some x
-> Some x
568 | Some prev
,Some x
->
569 (* [] is clearly an invalid ii value for a sequence.
570 hope that no one looks at it, since nothing will
571 match the sequence. Fortunately, SmPL doesn't
572 support , expressions. *)
573 Some
(Ast_c.mk_e
(Ast_c.Sequence
(prev
, x
)) []))
575 match possible_assignment with
576 Some x
-> F.DefineExpr x
577 | None
-> F.Decl decl
579 (*****************************************************************************)
580 (* Functor parameter combinators *)
581 (*****************************************************************************)
583 * src: papers on parser combinators in haskell (cf a pearl by meijer in ICFP)
585 * version0: was not tagging the SP, so just tag the C
587 * (tin -> 'c tout) -> ('c -> (tin -> 'b tout)) -> (tin -> 'b tout)
588 * val return : 'b -> tin -> 'b tout
589 * val fail : tin -> 'b tout
591 * version1: now also tag the SP so return a ('a * 'b)
594 type mode
= PatternMode
| TransformMode
602 type ('a
, 'b
) matcher
= 'a
-> 'b
-> tin
-> ('a
* 'b
) tout
607 (tin
-> ('a
* 'b
) tout
) ->
608 ('a
-> 'b
-> (tin
-> ('c
* 'd
) tout
)) ->
609 (tin
-> ('c
* 'd
) tout
)
611 val return
: ('a
* 'b
) -> tin
-> ('a
*'b
) tout
612 val fail
: tin
-> ('a
* 'b
) tout
624 val (>&&>) : (tin
-> bool) -> (tin
-> 'x tout
) -> (tin
-> 'x tout
)
626 val tokenf
: ('a
A.mcode
, B.info
) matcher
627 val tokenf_mck
: (A.mcodekind, B.info
) matcher
630 (A.meta_name
A.mcode
, B.expression
) matcher
632 (A.meta_name
A.mcode
, (Ast_c.argument
, Ast_c.il
) either list
) matcher
634 (A.meta_name
A.mcode
, Ast_c.fullType
) matcher
636 (A.meta_name
A.mcode
,
637 (Ast_c.parameterType
, Ast_c.il
) either list
) matcher
639 (A.meta_name
A.mcode
, Ast_c.parameterType
) matcher
641 (A.meta_name
A.mcode
, Ast_c.initialiser
) matcher
643 (A.meta_name
A.mcode
, (Ast_c.initialiser
, Ast_c.il
) either list
) matcher
645 (A.meta_name
A.mcode
, Ast_c.declaration
) matcher
647 (A.meta_name
A.mcode
, Ast_c.field
) matcher
649 (A.meta_name
A.mcode
, Control_flow_c.node
) matcher
651 val distrf_define_params
:
652 (A.meta_name
A.mcode
, (string Ast_c.wrap
, Ast_c.il
) either list
) matcher
654 val distrf_enum_fields
:
655 (A.meta_name
A.mcode
, (B.oneEnumType
, B.il
) either list
) matcher
657 val distrf_struct_fields
:
658 (A.meta_name
A.mcode
, B.field list
) matcher
661 (A.meta_name
A.mcode
, (B.constant
, string) either
B.wrap
) matcher
664 (A.expression
, B.expression
) matcher
-> (A.expression
, F.node
) matcher
667 (A.expression
, B.expression
) matcher
->
668 (A.expression
, B.expression
) matcher
671 (A.fullType
, B.fullType
) matcher
-> (A.fullType
, F.node
) matcher
674 (A.initialiser
, B.initialiser
) matcher
-> (A.initialiser
, F.node
) matcher
677 A.keep_binding
-> A.inherited
->
678 A.meta_name
A.mcode
* Ast_c.metavar_binding_kind
*
679 (unit -> Common.filename
* string * Ast_c.posl
* Ast_c.posl
) ->
680 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
682 val check_idconstraint
:
683 ('a
-> 'b
-> bool) -> 'a
-> 'b
->
684 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
686 val check_constraints_ne
:
687 ('a
, 'b
) matcher
-> 'a list
-> 'b
->
688 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
690 val all_bound
: A.meta_name list
-> (tin
-> bool)
692 val optional_storage_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
693 val optional_qualifier_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
694 val value_format_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
698 (*****************************************************************************)
699 (* Functor code, "Cocci vs C" *)
700 (*****************************************************************************)
703 functor (X
: PARAM
) ->
706 type ('a
, 'b
) matcher
= 'a
-> 'b
-> X.tin
-> ('a
* 'b
) X.tout
709 let return = X.return
712 let (>||>) = X.(>||>)
713 let (>|+|>) = X.(>|+|>)
714 let (>&&>) = X.(>&&>)
716 let tokenf = X.tokenf
718 (* should be raise Impossible when called from transformation.ml *)
721 | PatternMode
-> fail
722 | TransformMode
-> raise Impossible
725 let (option: ('a
,'b
) matcher
-> ('a
option,'b
option) matcher
)= fun f t1 t2
->
727 | (Some t1
, Some t2
) ->
728 f t1 t2
>>= (fun t1 t2
->
729 return (Some t1
, Some t2
)
731 | (None
, None
) -> return (None
, None
)
734 (* Dots are sometimes used as metavariables, since like metavariables they
735 can match other things. But they no longer have the same type. Perhaps these
736 functions could be avoided by introducing an appropriate level of polymorphism,
737 but I don't know how to declare polymorphism across functors *)
738 let dots2metavar (_
,info
,mcodekind,pos
) =
739 (("","..."),info
,mcodekind,pos
)
740 let metavar2dots (_
,info
,mcodekind,pos
) = ("...",info
,mcodekind,pos
)
741 let metavar2ndots (_
,info
,mcodekind,pos
) = ("<+...",info
,mcodekind,pos
)
743 let satisfies_regexpconstraint c id
: bool =
745 A.IdRegExp
(_
,recompiled
) -> Str.string_match recompiled id
0
746 | A.IdNotRegExp
(_
,recompiled
) -> not
(Str.string_match recompiled id
0)
748 let satisfies_iconstraint c id
: bool =
751 let satisfies_econstraint c exp
: bool =
752 let warning s
= pr2_once
("WARNING: "^s
); false in
753 match Ast_c.unwrap_expr exp
with
754 Ast_c.Ident
(name
) ->
756 Ast_c.RegularName rname
->
757 satisfies_regexpconstraint c
(Ast_c.unwrap_st rname
)
758 | Ast_c.CppConcatenatedName _
->
760 "Unable to apply a constraint on a CppConcatenatedName identifier!"
761 | Ast_c.CppVariadicName _
->
763 "Unable to apply a constraint on a CppVariadicName identifier!"
764 | Ast_c.CppIdentBuilder _
->
766 "Unable to apply a constraint on a CppIdentBuilder identifier!")
767 | Ast_c.Constant cst
->
769 | Ast_c.String
(str
, _
) -> satisfies_regexpconstraint c str
770 | Ast_c.MultiString strlist
->
771 warning "Unable to apply a constraint on an multistring constant!"
772 | Ast_c.Char
(char
, _
) -> satisfies_regexpconstraint c char
773 | Ast_c.Int
(int , _
) -> satisfies_regexpconstraint c
int
774 | Ast_c.Float
(float, _
) -> satisfies_regexpconstraint c
float)
775 | _
-> warning "Unable to apply a constraint on an expression!"
778 (* ------------------------------------------------------------------------- *)
779 (* This has to be up here to allow adequate polymorphism *)
781 let list_matcher match_dots rebuild_dots match_comma rebuild_comma
782 match_metalist rebuild_metalist mktermval special_cases
783 element distrf get_iis
= fun eas ebs
->
784 let rec loop = function
785 [], [] -> return ([], [])
786 | [], eb
::ebs
-> fail
788 X.all_bound
(A.get_inherited ea
) >&&>
790 (match match_dots ea
, ebs
with
791 Some
(mcode
, optexpr
), ys
->
792 (* todo: if optexpr, then a WHEN and so may have to filter yys *)
793 if optexpr
<> None
then failwith
"not handling when in a list";
795 (* '...' can take more or less the beginnings of the arguments *)
797 Common.zip
(Common.inits ys
) (Common.tails ys
) in
799 (startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
802 (* allow '...', and maybe its associated ',' to match nothing.
803 * for the associated ',' see below how we handle the EComma
808 if mcode_contain_plus (mcodekind mcode
)
811 "I have no token that I could accroche myself on"*)
812 else return (dots2metavar mcode
, [])
814 (* subtil: we dont want the '...' to match until the
815 * comma. cf -test pb_params_iso. We would get at
816 * "already tagged" error.
817 * this is because both f (... x, ...) and f (..., x, ...)
818 * would match a f(x,3) with our "optional-comma" strategy.
820 (match Common.last startxs
with
822 | Left _
-> distrf
(dots2metavar mcode
) startxs
))
824 >>= (fun mcode startxs
->
825 let mcode = metavar2dots mcode in
826 loop (eas
, endxs
) >>= (fun eas endxs
->
828 (rebuild_dots
(mcode, optexpr
) +> A.rewrap ea
) ::eas
,
836 (match match_comma ea
, ebs
with
837 | Some ia1
, Right ii
::ebs
->
839 (let ib1 = tuple_of_list1 ii
in
840 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
841 loop (eas
, ebs
) >>= (fun eas ebs
->
843 (rebuild_comma ia1
+> A.rewrap ea
)::eas
,
848 (* allow ',' to maching nothing. optional comma trick *)
850 (if mcode_contain_plus (mcodekind ia1
)
852 else loop (eas
, ebs
))
855 (match match_metalist ea
, ebs
with
856 Some
(ida
,leninfo
,keep
,inherited
), ys
->
858 Common.zip
(Common.inits ys
) (Common.tails ys
) in
860 (startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
865 if mcode_contain_plus (mcodekind ida
)
867 (* failwith "no token that I could accroche myself on" *)
870 (match Common.last startxs
with
877 let startxs'
= Ast_c.unsplit_comma
startxs in
878 let len = List.length
startxs'
in
881 | A.MetaListLen
(lenname
,lenkeep
,leninherited
) ->
882 let max_min _
= failwith
"no pos" in
883 X.envf lenkeep leninherited
884 (lenname
, Ast_c.MetaListlenVal
(len), max_min)
887 then (function f
-> f
())
888 else (function f
-> fail)
889 | A.AnyListLen
-> function f
-> f
())
892 Lib_parsing_c.lin_col_by_pos
(get_iis
startxs) in
893 X.envf keep inherited
894 (ida
, mktermval
startxs'
, max_min)
897 then return (ida
, [])
898 else distrf ida
(Ast_c.split_comma
startxs'
))
899 >>= (fun ida
startxs ->
900 loop (eas
, endxs
) >>= (fun eas endxs
->
902 (rebuild_metalist
(ida
,leninfo
,keep
,inherited
))
911 special_cases ea eas ebs
in
912 match try_matches with
917 element ea eb
>>= (fun ea eb
->
918 loop (eas
, ebs
) >>= (fun eas ebs
->
919 return (ea
::eas
, Left eb
::ebs
)))
920 | (Right y
)::ys
-> raise Impossible
924 (*---------------------------------------------------------------------------*)
936 (*---------------------------------------------------------------------------*)
937 let rec (expression
: (A.expression
, Ast_c.expression
) matcher
) =
939 if A.get_test_exp ea
&& not
(Ast_c.is_test eb
) then fail
941 X.all_bound
(A.get_inherited ea
) >&&>
942 let wa x
= A.rewrap ea x
in
943 match A.unwrap ea
, eb
with
945 (* general case: a MetaExpr can match everything *)
946 | A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
),
947 (((expr
, opttypb
), ii
) as expb
) ->
949 (* old: before have a MetaConst. Now we factorize and use 'form' to
950 * differentiate between different cases *)
951 let rec matches_id = function
952 B.Ident
(name
) -> true
953 | B.Cast
(ty
,e
) -> matches_id (B.unwrap_expr e
)
956 match (form
,expr
) with
959 let rec matches = function
960 B.Constant
(c
) -> true
961 | B.Ident
(nameidb
) ->
962 let s = Ast_c.str_of_name nameidb
in
963 if s =~
"^[A-Z_][A-Z_0-9]*$"
965 pr2_once
("warning: " ^
s ^
" treated as a constant");
969 | B.Cast
(ty
,e
) -> matches (B.unwrap_expr e
)
970 | B.Unary
(e
,B.UnMinus
) -> matches (B.unwrap_expr e
)
971 | B.SizeOfExpr
(exp
) -> true
972 | B.SizeOfType
(ty
) -> true
978 (Some
(_
,Ast_c.LocalVar _
),_
) -> true
980 | (A.ID
,e
) -> matches_id e
in
984 (let (opttypb
,_testb
) = !opttypb
in
985 match opttypa
, opttypb
with
986 | None
, _
-> return ((),())
988 pr2_once
("Missing type information. Certainly a pb in " ^
989 "annotate_typer.ml");
992 | Some tas
, Some tb
->
993 tas
+> List.fold_left
(fun acc ta
->
994 acc
>|+|> compatible_type ta tb
) fail
997 let meta_expr_val l x
= Ast_c.MetaExprVal
(x
,l
) in
998 match constraints
with
999 Ast_cocci.NoConstraint
-> return (meta_expr_val [],())
1000 | Ast_cocci.NotIdCstrt cstrt
->
1001 X.check_idconstraint
satisfies_econstraint cstrt eb
1002 (fun () -> return (meta_expr_val [],()))
1003 | Ast_cocci.NotExpCstrt cstrts
->
1004 X.check_constraints_ne expression cstrts eb
1005 (fun () -> return (meta_expr_val [],()))
1006 | Ast_cocci.SubExpCstrt cstrts
->
1007 return (meta_expr_val cstrts
,()))
1011 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_expr expb
) in
1012 X.envf keep inherited
(ida
, wrapper expb
, max_min)
1014 X.distrf_e ida expb
>>=
1017 A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
)+>
1025 * | A.MetaExpr(ida,false,opttypa,_inherited), expb ->
1026 * D.distribute_mck (mcodekind ida) D.distribute_mck_e expb binding
1028 * but bug! because if have not tagged SP, then transform without doing
1029 * any checks. Hopefully now have tagged SP technique.
1034 * | A.Edots _, _ -> raise Impossible.
1036 * In fact now can also have the Edots inside normal expression, not
1037 * just in arg lists. in 'x[...];' less: in if(<... x ... y ...>)
1039 | A.Edots
(mcode, None
), expb
->
1040 X.distrf_e
(dots2metavar mcode) expb
>>= (fun mcode expb
->
1042 A.Edots
(metavar2dots mcode, None
) +> A.rewrap ea
,
1047 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
1050 | A.Ident ida
, ((B.Ident
(nameidb
), typ),noii
) ->
1052 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1054 ((A.Ident ida
)) +> wa,
1055 ((B.Ident
(nameidb
), typ),Ast_c.noii
)
1061 | A.MetaErr _
, _
-> failwith
"not handling MetaErr"
1063 (* todo?: handle some isomorphisms in int/float ? can have different
1064 * format : 1l can match a 1.
1066 * todo: normally string can contain some metavar too, so should
1067 * recurse on the string
1069 | A.Constant
(ia1
), ((B.Constant
(ib
) , typ),ii
) ->
1070 (* for everything except the String case where can have multi elems *)
1072 let ib1 = tuple_of_list1 ii
in
1073 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1075 ((A.Constant ia1
)) +> wa,
1076 ((B.Constant
(ib
), typ),[ib1])
1079 (match term ia1
, ib
with
1080 | A.Int x
, B.Int
(y
,_
) ->
1081 X.value_format_flag
(fun use_value_equivalence
->
1082 if use_value_equivalence
1092 | A.Char x
, B.Char
(y
,_
) when x
=$
= y
(* todo: use kind ? *)
1094 | A.Float x
, B.Float
(y
,_
) when x
=$
= y
(* todo: use floatType ? *)
1097 | A.String sa
, B.String
(sb
,_kind
) when sa
=$
= sb
->
1100 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1102 ((A.Constant ia1
)) +> wa,
1103 ((B.Constant
(ib
), typ),[ib1])
1105 | _
-> fail (* multi string, not handled *)
1108 | _
, B.MultiString _
-> (* todo cocci? *) fail
1109 | _
, (B.String _
| B.Float _
| B.Char _
| B.Int _
) -> fail
1113 | A.FunCall
(ea
, ia1
, eas
, ia2
), ((B.FunCall
(eb
, ebs
), typ),ii
) ->
1114 (* todo: do special case to allow IdMetaFunc, cos doing the
1115 * recursive call will be too late, match_ident will not have the
1116 * info whether it was a function. todo: but how detect when do
1117 * x.field = f; how know that f is a Func ? By having computed
1118 * some information before the matching!
1120 * Allow match with FunCall containing types. Now ast_cocci allow
1121 * type in parameter, and morover ast_cocci allow f(...) and those
1122 * ... could match type.
1124 let (ib1, ib2
) = tuple_of_list2 ii
in
1125 expression ea eb
>>= (fun ea eb
->
1126 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1127 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1128 arguments
(seqstyle eas
) (A.undots eas
) ebs
>>= (fun easundots ebs
->
1129 let eas = redots
eas easundots
in
1131 ((A.FunCall
(ea
, ia1
, eas, ia2
)) +> wa,
1132 ((B.FunCall
(eb
, ebs
),typ), [ib1;ib2
])
1138 | A.Assignment
(ea1
, opa
, ea2
, simple
),
1139 ((B.Assignment
(eb1
, opb
, eb2
), typ),ii
) ->
1140 let (opbi
) = tuple_of_list1 ii
in
1141 if equal_assignOp (term opa
) opb
1143 expression ea1 eb1
>>= (fun ea1 eb1
->
1144 expression ea2 eb2
>>= (fun ea2 eb2
->
1145 tokenf opa opbi
>>= (fun opa opbi
->
1147 (A.Assignment
(ea1
, opa
, ea2
, simple
)) +> wa,
1148 ((B.Assignment
(eb1
, opb
, eb2
), typ), [opbi
])
1152 | A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
),((B.CondExpr
(eb1
,eb2opt
,eb3
),typ),ii
) ->
1153 let (ib1, ib2
) = tuple_of_list2 ii
in
1154 expression ea1 eb1
>>= (fun ea1 eb1
->
1155 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
1156 expression ea3 eb3
>>= (fun ea3 eb3
->
1157 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1158 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1160 ((A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
))) +> wa,
1161 ((B.CondExpr
(eb1
, eb2opt
, eb3
),typ), [ib1;ib2
])
1164 (* todo?: handle some isomorphisms here ? *)
1165 | A.Postfix
(ea
, opa
), ((B.Postfix
(eb
, opb
), typ),ii
) ->
1166 let opbi = tuple_of_list1 ii
in
1167 if equal_fixOp (term opa
) opb
1169 expression ea eb
>>= (fun ea eb
->
1170 tokenf opa
opbi >>= (fun opa
opbi ->
1172 ((A.Postfix
(ea
, opa
))) +> wa,
1173 ((B.Postfix
(eb
, opb
), typ),[opbi])
1178 | A.Infix
(ea
, opa
), ((B.Infix
(eb
, opb
), typ),ii
) ->
1179 let opbi = tuple_of_list1 ii
in
1180 if equal_fixOp (term opa
) opb
1182 expression ea eb
>>= (fun ea eb
->
1183 tokenf opa
opbi >>= (fun opa
opbi ->
1185 ((A.Infix
(ea
, opa
))) +> wa,
1186 ((B.Infix
(eb
, opb
), typ),[opbi])
1190 | A.Unary
(ea
, opa
), ((B.Unary
(eb
, opb
), typ),ii
) ->
1191 let opbi = tuple_of_list1 ii
in
1192 if equal_unaryOp (term opa
) opb
1194 expression ea eb
>>= (fun ea eb
->
1195 tokenf opa
opbi >>= (fun opa
opbi ->
1197 ((A.Unary
(ea
, opa
))) +> wa,
1198 ((B.Unary
(eb
, opb
), typ),[opbi])
1202 | A.Binary
(ea1
, opa
, ea2
), ((B.Binary
(eb1
, opb
, eb2
), typ),ii
) ->
1203 let opbi = tuple_of_list1 ii
in
1204 if equal_binaryOp (term opa
) opb
1206 expression ea1 eb1
>>= (fun ea1 eb1
->
1207 expression ea2 eb2
>>= (fun ea2 eb2
->
1208 tokenf opa
opbi >>= (fun opa
opbi ->
1210 ((A.Binary
(ea1
, opa
, ea2
))) +> wa,
1211 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1215 | A.Nested
(ea1
, opa
, ea2
), eb
->
1217 expression ea1 eb
>|+|>
1219 ((B.Binary
(eb1
, opb
, eb2
), typ),ii
)
1220 when equal_binaryOp (term opa
) opb
->
1221 let opbi = tuple_of_list1 ii
in
1223 (expression ea1 eb1
>>= (fun ea1 eb1
->
1224 expression ea2 eb2
>>= (fun ea2 eb2
->
1225 tokenf opa
opbi >>= (fun opa
opbi ->
1227 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1228 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1231 (expression ea2 eb1
>>= (fun ea2 eb1
->
1232 expression ea1 eb2
>>= (fun ea1 eb2
->
1233 tokenf opa
opbi >>= (fun opa
opbi ->
1235 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1236 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1239 (loop eb1
>>= (fun ea1 eb1
->
1240 expression ea2 eb2
>>= (fun ea2 eb2
->
1241 tokenf opa
opbi >>= (fun opa
opbi ->
1243 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1244 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1247 (expression ea2 eb1
>>= (fun ea2 eb1
->
1248 loop eb2
>>= (fun ea1 eb2
->
1249 tokenf opa
opbi >>= (fun opa
opbi ->
1251 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1252 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1254 left_to_right >|+|> right_to_left >|+|> in_left >|+|> in_right
1258 (* todo?: handle some isomorphisms here ? (with pointers = Unary Deref) *)
1259 | A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
),((B.ArrayAccess
(eb1
, eb2
), typ),ii
) ->
1260 let (ib1, ib2
) = tuple_of_list2 ii
in
1261 expression ea1 eb1
>>= (fun ea1 eb1
->
1262 expression ea2 eb2
>>= (fun ea2 eb2
->
1263 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1264 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1266 ((A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
))) +> wa,
1267 ((B.ArrayAccess
(eb1
, eb2
),typ), [ib1;ib2
])
1270 (* todo?: handle some isomorphisms here ? *)
1271 | A.RecordAccess
(ea
, ia1
, ida
), ((B.RecordAccess
(eb
, idb
), typ),ii
) ->
1272 let (ib1) = tuple_of_list1 ii
in
1273 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
1274 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1275 expression ea eb
>>= (fun ea eb
->
1277 ((A.RecordAccess
(ea
, ia1
, ida
))) +> wa,
1278 ((B.RecordAccess
(eb
, idb
), typ), [ib1])
1283 | A.RecordPtAccess
(ea
,ia1
,ida
),((B.RecordPtAccess
(eb
, idb
), typ), ii
) ->
1284 let (ib1) = tuple_of_list1 ii
in
1285 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
1286 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1287 expression ea eb
>>= (fun ea eb
->
1289 ((A.RecordPtAccess
(ea
, ia1
, ida
))) +> wa,
1290 ((B.RecordPtAccess
(eb
, idb
), typ), [ib1])
1294 (* todo?: handle some isomorphisms here ?
1295 * todo?: do some iso-by-absence on cast ?
1296 * by trying | ea, B.Case (typb, eb) -> match_e_e ea eb ?
1299 | A.Cast
(ia1
, typa
, ia2
, ea
), ((B.Cast
(typb
, eb
), typ),ii
) ->
1300 let (ib1, ib2
) = tuple_of_list2 ii
in
1301 fullType typa typb
>>= (fun typa typb
->
1302 expression ea eb
>>= (fun ea eb
->
1303 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1304 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1306 ((A.Cast
(ia1
, typa
, ia2
, ea
))) +> wa,
1307 ((B.Cast
(typb
, eb
),typ),[ib1;ib2
])
1310 | A.SizeOfExpr
(ia1
, ea
), ((B.SizeOfExpr
(eb
), typ),ii
) ->
1311 let ib1 = tuple_of_list1 ii
in
1312 expression ea eb
>>= (fun ea eb
->
1313 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1315 ((A.SizeOfExpr
(ia1
, ea
))) +> wa,
1316 ((B.SizeOfExpr
(eb
), typ),[ib1])
1319 | A.SizeOfType
(ia1
, ia2
, typa
, ia3
), ((B.SizeOfType typb
, typ),ii
) ->
1320 let (ib1,ib2
,ib3
) = tuple_of_list3 ii
in
1321 fullType typa typb
>>= (fun typa typb
->
1322 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1323 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1324 tokenf ia3 ib3
>>= (fun ia3 ib3
->
1326 ((A.SizeOfType
(ia1
, ia2
, typa
, ia3
))) +> wa,
1327 ((B.SizeOfType
(typb
),typ),[ib1;ib2
;ib3
])
1331 (* todo? iso ? allow all the combinations ? *)
1332 | A.Paren
(ia1
, ea
, ia2
), ((B.ParenExpr
(eb
), typ),ii
) ->
1333 let (ib1, ib2
) = tuple_of_list2 ii
in
1334 expression ea eb
>>= (fun ea eb
->
1335 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1336 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1338 ((A.Paren
(ia1
, ea
, ia2
))) +> wa,
1339 ((B.ParenExpr
(eb
), typ), [ib1;ib2
])
1342 | A.NestExpr
(starter
,exps
,ender
,None
,true), eb
->
1343 (match A.unwrap exps
with
1345 X.cocciExpExp expression exp eb
>>= (fun exp eb
->
1346 X.distrf_e
(dots2metavar starter
) eb
>>= (fun mcode eb
->
1349 (metavar2ndots mcode,
1350 A.rewrap exps
(A.DOTS
[exp
]),ender
,None
,true)) +> wa,
1356 "for nestexpr, only handling the case with dots and only one exp")
1358 | A.NestExpr _
, _
->
1359 failwith
"only handling multi and no when code in a nest expr"
1361 (* only in arg lists or in define body *)
1362 | A.TypeExp _
, _
-> fail
1364 (* only in arg lists *)
1365 | A.MetaExprList _
, _
1372 | A.DisjExpr
eas, eb
->
1373 eas +> List.fold_left
(fun acc ea
-> acc
>|+|> (expression ea eb
)) fail
1375 | A.UniqueExp _
,_
| A.OptExp _
,_
->
1376 failwith
"not handling Opt/Unique/Multi on expr"
1378 (* Because of Exp cant put a raise Impossible; have to put a fail *)
1380 (* have not a counter part in coccinelle, for the moment *)
1381 | _
, ((B.Sequence _
,_
),_
)
1382 | _
, ((B.StatementExpr _
,_
),_
)
1383 | _
, ((B.Constructor _
,_
),_
)
1384 | _
, ((B.New _
,_
),_
)
1385 | _
, ((B.Delete _
,_
),_
)
1390 (((B.Cast
(_
, _
)|B.ParenExpr _
|B.SizeOfType _
|B.SizeOfExpr _
|
1391 B.RecordPtAccess
(_
, _
)|
1392 B.RecordAccess
(_
, _
)|B.ArrayAccess
(_
, _
)|
1393 B.Binary
(_
, _
, _
)|B.Unary
(_
, _
)|
1394 B.Infix
(_
, _
)|B.Postfix
(_
, _
)|
1395 B.Assignment
(_
, _
, _
)|B.CondExpr
(_
, _
, _
)|
1396 B.FunCall
(_
, _
)|B.Constant _
|B.Ident _
),
1404 (* ------------------------------------------------------------------------- *)
1405 and (ident_cpp
: info_ident
-> (A.ident, B.name
) matcher
) =
1406 fun infoidb ida idb
->
1408 | B.RegularName
(s, iis) ->
1409 let iis = tuple_of_list1
iis in
1410 ident infoidb ida
(s, iis) >>= (fun ida
(s,iis) ->
1413 (B.RegularName
(s, [iis]))
1415 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
1417 (* This should be moved to the Id case of ident. Metavariables
1418 should be allowed to be bound to such variables. But doing so
1419 would require implementing an appropriate distr function *)
1422 and (ident: info_ident
-> (A.ident, string * Ast_c.info
) matcher
) =
1423 fun infoidb ida
((idb
, iib
) as ib
) -> (* (idb, iib) as ib *)
1424 let check_constraints constraints idb
=
1425 let meta_id_val l x
= Ast_c.MetaIdVal
(x
,l
) in
1426 match constraints
with
1427 A.IdNoConstraint
-> return (meta_id_val [],())
1428 | A.IdNegIdSet
(str
,meta
) ->
1429 X.check_idconstraint
satisfies_iconstraint str idb
1430 (fun () -> return (meta_id_val meta
,()))
1431 | A.IdRegExpConstraint re
->
1432 X.check_idconstraint
satisfies_regexpconstraint re idb
1433 (fun () -> return (meta_id_val [],())) in
1434 X.all_bound
(A.get_inherited ida
) >&&>
1435 match A.unwrap ida
with
1437 if (term sa
) =$
= idb
then
1438 tokenf sa iib
>>= (fun sa iib
->
1440 ((A.Id sa
)) +> A.rewrap ida
,
1445 | A.MetaId
(mida
,constraints
,keep
,inherited
) ->
1446 check_constraints constraints idb
>>=
1448 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1449 (* use drop_pos for ids so that the pos is not added a second time in
1450 the call to tokenf *)
1451 X.envf keep inherited
(A.drop_pos mida
, wrapper idb
, max_min)
1453 tokenf mida iib
>>= (fun mida iib
->
1455 ((A.MetaId
(mida
, constraints
, keep
, inherited
)) +> A.rewrap ida
,
1460 | A.MetaFunc
(mida
,constraints
,keep
,inherited
) ->
1462 check_constraints constraints idb
>>=
1464 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1465 X.envf keep inherited
(A.drop_pos mida
,Ast_c.MetaFuncVal idb
,max_min)
1467 tokenf mida iib
>>= (fun mida iib
->
1469 ((A.MetaFunc
(mida
,constraints
,keep
,inherited
)))+>A.rewrap ida
,
1474 | LocalFunction
| Function
-> is_function()
1476 failwith
"MetaFunc, need more semantic info about id"
1477 (* the following implementation could possibly be useful, if one
1478 follows the convention that a macro is always in capital letters
1479 and that a macro is not a function.
1480 (if idb =~ "^[A-Z_][A-Z_0-9]*$" then fail else is_function())*)
1483 | A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
) ->
1486 check_constraints constraints idb
>>=
1488 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1489 X.envf keep inherited
1490 (A.drop_pos mida
,Ast_c.MetaLocalFuncVal idb
, max_min)
1492 tokenf mida iib
>>= (fun mida iib
->
1494 ((A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
)))
1500 | DontKnow
-> failwith
"MetaLocalFunc, need more semantic info about id"
1503 (* not clear why disj things are needed, after disjdistr? *)
1505 ias
+> List.fold_left
(fun acc ia
-> acc
>|+|> (ident infoidb ia ib
)) fail
1507 | A.OptIdent _
| A.UniqueIdent _
->
1508 failwith
"not handling Opt/Unique for ident"
1510 (* ------------------------------------------------------------------------- *)
1511 and (arguments
: sequence
->
1512 (A.expression list
, Ast_c.argument
Ast_c.wrap2 list
) matcher
) =
1513 fun seqstyle eas ebs
->
1515 | Unordered
-> failwith
"not handling ooo"
1517 arguments_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1518 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1520 (* because '...' can match nothing, need to take care when have
1521 * ', ...' or '...,' as in f(..., X, Y, ...). It must match
1522 * f(1,2) for instance.
1523 * So I have added special cases such as (if startxs = []) and code
1524 * in the Ecomma matching rule.
1526 * old: Must do some try, for instance when f(...,X,Y,...) have to
1527 * test the transfo for all the combinaitions and if multiple transfo
1528 * possible ? pb ? => the type is to return a expression option ? use
1529 * some combinators to help ?
1530 * update: with the tag-SP approach, no more a problem.
1533 and arguments_bis
= fun eas ebs
->
1535 match A.unwrap ea
with
1536 A.Edots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
1538 let build_dots (mcode, optexpr
) = A.Edots
(mcode, optexpr
) in
1539 let match_comma ea
=
1540 match A.unwrap ea
with
1541 A.EComma ia1
-> Some ia1
1543 let build_comma ia1
= A.EComma ia1
in
1544 let match_metalist ea
=
1545 match A.unwrap ea
with
1546 A.MetaExprList
(ida
,leninfo
,keep
,inherited
) ->
1547 Some
(ida
,leninfo
,keep
,inherited
)
1549 let build_metalist (ida
,leninfo
,keep
,inherited
) =
1550 A.MetaExprList
(ida
,leninfo
,keep
,inherited
) in
1551 let mktermval v
= Ast_c.MetaExprListVal v
in
1552 let special_cases ea
eas ebs
= None
in
1553 list_matcher match_dots build_dots match_comma build_comma
1554 match_metalist build_metalist mktermval
1555 special_cases argument
X.distrf_args
1556 Lib_parsing_c.ii_of_args
eas ebs
1558 and argument arga argb
=
1559 X.all_bound
(A.get_inherited arga
) >&&>
1560 match A.unwrap arga
, argb
with
1562 Right
(B.ArgType
{B.p_register
=b
,iib
; p_namei
=sopt
;p_type
=tyb
}) ->
1563 if b
|| sopt
<> None
1565 (* failwith "the argument have a storage and ast_cocci does not have"*)
1568 (* b = false and sopt = None *)
1569 fullType tya tyb
>>= (fun tya tyb
->
1571 (A.TypeExp tya
) +> A.rewrap arga
,
1572 (Right
(B.ArgType
{B.p_register
=(b
,iib
);
1577 | A.TypeExp tya
, _
-> fail
1578 | _
, Right
(B.ArgType _
) -> fail
1580 expression arga argb
>>= (fun arga argb
->
1581 return (arga
, Left argb
)
1583 | _
, Right
(B.ArgAction y
) -> fail
1586 (* ------------------------------------------------------------------------- *)
1587 (* todo? facto code with argument ? *)
1588 and (parameters
: sequence
->
1589 (A.parameterTypeDef list
, Ast_c.parameterType
Ast_c.wrap2 list
)
1591 fun seqstyle eas ebs
->
1593 | Unordered
-> failwith
"not handling ooo"
1595 parameters_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1596 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1600 and parameters_bis
eas ebs
=
1602 match A.unwrap ea
with
1603 A.Pdots
(mcode) -> Some
(mcode, None
)
1605 let build_dots (mcode, _optexpr
) = A.Pdots
(mcode) in
1606 let match_comma ea
=
1607 match A.unwrap ea
with
1608 A.PComma ia1
-> Some ia1
1610 let build_comma ia1
= A.PComma ia1
in
1611 let match_metalist ea
=
1612 match A.unwrap ea
with
1613 A.MetaParamList
(ida
,leninfo
,keep
,inherited
) ->
1614 Some
(ida
,leninfo
,keep
,inherited
)
1616 let build_metalist (ida
,leninfo
,keep
,inherited
) =
1617 A.MetaParamList
(ida
,leninfo
,keep
,inherited
) in
1618 let mktermval v
= Ast_c.MetaParamListVal v
in
1619 let special_cases ea
eas ebs
=
1620 (* a case where one smpl parameter matches a list of C parameters *)
1621 match A.unwrap ea
,ebs
with
1622 A.VoidParam ta
, ys
->
1624 (match eas, ebs
with
1626 let {B.p_register
=(hasreg
,iihasreg
);
1628 p_type
=tb
; } = eb
in
1630 if idbopt
=*= None
&& not hasreg
1633 | (qub
, (B.BaseType
B.Void
,_
)) ->
1634 fullType ta tb
>>= (fun ta tb
->
1636 [(A.VoidParam ta
) +> A.rewrap ea
],
1637 [Left
{B.p_register
=(hasreg
, iihasreg
);
1645 list_matcher match_dots build_dots match_comma build_comma
1646 match_metalist build_metalist mktermval
1647 special_cases parameter
X.distrf_params
1648 Lib_parsing_c.ii_of_params
eas ebs
1651 let split_register_param = fun (hasreg, idb, ii_b_s) ->
1652 match hasreg, idb, ii_b_s with
1653 | false, Some s, [i1] -> Left (s, [], i1)
1654 | true, Some s, [i1;i2] -> Left (s, [i1], i2)
1655 | _, None, ii -> Right ii
1656 | _ -> raise Impossible
1660 and parameter
= fun parama paramb
->
1661 match A.unwrap parama
, paramb
with
1662 A.MetaParam
(ida
,keep
,inherited
), eb
->
1663 (* todo: use quaopt, hasreg ? *)
1665 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_param eb
) in
1666 X.envf keep inherited
(ida
,Ast_c.MetaParamVal eb
,max_min) (fun () ->
1667 X.distrf_param ida eb
1668 ) >>= (fun ida eb
->
1669 return (A.MetaParam
(ida
,keep
,inherited
)+> A.rewrap parama
,eb
))
1670 | A.Param
(typa
, idaopt
), eb
->
1671 let {B.p_register
= (hasreg
,iihasreg
);
1672 p_namei
= nameidbopt
;
1673 p_type
= typb
;} = paramb
in
1675 fullType typa typb
>>= (fun typa typb
->
1676 match idaopt
, nameidbopt
with
1677 | Some ida
, Some nameidb
->
1678 (* todo: if minus on ida, should also minus the iihasreg ? *)
1679 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1681 A.Param
(typa
, Some ida
)+> A.rewrap parama
,
1682 {B.p_register
= (hasreg
, iihasreg
);
1683 p_namei
= Some
(nameidb
);
1689 A.Param
(typa
, None
)+> A.rewrap parama
,
1690 {B.p_register
=(hasreg
,iihasreg
);
1694 (* why handle this case ? because of transform_proto ? we may not
1695 * have an ident in the proto.
1696 * If have some plus on ida ? do nothing about ida ?
1698 (* not anymore !!! now that julia is handling the proto.
1699 | _, Right iihasreg ->
1702 ((hasreg, None, typb), iihasreg)
1706 | Some _
, None
-> fail
1707 | None
, Some _
-> fail)
1708 | (A.OptParam _
| A.UniqueParam _
), _
->
1709 failwith
"not handling Opt/Unique for Param"
1710 | A.Pcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
1713 (* ------------------------------------------------------------------------- *)
1714 and (declaration
: (A.mcodekind * bool * A.declaration
,B.declaration
) matcher
) =
1715 fun (mckstart
, allminus
, decla
) declb
->
1716 X.all_bound
(A.get_inherited decla
) >&&>
1717 match A.unwrap decla
, declb
with
1719 (* Un MetaDecl est introduit dans l'asttoctl pour sauter au dessus
1720 * de toutes les declarations qui sont au debut d'un fonction et
1721 * commencer le reste du match au premier statement. Alors, ca matche
1722 * n'importe quelle declaration. On n'a pas besoin d'ajouter
1723 * quoi que ce soit dans l'environnement. C'est une sorte de DDots.
1725 * When the SP want to remove the whole function, the minus is not
1726 * on the MetaDecl but on the MetaRuleElem. So there should
1727 * be no transform of MetaDecl, just matching are allowed.
1730 | A.MetaDecl
(ida
,keep
,inherited
), _
->
1732 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_decl declb
) in
1733 X.envf keep inherited
(ida
, Ast_c.MetaDeclVal declb
, max_min) (fun () ->
1734 X.distrf_decl ida declb
1735 ) >>= (fun ida declb
->
1736 return ((mckstart
, allminus
,
1737 (A.MetaDecl
(ida
, keep
, inherited
))+> A.rewrap decla
),
1739 | _
, (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
)) ->
1740 onedecl allminus decla
(var
,iiptvirgb
,iisto
) >>=
1741 (fun decla
(var
,iiptvirgb
,iisto
)->
1742 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1744 (mckstart
, allminus
, decla
),
1745 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1748 | _
, (B.DeclList
(xs
, ((iiptvirgb
::iifakestart
::iisto
) as ii
))) ->
1750 let rec loop n
= function
1752 | x
::xs
-> (n
,x
)::(loop (n
+1) xs
) in
1754 let rec repln n vl cur
= function
1757 if n
= cur
then vl
:: xs
else x
:: (repln n vl
(cur
+1) xs
) in
1758 if X.mode
=*= PatternMode
|| A.get_safe_decl decla
1760 (indexify xs
) +> List.fold_left
(fun acc
(n
,var
) ->
1761 (* consider all possible matches *)
1762 acc
>||> (function tin
-> (
1763 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1764 onedecl allminus decla
(var
, iiptvirgb
, iisto
) >>=
1765 (fun decla
(var
, iiptvirgb
, iisto
) ->
1767 (mckstart
, allminus
, decla
),
1768 (* adjust the variable that was chosen *)
1769 (B.DeclList
(repln n var
0 xs
,
1770 iiptvirgb
::iifakestart
::iisto
))
1775 "More than one variable in the declaration, and so it cannot be transformed. Check that there is no transformation on the type or the ;"
1777 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
), B.MacroDecl
((sb
,ebs
),ii
) ->
1778 let (iisb
, lpb
, rpb
, iiendb
, iifakestart
, iistob
) =
1780 | iisb
::lpb
::rpb
::iiendb
::iifakestart
::iisto
->
1781 (iisb
,lpb
,rpb
,iiendb
, iifakestart
,iisto
)
1782 | _
-> raise Impossible
1785 then minusize_list iistob
1786 else return ((), iistob
)
1787 ) >>= (fun () iistob
->
1789 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1790 ident DontKnow sa
(sb
, iisb
) >>= (fun sa
(sb
, iisb
) ->
1791 tokenf lpa lpb
>>= (fun lpa lpb
->
1792 tokenf rpa rpb
>>= (fun rpa rpb
->
1793 tokenf enda iiendb
>>= (fun enda iiendb
->
1794 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
1795 let eas = redots
eas easundots
in
1798 (mckstart
, allminus
,
1799 (A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
)) +> A.rewrap decla
),
1800 (B.MacroDecl
((sb
,ebs
),
1801 [iisb
;lpb
;rpb
;iiendb
;iifakestart
] ++ iistob
))
1804 | _
, (B.MacroDecl _
|B.DeclList _
) -> fail
1807 and onedecl
= fun allminus decla
(declb
, iiptvirgb
, iistob
) ->
1808 X.all_bound
(A.get_inherited decla
) >&&>
1809 match A.unwrap decla
, declb
with
1811 (* kind of typedef iso, we must unfold, it's for the case
1812 * T { }; that we want to match against typedef struct { } xx_t;
1815 | A.TyDecl
(tya0
, ptvirga
),
1816 ({B.v_namei
= Some
(nameidb
, B.NoInit
);
1818 B.v_storage
= (B.StoTypedef
, inl
);
1821 B.v_type_bis
= typb0bis
;
1824 (match A.unwrap tya0
, typb0
with
1825 | A.Type
(cv1
,tya1
), ((qu
,il
),typb1
) ->
1827 (match A.unwrap tya1
, typb1
with
1828 | A.StructUnionDef
(tya2
, lba
, declsa
, rba
),
1829 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
1831 let (iisub
, iisbopt
, lbb
, rbb
) =
1834 let (iisub
, lbb
, rbb
) = tuple_of_list3 ii
in
1835 (iisub
, [], lbb
, rbb
)
1838 "warning: both a typedef (%s) and struct name introduction (%s)"
1839 (Ast_c.str_of_name nameidb
) s
1841 pr2 "warning: I will consider only the typedef";
1842 let (iisub
, iisb
, lbb
, rbb
) = tuple_of_list4 ii
in
1843 (iisub
, [iisb
], lbb
, rbb
)
1846 structdef_to_struct_name
1847 (Ast_c.nQ
, (B.StructUnion
(sub
, sbopt
, declsb
), ii
))
1850 Ast_c.nQ
,((B.TypeName
(nameidb
, Some
1851 (Lib_parsing_c.al_type
structnameb))), [])
1854 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1855 tokenf lba lbb
>>= (fun lba lbb
->
1856 tokenf rba rbb
>>= (fun rba rbb
->
1857 struct_fields
(A.undots declsa
) declsb
>>=(fun undeclsa declsb
->
1858 let declsa = redots
declsa undeclsa
in
1860 (match A.unwrap tya2
with
1861 | A.Type
(cv3
, tya3
) ->
1862 (match A.unwrap tya3
with
1863 | A.MetaType
(ida
,keep
, inherited
) ->
1865 fullType tya2
fake_typeb >>= (fun tya2
fake_typeb ->
1867 A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1 in
1868 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1871 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1872 [iisub
] @ iisbopt
@ [lbb
;rbb
] in
1873 let typb0 = ((qu
, il
), typb1) in
1875 match fake_typeb with
1876 | _nQ
, ((B.TypeName
(nameidb
, _typ
)),[]) ->
1879 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1880 (({B.v_namei
= Some
(nameidb
, B.NoInit
);
1882 B.v_storage
= (B.StoTypedef
, inl
);
1885 B.v_type_bis
= typb0bis
;
1887 iivirg
),iiptvirgb
,iistob
)
1889 | _
-> raise Impossible
1892 (* do we need EnumName here too? *)
1893 | A.StructUnionName
(sua
, sa
) ->
1894 fullType tya2
structnameb >>= (fun tya2
structnameb ->
1896 let tya1 = A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1
1898 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1900 match structnameb with
1901 | _nQ
, (B.StructUnionName
(sub
, s), [iisub
;iisbopt
]) ->
1903 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1904 [iisub
;iisbopt
;lbb
;rbb
] in
1905 let typb0 = ((qu
, il
), typb1) in
1908 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1909 (({B.v_namei
= Some
(nameidb
, B.NoInit
);
1911 B.v_storage
= (B.StoTypedef
, inl
);
1914 B.v_type_bis
= typb0bis
;
1916 iivirg
),iiptvirgb
,iistob
)
1918 | _
-> raise Impossible
1920 | _
-> raise Impossible
1929 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1930 ({B.v_namei
= Some
(nameidb
, _
);B.v_storage
= (B.StoTypedef
,_
);}, iivirg
)
1933 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1934 ({B.v_namei
=Some
(nameidb
, _
);B.v_storage
=(B.StoTypedef
,_
);}, iivirg
)
1939 (* could handle iso here but handled in standard.iso *)
1940 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1941 ({B.v_namei
= Some
(nameidb
, B.NoInit
);
1946 B.v_type_bis
= typbbis
;
1948 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1949 fullType typa typb
>>= (fun typa typb
->
1950 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1951 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1952 (fun stoa
(stob
, iistob
) ->
1954 (A.UnInit
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
1955 (({B.v_namei
= Some
(nameidb
, B.NoInit
);
1960 B.v_type_bis
= typbbis
;
1965 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1966 ({B.v_namei
= Some
(nameidb
, B.ValInit
(iieqb
, inib
));
1971 B.v_type_bis
= typbbis
;
1974 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1975 tokenf eqa iieqb
>>= (fun eqa iieqb
->
1976 fullType typa typb
>>= (fun typa typb
->
1977 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1978 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1979 (fun stoa
(stob
, iistob
) ->
1980 initialiser inia inib
>>= (fun inia inib
->
1982 (A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
)) +> A.rewrap decla
,
1983 (({B.v_namei
= Some
(nameidb
, B.ValInit
(iieqb
, inib
));
1988 B.v_type_bis
= typbbis
;
1993 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1994 ({B.v_namei
= Some
(nameidb
, B.ConstrInit _
);
1999 B.v_type_bis
= typbbis
;
2001 -> fail (* C++ constructor declaration not supported in SmPL *)
2003 (* do iso-by-absence here ? allow typedecl and var ? *)
2004 | A.TyDecl
(typa
, ptvirga
),
2005 ({B.v_namei
= None
; B.v_type
= typb
;
2009 B.v_type_bis
= typbbis
;
2012 if stob
=*= (B.NoSto
, false)
2014 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2015 fullType typa typb
>>= (fun typa typb
->
2017 (A.TyDecl
(typa
, ptvirga
)) +> A.rewrap decla
,
2018 (({B.v_namei
= None
;
2023 B.v_type_bis
= typbbis
;
2024 }, iivirg
), iiptvirgb
, iistob
)
2029 | A.Typedef
(stoa
, typa
, ida
, ptvirga
),
2030 ({B.v_namei
= Some
(nameidb
, B.NoInit
);
2032 B.v_storage
= (B.StoTypedef
,inline
);
2035 B.v_type_bis
= typbbis
;
2038 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2039 fullType typa typb
>>= (fun typa typb
->
2042 tokenf stoa iitypedef
>>= (fun stoa iitypedef
->
2043 return (stoa
, [iitypedef
])
2045 | _
-> error iistob
"weird, have both typedef and inline or nothing";
2046 ) >>= (fun stoa iistob
->
2047 (match A.unwrap ida
with
2048 | A.MetaType
(_
,_
,_
) ->
2051 Ast_c.nQ
, ((B.TypeName
(nameidb
, Ast_c.noTypedefDef
())), [])
2053 fullTypebis ida
fake_typeb >>= (fun ida
fake_typeb ->
2054 match fake_typeb with
2055 | _nQ
, ((B.TypeName
(nameidb
, _typ
)), []) ->
2056 return (ida
, nameidb
)
2057 | _
-> raise Impossible
2062 | B.RegularName
(sb
, iidb
) ->
2063 let iidb1 = tuple_of_list1 iidb
in
2067 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
2069 (A.TypeName sa
) +> A.rewrap ida
,
2070 B.RegularName
(sb
, [iidb1])
2074 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
2078 | _
-> raise Impossible
2080 ) >>= (fun ida nameidb
->
2082 (A.Typedef
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
2083 (({B.v_namei
= Some
(nameidb
, B.NoInit
);
2085 B.v_storage
= (B.StoTypedef
,inline
);
2088 B.v_type_bis
= typbbis
;
2096 | _
, ({B.v_namei
= None
;}, _
) ->
2097 (* old: failwith "no variable in this declaration, weird" *)
2102 | A.DisjDecl declas
, declb
->
2103 declas
+> List.fold_left
(fun acc decla
->
2105 (* (declaration (mckstart, allminus, decla) declb) *)
2106 (onedecl allminus decla
(declb
,iiptvirgb
, iistob
))
2111 (* only in struct type decls *)
2112 | A.Ddots
(dots
,whencode
), _
->
2115 | A.OptDecl _
, _
| A.UniqueDecl _
, _
->
2116 failwith
"not handling Opt/Unique Decl"
2118 | _
, ({B.v_namei
=Some _
}, _
) ->
2124 (* ------------------------------------------------------------------------- *)
2126 and (initialiser
: (A.initialiser
, Ast_c.initialiser
) matcher
) = fun ia ib
->
2127 X.all_bound
(A.get_inherited ia
) >&&>
2128 match (A.unwrap ia
,ib
) with
2130 | (A.MetaInit
(ida
,keep
,inherited
), ib
) ->
2132 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_ini ib
) in
2133 X.envf keep inherited
(ida
, Ast_c.MetaInitVal ib
, max_min)
2135 X.distrf_ini ida ib
>>= (fun ida ib
->
2137 A.MetaInit
(ida
,keep
,inherited
) +> A.rewrap ia
,
2142 | (A.InitExpr expa
, ib
) ->
2143 (match A.unwrap expa
, ib
with
2144 | A.Edots
(mcode, None
), ib
->
2145 X.distrf_ini
(dots2metavar mcode) ib
>>= (fun mcode ib
->
2148 (A.Edots
(metavar2dots mcode, None
) +> A.rewrap expa
)
2153 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
2155 | _
, (B.InitExpr expb
, ii
) ->
2157 expression expa expb
>>= (fun expa expb
->
2159 (A.InitExpr expa
) +> A.rewrap ia
,
2160 (B.InitExpr expb
, ii
)
2165 | (A.ArInitList
(ia1
, ias
, ia2
), (B.InitList ibs
, ii
)) ->
2167 | ib1::ib2
::iicommaopt
->
2168 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2169 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2170 ar_initialisers
(A.undots ias
) (ibs
, iicommaopt
) >>=
2171 (fun iasundots
(ibs
,iicommaopt
) ->
2173 (A.ArInitList
(ia1
, redots ias iasundots
, ia2
)) +> A.rewrap ia
,
2174 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2177 | _
-> raise Impossible
2180 | (A.StrInitList
(allminus
, ia1
, ias
, ia2
, []), (B.InitList ibs
, ii
)) ->
2182 | ib1::ib2
::iicommaopt
->
2183 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2184 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2185 str_initialisers allminus ias
(ibs
, iicommaopt
) >>=
2186 (fun ias
(ibs
,iicommaopt
) ->
2188 (A.StrInitList
(allminus
, ia1
, ias
, ia2
, [])) +> A.rewrap ia
,
2189 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2192 | _
-> raise Impossible
2195 | (A.StrInitList
(allminus
, i1
, ias
, i2
, whencode
),
2196 (B.InitList ibs
, _ii
)) ->
2197 failwith
"TODO: not handling whencode in initialisers"
2200 | (A.InitGccExt
(designatorsa
, ia2
, inia
),
2201 (B.InitDesignators
(designatorsb
, inib
), ii2
))->
2203 let iieq = tuple_of_list1 ii2
in
2205 tokenf ia2
iieq >>= (fun ia2
iieq ->
2206 designators designatorsa designatorsb
>>=
2207 (fun designatorsa designatorsb
->
2208 initialiser inia inib
>>= (fun inia inib
->
2210 (A.InitGccExt
(designatorsa
, ia2
, inia
)) +> A.rewrap ia
,
2211 (B.InitDesignators
(designatorsb
, inib
), [iieq])
2217 | (A.InitGccName
(ida
, ia1
, inia
), (B.InitFieldOld
(idb
, inib
), ii
)) ->
2220 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2221 initialiser inia inib
>>= (fun inia inib
->
2222 tokenf ia1 iicolon
>>= (fun ia1 iicolon
->
2224 (A.InitGccName
(ida
, ia1
, inia
)) +> A.rewrap ia
,
2225 (B.InitFieldOld
(idb
, inib
), [iidb
;iicolon
])
2232 | A.IComma
(comma
), _
->
2235 | A.UniqueIni _
,_
| A.OptIni _
,_
->
2236 failwith
"not handling Opt/Unique on initialisers"
2238 | _
, (B.InitIndexOld
(_
, _
), _
) -> fail
2239 | _
, (B.InitFieldOld
(_
, _
), _
) -> fail
2241 | _
, ((B.InitDesignators
(_
, _
)|B.InitList _
|B.InitExpr _
), _
)
2244 and designators dla dlb
=
2245 match (dla
,dlb
) with
2246 ([],[]) -> return ([], [])
2247 | ([],_
) | (_
,[]) -> fail
2248 | (da
::dla
,db
::dlb
) ->
2249 designator da db
>>= (fun da db
->
2250 designators dla dlb
>>= (fun dla dlb
->
2251 return (da
::dla
, db
::dlb
)))
2253 and designator da db
=
2255 (A.DesignatorField
(ia1
, ida
), (B.DesignatorField idb
,ii1
)) ->
2257 let (iidot
, iidb
) = tuple_of_list2 ii1
in
2258 tokenf ia1 iidot
>>= (fun ia1 iidot
->
2259 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2261 A.DesignatorField
(ia1
, ida
),
2262 (B.DesignatorField idb
, [iidot
;iidb
])
2265 | (A.DesignatorIndex
(ia1
,ea
,ia2
), (B.DesignatorIndex eb
, ii1
)) ->
2267 let (ib1, ib2
) = tuple_of_list2 ii1
in
2268 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2269 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2270 expression ea eb
>>= (fun ea eb
->
2272 A.DesignatorIndex
(ia1
,ea
,ia2
),
2273 (B.DesignatorIndex eb
, [ib1;ib2
])
2276 | (A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2277 (B.DesignatorRange
(e1b
, e2b
), ii1
)) ->
2279 let (ib1, ib2
, ib3
) = tuple_of_list3 ii1
in
2280 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2281 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2282 tokenf ia3 ib3
>>= (fun ia3 ib3
->
2283 expression e1a e1b
>>= (fun e1a e1b
->
2284 expression e2a e2b
>>= (fun e2a e2b
->
2286 A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2287 (B.DesignatorRange
(e1b
, e2b
), [ib1;ib2
;ib3
])
2289 | (_
, ((B.DesignatorField _
|B.DesignatorIndex _
|B.DesignatorRange _
), _
)) ->
2292 and str_initialisers
= fun allminus ias
(ibs
, iicomma
) ->
2293 let ias_unsplit = unsplit_icomma ias
in
2294 let ibs_split = resplit_initialiser ibs iicomma
in
2296 if need_unordered_initialisers ibs
2297 then initialisers_unordered2 allminus
ias_unsplit ibs_split >>=
2298 (fun ias_unsplit ibs_split ->
2300 split_icomma ias_unsplit,
2301 unsplit_initialiser ibs_split))
2304 and ar_initialisers
= fun ias
(ibs
, iicomma
) ->
2305 (* this doesn't check need_unordered_initialisers because ... can be
2306 implemented as ordered, even if it matches unordered initializers *)
2307 let ibs = resplit_initialiser ibs iicomma
in
2310 (List.map
(function (elem
,comma
) -> [Left elem
; Right
[comma
]]) ibs) in
2311 initialisers_ordered2 ias
ibs >>=
2312 (fun ias
ibs_split ->
2314 match List.rev
ibs_split with
2315 (Right comma
)::rest
-> (Ast_c.unsplit_comma
(List.rev rest
),comma
)
2316 | (Left _
)::_
-> (Ast_c.unsplit_comma
ibs_split,[]) (* possible *)
2318 return (ias
, (ibs,iicomma
)))
2320 and initialisers_ordered2
= fun ias
ibs ->
2322 match A.unwrap ea
with
2323 A.Idots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2325 let build_dots (mcode, optexpr
) = A.Idots
(mcode, optexpr
) in
2326 let match_comma ea
=
2327 match A.unwrap ea
with
2328 A.IComma ia1
-> Some ia1
2330 let build_comma ia1
= A.IComma ia1
in
2331 let match_metalist ea
=
2332 match A.unwrap ea
with
2333 A.MetaInitList
(ida
,leninfo
,keep
,inherited
) ->
2334 Some
(ida
,leninfo
,keep
,inherited
)
2336 let build_metalist (ida
,leninfo
,keep
,inherited
) =
2337 A.MetaInitList
(ida
,leninfo
,keep
,inherited
) in
2338 let mktermval v
= Ast_c.MetaInitListVal v
in
2339 let special_cases ea
eas ebs
= None
in
2340 let no_ii x
= failwith
"not possible" in
2341 list_matcher match_dots build_dots match_comma build_comma
2342 match_metalist build_metalist mktermval
2343 special_cases initialiser
X.distrf_inis
no_ii ias
ibs
2345 and initialisers_unordered2
= fun allminus ias
ibs ->
2350 let rec loop = function
2351 [] -> return ([],[])
2352 | (ib
,comma
)::ibs ->
2353 X.distrf_ini
minusizer ib
>>= (fun _ ib
->
2354 tokenf minusizer comma
>>= (fun _ comma
->
2355 loop ibs >>= (fun l
ibs ->
2356 return(l
,(ib
,comma
)::ibs)))) in
2358 else return ([], ys
)
2360 let permut = Common.uncons_permut_lazy ys
in
2361 permut +> List.fold_left
(fun acc
((e
, pos
), rest
) ->
2363 (initialiser_comma x e
2365 let rest = Lazy.force
rest in
2366 initialisers_unordered2 allminus xs
rest >>= (fun xs
rest ->
2369 Common.insert_elem_pos
(e
, pos
) rest
2373 and initialiser_comma
(x
,xcomma
) (y
, commay
) =
2374 match A.unwrap xcomma
with
2376 tokenf commax commay
>>= (fun commax commay
->
2377 initialiser x y
>>= (fun x y
->
2379 (x
, (A.IComma commax
) +> A.rewrap xcomma
),
2381 | _
-> raise Impossible
(* unsplit_iicomma wrong *)
2383 (* ------------------------------------------------------------------------- *)
2384 and (struct_fields
: (A.declaration list
, B.field list
) matcher
) =
2387 match A.unwrap ea
with
2388 A.Ddots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2390 let build_dots (mcode, optexpr
) = A.Ddots
(mcode, optexpr
) in
2391 let match_comma ea
= None
in
2392 let build_comma ia1
= failwith
"not possible" in
2393 let match_metalist ea
=
2394 match A.unwrap ea
with
2395 A.MetaFieldList
(ida
,leninfo
,keep
,inherited
) ->
2396 Some
(ida
,leninfo
,keep
,inherited
)
2398 let build_metalist (ida
,leninfo
,keep
,inherited
) =
2399 A.MetaFieldList
(ida
,leninfo
,keep
,inherited
) in
2401 (* drop empty ii information, because nothing between elements *)
2402 let v = List.map
Ast_c.unwrap
v in
2403 Ast_c.MetaFieldListVal
v in
2404 let special_cases ea
eas ebs
= None
in
2405 let no_ii x
= failwith
"not possible" in
2406 let make_ebs ebs
= List.map
(function x
-> Left x
) ebs
in
2407 let unmake_ebs ebs
=
2408 List.map
(function Left x
-> x
| Right x
-> failwith
"no right") ebs
in
2409 let distrf mcode startxs =
2410 let startxs = unmake_ebs startxs in
2411 X.distrf_struct_fields
mcode startxs >>=
2412 (fun mcode startxs -> return (mcode,make_ebs startxs)) in
2413 list_matcher match_dots build_dots match_comma build_comma
2414 match_metalist build_metalist mktermval
2415 special_cases struct_field
distrf no_ii eas (make_ebs ebs
) >>=
2416 (fun eas ebs
-> return (eas,unmake_ebs ebs
))
2418 and (struct_field
: (A.declaration
, B.field
) matcher
) = fun fa fb
->
2420 match A.unwrap fa
,fb
with
2421 | A.MetaField
(ida
,keep
,inherited
), _
->
2423 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_field fb
) in
2424 X.envf keep inherited
(ida
, Ast_c.MetaFieldVal fb
, max_min) (fun () ->
2425 X.distrf_field ida fb
2426 ) >>= (fun ida fb
->
2427 return ((A.MetaField
(ida
, keep
, inherited
))+> A.rewrap fa
,
2429 | _
,B.DeclarationField
(B.FieldDeclList
(onefield_multivars
,iiptvirg
)) ->
2431 let iiptvirgb = tuple_of_list1 iiptvirg
in
2433 (match onefield_multivars
with
2434 | [] -> raise Impossible
2435 | [onevar
,iivirg
] ->
2436 assert (null iivirg
);
2438 | B.BitField
(sopt
, typb
, _
, expr
) ->
2439 pr2_once
"warning: bitfield not handled by ast_cocci";
2441 | B.Simple
(None
, typb
) ->
2442 pr2_once
"warning: unamed struct field not handled by ast_cocci";
2444 | B.Simple
(Some nameidb
, typb
) ->
2446 (* build a declaration from a struct field *)
2447 let allminus = false in
2449 let stob = B.NoSto
, false in
2451 ({B.v_namei
= Some
(nameidb
, B.NoInit
);
2454 B.v_local
= Ast_c.NotLocalDecl
;
2455 B.v_attr
= Ast_c.noattr
;
2456 B.v_type_bis
= ref None
;
2457 (* the struct field should also get expanded ? no it's not
2458 * important here, we will rematch very soon *)
2462 onedecl
allminus fa
(fake_var,iiptvirgb,iisto) >>=
2463 (fun fa
(var
,iiptvirgb,iisto) ->
2466 | ({B.v_namei
= Some
(nameidb
, B.NoInit
);
2471 let onevar = B.Simple
(Some nameidb
, typb
) in
2475 ((B.DeclarationField
2476 (B.FieldDeclList
([onevar, iivirg
], [iiptvirgb])))
2479 | _
-> raise Impossible
2484 pr2_once
"PB: More that one variable in decl. Have to split";
2487 | _
,B.EmptyField _iifield
->
2490 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
),B.MacroDeclField
((sb
,ebs
),ii
) ->
2492 | _
,B.MacroDeclField
((sb
,ebs
),ii
) -> fail
2494 | _
,B.CppDirectiveStruct directive
-> fail
2495 | _
,B.IfdefStruct directive
-> fail
2498 and enum_fields
= fun eas ebs
->
2500 match A.unwrap ea
with
2501 A.Edots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2503 let build_dots (mcode, optexpr
) = A.Edots
(mcode, optexpr
) in
2504 let match_comma ea
=
2505 match A.unwrap ea
with
2506 A.EComma ia1
-> Some ia1
2508 let build_comma ia1
= A.EComma ia1
in
2509 let match_metalist ea
= None
in
2510 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
2511 let mktermval v = failwith
"not possible" in
2512 let special_cases ea
eas ebs
= None
in
2513 list_matcher match_dots build_dots match_comma build_comma
2514 match_metalist build_metalist mktermval
2515 special_cases enum_field
X.distrf_enum_fields
2516 Lib_parsing_c.ii_of_enum_fields
eas ebs
2518 and enum_field ida idb
=
2519 X.all_bound
(A.get_inherited ida
) >&&>
2520 match A.unwrap ida
, idb
with
2521 A.Ident
(id
),(nameidb
,None
) ->
2522 ident_cpp DontKnow id nameidb
>>= (fun id nameidb
->
2523 return ((A.Ident id
) +> A.rewrap ida
, (nameidb
,None
)))
2524 | A.Assignment
(ea1
,opa
,ea2
,init
),(nameidb
,Some
(opbi,eb2
)) ->
2525 (match A.unwrap ea1
with
2527 ident_cpp DontKnow id nameidb
>>= (fun id nameidb
->
2528 expression ea2 eb2
>>= (fun ea2 eb2
->
2529 tokenf opa
opbi >>= (fun opa
opbi -> (* only one kind of assignop *)
2531 (A.Assignment
((A.Ident
(id
))+>A.rewrap ea1
,opa
,ea2
,init
)) +>
2533 (nameidb
,Some
(opbi,eb2
))))))
2534 | _
-> failwith
"not possible")
2535 | _
-> failwith
"not possible"
2537 (* ------------------------------------------------------------------------- *)
2538 and (fullType
: (A.fullType
, Ast_c.fullType
) matcher
) =
2540 X.optional_qualifier_flag
(fun optional_qualifier
->
2541 X.all_bound
(A.get_inherited typa
) >&&>
2542 match A.unwrap typa
, typb
with
2543 | A.Type
(cv
,ty1
), ((qu
,il
),ty2
) ->
2545 if qu
.B.const
&& qu
.B.volatile
2548 ("warning: the type is both const & volatile but cocci " ^
2549 "does not handle that");
2551 (* Drop out the const/volatile part that has been matched.
2552 * This is because a SP can contain const T v; in which case
2553 * later in match_t_t when we encounter a T, we must not add in
2554 * the environment the whole type.
2559 (* "iso-by-absence" *)
2562 fullTypebis ty1
((qu
,il
), ty2
) >>= (fun ty1 fullty2
->
2564 (A.Type
(None
, ty1
)) +> A.rewrap typa
,
2568 (match optional_qualifier
, qu
.B.const
|| qu
.B.volatile
with
2569 | false, false -> do_stuff ()
2570 | false, true -> fail
2571 | true, false -> do_stuff ()
2574 then pr2_once
"USING optional_qualifier builtin isomorphism";
2580 (* todo: can be __const__ ? can be const & volatile so
2581 * should filter instead ?
2583 (match term x
, il
with
2584 | A.Const
, [i1
] when qu
.B.const
->
2586 tokenf x i1
>>= (fun x i1
->
2587 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2589 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2593 | A.Volatile
, [i1
] when qu
.B.volatile
->
2594 tokenf x i1
>>= (fun x i1
->
2595 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2597 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2605 | A.DisjType typas
, typb
->
2607 List.fold_left
(fun acc typa
-> acc
>|+|> (fullType typa typb
)) fail
2609 | A.OptType
(_
), _
| A.UniqueType
(_
), _
2610 -> failwith
"not handling Opt/Unique on type"
2615 * Why not (A.typeC, Ast_c.typeC) matcher ?
2616 * because when there is MetaType, we want that T record the whole type,
2617 * including the qualifier, and so this type (and the new_il function in
2618 * preceding function).
2621 and (fullTypebis
: (A.typeC
, Ast_c.fullType
) matcher
) =
2623 X.all_bound
(A.get_inherited ta
) >&&>
2624 match A.unwrap ta
, tb
with
2627 | A.MetaType
(ida
,keep
, inherited
), typb
->
2629 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
2630 X.envf keep inherited
(ida
, B.MetaTypeVal typb
, max_min) (fun () ->
2631 X.distrf_type ida typb
>>= (fun ida typb
->
2633 A.MetaType
(ida
,keep
, inherited
) +> A.rewrap ta
,
2637 | unwrap
, (qub
, typb
) ->
2638 typeC ta typb
>>= (fun ta typb
->
2639 return (ta
, (qub
, typb
))
2642 and simulate_signed ta basea stringsa signaopt tb baseb ii rebuilda
=
2643 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2644 * And even if in baseb we have a Signed Int, that does not mean
2645 * that ii is of length 2, cos Signed is the default, so if in signa
2646 * we have Signed explicitely ? we cant "accrocher" this mcode to
2647 * something :( So for the moment when there is signed in cocci,
2648 * we force that there is a signed in c too (done in pattern.ml).
2650 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2653 (* handle some iso on type ? (cf complex C rule for possible implicit
2655 match basea
, baseb
with
2656 | A.VoidType
, B.Void
2657 | A.FloatType
, B.FloatType
(B.CFloat
)
2658 | A.DoubleType
, B.FloatType
(B.CDouble
)
2659 | A.SizeType
, B.SizeType
2660 | A.SSizeType
, B.SSizeType
2661 | A.PtrDiffType
,B.PtrDiffType
->
2662 assert (signaopt
=*= None
);
2663 let stringa = tuple_of_list1 stringsa
in
2664 let (ibaseb
) = tuple_of_list1 ii
in
2665 tokenf stringa ibaseb
>>= (fun stringa ibaseb
->
2667 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2668 (B.BaseType baseb
, [ibaseb
])
2671 | A.CharType
, B.IntType
B.CChar
when signaopt
=*= None
->
2672 let stringa = tuple_of_list1 stringsa
in
2673 let ibaseb = tuple_of_list1 ii
in
2674 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2676 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2677 (B.BaseType
(B.IntType
B.CChar
), [ibaseb])
2680 | A.CharType
,B.IntType
(B.Si
(_sign
, B.CChar2
)) when signaopt
<> None
->
2681 let stringa = tuple_of_list1 stringsa
in
2682 let ibaseb = tuple_of_list1 iibaseb
in
2683 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2684 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2686 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2687 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2690 | A.ShortType
, B.IntType
(B.Si
(_
, B.CShort
))
2691 | A.IntType
, B.IntType
(B.Si
(_
, B.CInt
))
2692 | A.LongType
, B.IntType
(B.Si
(_
, B.CLong
)) ->
2693 let stringa = tuple_of_list1 stringsa
in
2696 (* iso-by-presence ? *)
2697 (* when unsigned int in SP, allow have just unsigned in C ? *)
2698 if mcode_contain_plus (mcodekind stringa)
2702 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2704 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2705 (B.BaseType
(baseb
), iisignbopt
++ [])
2711 "warning: long int or short int not handled by ast_cocci";
2715 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2716 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2718 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2719 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2721 | _
-> raise Impossible
2726 | A.LongLongType
, B.IntType
(B.Si
(_
, B.CLongLong
)) ->
2727 let (string1a
,string2a
) = tuple_of_list2 stringsa
in
2729 [ibase1b
;ibase2b
] ->
2730 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2731 tokenf string1a ibase1b
>>= (fun base1a ibase1b
->
2732 tokenf string2a ibase2b
>>= (fun base2a ibase2b
->
2734 (rebuilda
([base1a
;base2a
], signaopt
)) +> A.rewrap ta
,
2735 (B.BaseType
(baseb
), iisignbopt
++ [ibase1b
;ibase2b
])
2737 | [] -> fail (* should something be done in this case? *)
2738 | _
-> raise Impossible
)
2741 | _
, B.FloatType
B.CLongDouble
2744 "warning: long double not handled by ast_cocci";
2747 | _
, (B.Void
|B.FloatType _
|B.IntType _
2748 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
2750 and simulate_signed_meta ta basea signaopt tb baseb ii rebuilda
=
2751 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2752 * And even if in baseb we have a Signed Int, that does not mean
2753 * that ii is of length 2, cos Signed is the default, so if in signa
2754 * we have Signed explicitely ? we cant "accrocher" this mcode to
2755 * something :( So for the moment when there is signed in cocci,
2756 * we force that there is a signed in c too (done in pattern.ml).
2758 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2760 let match_to_type rebaseb
=
2761 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2762 let fta = A.rewrap basea
(A.Type
(None
,basea
)) in
2763 let ftb = Ast_c.nQ
,(B.BaseType
(rebaseb
), iibaseb
) in
2764 fullType
fta ftb >>= (fun fta (_
,tb
) ->
2765 (match A.unwrap
fta,tb
with
2766 A.Type
(_
,basea
), (B.BaseType baseb
, ii
) ->
2768 (rebuilda
(basea
, signaopt
)) +> A.rewrap ta
,
2769 (B.BaseType
(baseb
), iisignbopt
++ ii
)
2771 | _
-> failwith
"not possible"))) in
2773 (* handle some iso on type ? (cf complex C rule for possible implicit
2776 | B.IntType
(B.Si
(_sign
, B.CChar2
)) ->
2777 match_to_type (B.IntType
B.CChar
)
2779 | B.IntType
(B.Si
(_
, ty
)) ->
2781 | [] -> fail (* metavariable has to match something *)
2783 | _
-> match_to_type (B.IntType
(B.Si
(B.Signed
, ty
)))
2787 | (B.Void
|B.FloatType _
|B.IntType _
2788 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
2790 and (typeC
: (A.typeC
, Ast_c.typeC
) matcher
) =
2792 match A.unwrap ta
, tb
with
2793 | A.BaseType
(basea
,stringsa
), (B.BaseType baseb
, ii
) ->
2794 simulate_signed ta basea stringsa None tb baseb ii
2795 (function (stringsa
, signaopt
) -> A.BaseType
(basea
,stringsa
))
2796 | A.SignedT
(signaopt
, Some basea
), (B.BaseType baseb
, ii
) ->
2797 (match A.unwrap basea
with
2798 A.BaseType
(basea1
,strings1
) ->
2799 simulate_signed ta basea1 strings1
(Some signaopt
) tb baseb ii
2800 (function (strings1
, Some signaopt
) ->
2803 Some
(A.rewrap basea
(A.BaseType
(basea1
,strings1
))))
2804 | _
-> failwith
"not possible")
2805 | A.MetaType
(ida
,keep
,inherited
) ->
2806 simulate_signed_meta ta basea
(Some signaopt
) tb baseb ii
2807 (function (basea
, Some signaopt
) ->
2808 A.SignedT
(signaopt
,Some basea
)
2809 | _
-> failwith
"not possible")
2810 | _
-> failwith
"not possible")
2811 | A.SignedT
(signa
,None
), (B.BaseType baseb
, ii
) ->
2812 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2813 (match iibaseb
, baseb
with
2814 | [], B.IntType
(B.Si
(_sign
, B.CInt
)) ->
2815 sign
(Some signa
) signbopt >>= (fun signaopt iisignbopt
->
2817 | None
-> raise Impossible
2820 (A.SignedT
(signa
,None
)) +> A.rewrap ta
,
2821 (B.BaseType baseb
, iisignbopt
)
2829 (* todo? iso with array *)
2830 | A.Pointer
(typa
, iamult
), (B.Pointer typb
, ii
) ->
2831 let (ibmult
) = tuple_of_list1 ii
in
2832 fullType typa typb
>>= (fun typa typb
->
2833 tokenf iamult ibmult
>>= (fun iamult ibmult
->
2835 (A.Pointer
(typa
, iamult
)) +> A.rewrap ta
,
2836 (B.Pointer typb
, [ibmult
])
2839 | A.FunctionType
(allminus,tyaopt
,lpa
,paramsa
,rpa
),
2840 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
) ->
2842 let (lpb
, rpb
) = tuple_of_list2 ii
in
2846 ("Not handling well variable length arguments func. "^
2847 "You have been warned");
2848 tokenf lpa lpb
>>= (fun lpa lpb
->
2849 tokenf rpa rpb
>>= (fun rpa rpb
->
2850 fullType_optional_allminus
allminus tyaopt tyb
>>= (fun tyaopt tyb
->
2851 parameters
(seqstyle paramsa
) (A.undots paramsa
) paramsb
>>=
2852 (fun paramsaundots paramsb
->
2853 let paramsa = redots
paramsa paramsaundots
in
2855 (A.FunctionType
(allminus,tyaopt
,lpa
,paramsa,rpa
) +> A.rewrap ta
,
2856 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), [lpb
;rpb
])
2864 | A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
),
2865 (B.ParenType t1
, ii
) ->
2866 let (lp1b
, rp1b
) = tuple_of_list2 ii
in
2867 let (qu1b
, t1b
) = t1
in
2869 | B.Pointer t2
, ii
->
2870 let (starb
) = tuple_of_list1 ii
in
2871 let (qu2b
, t2b
) = t2
in
2873 | B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
->
2874 let (lp2b
, rp2b
) = tuple_of_list2 ii
in
2879 ("Not handling well variable length arguments func. "^
2880 "You have been warned");
2882 fullType tya tyb
>>= (fun tya tyb
->
2883 tokenf lp1a lp1b
>>= (fun lp1a lp1b
->
2884 tokenf rp1a rp1b
>>= (fun rp1a rp1b
->
2885 tokenf lp2a lp2b
>>= (fun lp2a lp2b
->
2886 tokenf rp2a rp2b
>>= (fun rp2a rp2b
->
2887 tokenf stara starb
>>= (fun stara starb
->
2888 parameters
(seqstyle paramsa) (A.undots
paramsa) paramsb
>>=
2889 (fun paramsaundots paramsb
->
2890 let paramsa = redots
paramsa paramsaundots
in
2894 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))),
2899 (B.Pointer
t2, [starb
]))
2903 (A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
))
2905 (B.ParenType
t1, [lp1b
;rp1b
])
2918 (* todo: handle the iso on optionnal size specifification ? *)
2919 | A.Array
(typa
, ia1
, eaopt
, ia2
), (B.Array
(ebopt
, typb
), ii
) ->
2920 let (ib1, ib2
) = tuple_of_list2 ii
in
2921 fullType typa typb
>>= (fun typa typb
->
2922 option expression eaopt ebopt
>>= (fun eaopt ebopt
->
2923 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2924 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2926 (A.Array
(typa
, ia1
, eaopt
, ia2
)) +> A.rewrap ta
,
2927 (B.Array
(ebopt
, typb
), [ib1;ib2
])
2931 (* todo: could also match a Struct that has provided a name *)
2932 (* This is for the case where the SmPL code contains "struct x", without
2933 a definition. In this case, the name field is always present.
2934 This case is also called from the case for A.StructUnionDef when
2935 a name is present in the C code. *)
2936 | A.StructUnionName
(sua
, Some sa
), (B.StructUnionName
(sub
, sb
), ii
) ->
2937 (* sa is now an ident, not an mcode, old: ... && (term sa) =$= sb *)
2938 let (ib1, ib2
) = tuple_of_list2 ii
in
2939 if equal_structUnion (term sua
) sub
2941 ident DontKnow sa
(sb
, ib2
) >>= (fun sa
(sb
, ib2
) ->
2942 tokenf sua
ib1 >>= (fun sua
ib1 ->
2944 (A.StructUnionName
(sua
, Some sa
)) +> A.rewrap ta
,
2945 (B.StructUnionName
(sub
, sb
), [ib1;ib2
])
2950 | A.StructUnionDef
(ty
, lba
, declsa, rba
),
2951 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
2953 let (ii_sub_sb
, lbb
, rbb
) =
2955 [iisub
; lbb
; rbb
] -> (Common.Left iisub
,lbb
,rbb
)
2956 | [iisub
; iisb
; lbb
; rbb
] -> (Common.Right
(iisub
,iisb
),lbb
,rbb
)
2957 | _
-> error ii
"list of length 3 or 4 expected" in
2960 match (sbopt
,ii_sub_sb
) with
2961 (None
,Common.Left iisub
) ->
2962 (* the following doesn't reconstruct the complete SP code, just
2963 the part that matched *)
2965 match A.unwrap
s with
2967 (match A.unwrap ty
with
2968 A.StructUnionName
(sua
, None
) ->
2969 (match (term sua
, sub
) with
2971 | (A.Union
,B.Union
) -> return ((),())
2974 tokenf sua iisub
>>= (fun sua iisub
->
2977 A.StructUnionName
(sua
, None
) +> A.rewrap
ty)
2979 return (ty,[iisub
])))
2981 | A.DisjType
(disjs
) ->
2983 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
2987 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
2989 (* build a StructUnionName from a StructUnion *)
2990 let fake_su = B.nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) in
2992 fullType
ty fake_su >>= (fun ty fake_su ->
2994 | _nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) ->
2995 return (ty, [iisub
; iisb
])
2996 | _
-> raise Impossible
)
3000 >>= (fun ty ii_sub_sb
->
3002 tokenf lba lbb
>>= (fun lba lbb
->
3003 tokenf rba rbb
>>= (fun rba rbb
->
3004 struct_fields
(A.undots
declsa) declsb
>>=(fun undeclsa declsb
->
3005 let declsa = redots
declsa undeclsa
in
3008 (A.StructUnionDef
(ty, lba
, declsa, rba
)) +> A.rewrap ta
,
3009 (B.StructUnion
(sub
, sbopt
, declsb
),ii_sub_sb
@[lbb
;rbb
])
3013 (* todo? handle isomorphisms ? because Unsigned Int can be match on a
3014 * uint in the C code. But some CEs consists in renaming some types,
3015 * so we don't want apply isomorphisms every time.
3017 | A.TypeName sa
, (B.TypeName
(nameb
, typb
), noii
) ->
3021 | B.RegularName
(sb
, iidb
) ->
3022 let iidb1 = tuple_of_list1 iidb
in
3026 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
3028 (A.TypeName sa
) +> A.rewrap ta
,
3029 (B.TypeName
(B.RegularName
(sb
, [iidb1]), typb
), noii
)
3033 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
3038 | _
, (B.NoType
, ii
) -> fail
3039 | _
, (B.TypeOfExpr e
, ii
) -> fail
3040 | _
, (B.TypeOfType e
, ii
) -> fail
3042 | _
, (B.ParenType e
, ii
) -> fail (* todo ?*)
3043 | A.EnumName
(en
,Some namea
), (B.EnumName nameb
, ii
) ->
3044 let (ib1,ib2
) = tuple_of_list2 ii
in
3045 ident DontKnow namea
(nameb
, ib2
) >>= (fun namea
(nameb
, ib2
) ->
3046 tokenf en
ib1 >>= (fun en
ib1 ->
3048 (A.EnumName
(en
, Some namea
)) +> A.rewrap ta
,
3049 (B.EnumName nameb
, [ib1;ib2
])
3052 | A.EnumDef
(ty, lba
, idsa
, rba
),
3053 (B.Enum
(sbopt
, idsb
), ii
) ->
3055 let (ii_sub_sb
, lbb
, rbb
, comma_opt
) =
3057 [iisub
; lbb
; rbb
; comma_opt
] ->
3058 (Common.Left iisub
,lbb
,rbb
,comma_opt
)
3059 | [iisub
; iisb
; lbb
; rbb
; comma_opt
] ->
3060 (Common.Right
(iisub
,iisb
),lbb
,rbb
,comma_opt
)
3061 | _
-> error ii
"list of length 4 or 5 expected" in
3064 match (sbopt
,ii_sub_sb
) with
3065 (None
,Common.Left iisub
) ->
3066 (* the following doesn't reconstruct the complete SP code, just
3067 the part that matched *)
3069 match A.unwrap
s with
3071 (match A.unwrap
ty with
3072 A.EnumName
(sua
, None
) ->
3073 tokenf sua iisub
>>= (fun sua iisub
->
3075 A.Type
(None
,A.EnumName
(sua
, None
) +> A.rewrap
ty)
3077 return (ty,[iisub
]))
3079 | A.DisjType
(disjs
) ->
3081 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
3085 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
3087 (* build an EnumName from an Enum *)
3088 let fake_su = B.nQ
, (B.EnumName sb
, [iisub
;iisb
]) in
3090 fullType
ty fake_su >>= (fun ty fake_su ->
3092 | _nQ
, (B.EnumName sb
, [iisub
;iisb
]) ->
3093 return (ty, [iisub
; iisb
])
3094 | _
-> raise Impossible
)
3098 >>= (fun ty ii_sub_sb
->
3100 tokenf lba lbb
>>= (fun lba lbb
->
3101 tokenf rba rbb
>>= (fun rba rbb
->
3102 let idsb = resplit_initialiser idsb [comma_opt
] in
3106 (function (elem
,comma
) -> [Left elem
; Right
[comma
]])
3108 enum_fields
(A.undots idsa
) idsb >>= (fun unidsa
idsb ->
3109 let idsa = redots
idsa unidsa
in
3111 match List.rev
idsb with
3112 (Right comma
)::rest ->
3113 (Ast_c.unsplit_comma
(List.rev
rest),comma
)
3114 | (Left _
)::_
-> (Ast_c.unsplit_comma
idsb,[]) (* possible *)
3117 (A.EnumDef
(ty, lba
, idsa, rba
)) +> A.rewrap ta
,
3118 (B.Enum
(sbopt
, idsb),ii_sub_sb
@[lbb
;rbb
]@iicomma
)
3122 | _
, (B.Enum _
, _
) -> fail (* todo cocci ?*)
3125 ((B.TypeName _
| B.StructUnionName
(_
, _
) | B.EnumName _
|
3126 B.StructUnion
(_
, _
, _
) |
3127 B.FunctionType _
| B.Array
(_
, _
) | B.Pointer _
|
3133 (* todo: iso on sign, if not mentioned then free. tochange?
3134 * but that require to know if signed int because explicit
3135 * signed int, or because implicit signed int.
3138 and sign signa signb
=
3139 match signa
, signb
with
3140 | None
, None
-> return (None
, [])
3141 | Some signa
, Some
(signb
, ib
) ->
3142 if equal_sign (term signa
) signb
3143 then tokenf signa ib
>>= (fun signa ib
->
3144 return (Some signa
, [ib
])
3150 and minusize_list iixs
=
3151 iixs
+> List.fold_left
(fun acc ii
->
3152 acc
>>= (fun xs ys
->
3153 tokenf minusizer ii
>>= (fun minus ii
->
3154 return (minus
::xs
, ii
::ys
)
3155 ))) (return ([],[]))
3156 >>= (fun _xsminys ys
->
3157 return ((), List.rev ys
)
3160 and storage_optional_allminus
allminus stoa
(stob, iistob
) =
3161 (* "iso-by-absence" for storage, and return type. *)
3162 X.optional_storage_flag
(fun optional_storage
->
3163 match stoa
, stob with
3164 | None
, (stobis
, inline
) ->
3168 minusize_list iistob
>>= (fun () iistob
->
3169 return (None
, (stob, iistob
))
3171 else return (None
, (stob, iistob
))
3174 (match optional_storage
, stobis
with
3175 | false, B.NoSto
-> do_minus ()
3177 | true, B.NoSto
-> do_minus ()
3180 then pr2_once
"USING optional_storage builtin isomorphism";
3184 | Some x
, ((stobis
, inline
)) ->
3185 if equal_storage (term x
) stobis
3187 let rec loop acc
= function
3190 let str = B.str_of_info i1
in
3192 "static" | "extern" | "auto" | "register" ->
3193 (* not very elegant, but tokenf doesn't know what token to
3195 tokenf x i1
>>= (fun x i1
->
3196 let rebuilt = (List.rev acc
) @ i1
:: iistob
in
3197 return (Some x
, ((stobis
, inline
), rebuilt)))
3198 | _
-> loop (i1
::acc
) iistob
) in
3203 and inline_optional_allminus
allminus inla
(stob, iistob
) =
3204 (* "iso-by-absence" for storage, and return type. *)
3205 X.optional_storage_flag
(fun optional_storage
->
3206 match inla
, stob with
3207 | None
, (stobis
, inline
) ->
3211 minusize_list iistob
>>= (fun () iistob
->
3212 return (None
, (stob, iistob
))
3214 else return (None
, (stob, iistob
))
3223 then pr2_once
"USING optional_storage builtin isomorphism";
3226 else fail (* inline not in SP and present in C code *)
3229 | Some x
, ((stobis
, inline
)) ->
3232 let rec loop acc
= function
3235 let str = B.str_of_info i1
in
3238 (* not very elegant, but tokenf doesn't know what token to
3240 tokenf x i1
>>= (fun x i1
->
3241 let rebuilt = (List.rev acc
) @ i1
:: iistob
in
3242 return (Some x
, ((stobis
, inline
), rebuilt)))
3243 | _
-> loop (i1
::acc
) iistob
) in
3245 else fail (* SP has inline, but the C code does not *)
3248 and fullType_optional_allminus
allminus tya retb
=
3253 X.distrf_type
minusizer retb
>>= (fun _x retb
->
3257 else return (None
, retb
)
3259 fullType tya retb
>>= (fun tya retb
->
3260 return (Some tya
, retb
)
3265 (*---------------------------------------------------------------------------*)
3267 and compatible_base_type a signa b
=
3268 let ok = return ((),()) in
3271 | Type_cocci.VoidType
, B.Void
3272 | Type_cocci.SizeType
, B.SizeType
3273 | Type_cocci.SSizeType
, B.SSizeType
3274 | Type_cocci.PtrDiffType
, B.PtrDiffType
->
3275 assert (signa
=*= None
);
3277 | Type_cocci.CharType
, B.IntType
B.CChar
when signa
=*= None
->
3279 | Type_cocci.CharType
, B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3280 compatible_sign signa signb
3281 | Type_cocci.ShortType
, B.IntType
(B.Si
(signb
, B.CShort
)) ->
3282 compatible_sign signa signb
3283 | Type_cocci.IntType
, B.IntType
(B.Si
(signb
, B.CInt
)) ->
3284 compatible_sign signa signb
3285 | Type_cocci.LongType
, B.IntType
(B.Si
(signb
, B.CLong
)) ->
3286 compatible_sign signa signb
3287 | _
, B.IntType
(B.Si
(signb
, B.CLongLong
)) ->
3288 pr2_once
"no longlong in cocci";
3290 | Type_cocci.FloatType
, B.FloatType
B.CFloat
->
3291 assert (signa
=*= None
);
3293 | Type_cocci.DoubleType
, B.FloatType
B.CDouble
->
3294 assert (signa
=*= None
);
3296 | _
, B.FloatType
B.CLongDouble
->
3297 pr2_once
"no longdouble in cocci";
3299 | Type_cocci.BoolType
, _
-> failwith
"no booltype in C"
3301 | _
, (B.Void
|B.FloatType _
|B.IntType _
3302 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
3304 and compatible_base_type_meta a signa qua b ii
local =
3306 | Type_cocci.MetaType
(ida
,keep
,inherited
),
3307 B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3308 compatible_sign signa signb
>>= fun _ _
->
3309 let newb = ((qua
, (B.BaseType
(B.IntType
B.CChar
),ii
)),local) in
3310 compatible_type a
newb
3311 | Type_cocci.MetaType
(ida
,keep
,inherited
), B.IntType
(B.Si
(signb
, ty)) ->
3312 compatible_sign signa signb
>>= fun _ _
->
3314 ((qua
, (B.BaseType
(B.IntType
(B.Si
(B.Signed
, ty))),ii
)),local) in
3315 compatible_type a
newb
3316 | _
, B.FloatType
B.CLongDouble
->
3317 pr2_once
"no longdouble in cocci";
3320 | _
, (B.Void
|B.FloatType _
|B.IntType _
3321 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
3324 and compatible_type a
(b
,local) =
3325 let ok = return ((),()) in
3327 let rec loop = function
3328 | _
, (qua
, (B.NoType
, _
)) ->
3329 failwith
"compatible_type: matching with NoType"
3330 | Type_cocci.BaseType a
, (qua
, (B.BaseType b
,ii
)) ->
3331 compatible_base_type a None b
3333 | Type_cocci.SignedT
(signa
,None
), (qua
, (B.BaseType b
,ii
)) ->
3334 compatible_base_type
Type_cocci.IntType
(Some signa
) b
3336 | Type_cocci.SignedT
(signa
,Some
ty), (qua
, (B.BaseType b
,ii
)) ->
3338 Type_cocci.BaseType
ty ->
3339 compatible_base_type
ty (Some signa
) b
3340 | Type_cocci.MetaType
(ida
,keep
,inherited
) ->
3341 compatible_base_type_meta
ty (Some signa
) qua b ii
local
3342 | _
-> failwith
"not possible")
3344 | Type_cocci.Pointer a
, (qub
, (B.Pointer b
, ii
)) ->
3346 | Type_cocci.FunctionPointer a
, _
->
3348 "TODO: function pointer type doesn't store enough information to determine compatability"
3349 | Type_cocci.Array a
, (qub
, (B.Array
(eopt
, b
),ii
)) ->
3350 (* no size info for cocci *)
3352 | Type_cocci.StructUnionName
(sua
, name
),
3353 (qub
, (B.StructUnionName
(sub
, sb
),ii
)) ->
3354 if equal_structUnion_type_cocci sua sub
3355 then structure_type_name name sb ii
3357 | Type_cocci.EnumName
(name
),
3358 (qub
, (B.EnumName
(sb
),ii
)) -> structure_type_name name sb ii
3359 | Type_cocci.TypeName sa
, (qub
, (B.TypeName
(namesb
, _typb
),noii
)) ->
3360 let sb = Ast_c.str_of_name namesb
in
3365 | Type_cocci.ConstVol
(qua
, a
), (qub
, b
) ->
3366 if (fst qub
).B.const
&& (fst qub
).B.volatile
3369 pr2_once
("warning: the type is both const & volatile but cocci " ^
3370 "does not handle that");
3376 | Type_cocci.Const
-> (fst qub
).B.const
3377 | Type_cocci.Volatile
-> (fst qub
).B.volatile
3379 then loop (a
,(Ast_c.nQ
, b
))
3382 | Type_cocci.MetaType
(ida
,keep
,inherited
), typb
->
3384 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
3385 X.envf keep inherited
(A.make_mcode ida
, B.MetaTypeVal typb
, max_min)
3389 (* subtil: must be after the MetaType case *)
3390 | a
, (qub
, (B.TypeName
(_namesb
, Some b
), noii
)) ->
3391 (* kind of typedef iso *)
3394 (* for metavariables of type expression *^* *)
3395 | Type_cocci.Unknown
, _
-> ok
3400 B.TypeOfType _
|B.TypeOfExpr _
|B.ParenType _
|
3401 B.EnumName _
|B.StructUnion
(_
, _
, _
)|B.Enum
(_
, _
)
3408 B.StructUnionName
(_
, _
)|
3410 B.Array
(_
, _
)|B.Pointer _
|B.TypeName _
|
3415 and structure_type_name nm
sb ii
=
3417 Type_cocci.NoName
-> ok
3418 | Type_cocci.Name sa
->
3422 | Type_cocci.MV
(ida
,keep
,inherited
) ->
3423 (* degenerate version of MetaId, no transformation possible *)
3424 let (ib1, ib2
) = tuple_of_list2 ii
in
3425 let max_min _
= Lib_parsing_c.lin_col_by_pos
[ib2
] in
3426 let mida = A.make_mcode ida
in
3427 X.envf keep inherited
(mida, B.MetaIdVal
(sb,[]), max_min)
3433 and compatible_sign signa signb
=
3434 let ok = return ((),()) in
3435 match signa
, signb
with
3437 | Some
Type_cocci.Signed
, B.Signed
3438 | Some
Type_cocci.Unsigned
, B.UnSigned
3443 and equal_structUnion_type_cocci a b
=
3445 | Type_cocci.Struct
, B.Struct
-> true
3446 | Type_cocci.Union
, B.Union
-> true
3447 | _
, (B.Struct
| B.Union
) -> false
3451 (*---------------------------------------------------------------------------*)
3452 and inc_file
(a
, before_after
) (b
, h_rel_pos
) =
3454 let rec aux_inc (ass
, bss
) passed
=
3458 let passed = List.rev
passed in
3460 (match before_after
, !h_rel_pos
with
3461 | IncludeNothing
, _
-> true
3462 | IncludeMcodeBefore
, Some x
->
3463 List.mem
passed (x
.Ast_c.first_of
)
3465 | IncludeMcodeAfter
, Some x
->
3466 List.mem
passed (x
.Ast_c.last_of
)
3468 (* no info, maybe cos of a #include <xx.h> that was already in a .h *)
3472 | (A.IncPath x
)::xs
, y
::ys
-> x
=$
= y
&& aux_inc (xs
, ys
) (x
::passed)
3473 | _
-> failwith
"IncDots not in last place or other pb"
3478 | A.Local ass
, B.Local bss
->
3479 aux_inc (ass
, bss
) []
3480 | A.NonLocal ass
, B.NonLocal bss
->
3481 aux_inc (ass
, bss
) []
3486 (*---------------------------------------------------------------------------*)
3488 and (define_params
: sequence
->
3489 (A.define_param list
, (string B.wrap
) B.wrap2 list
) matcher
) =
3490 fun seqstyle eas ebs
->
3492 | Unordered
-> failwith
"not handling ooo"
3494 define_paramsbis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
3495 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
3498 (* todo? facto code with argument and parameters ? *)
3499 and define_paramsbis
= fun eas ebs
->
3501 match A.unwrap ea
with
3502 A.DPdots
(mcode) -> Some
(mcode, None
)
3504 let build_dots (mcode, _optexpr
) = A.DPdots
(mcode) in
3505 let match_comma ea
=
3506 match A.unwrap ea
with
3507 A.DPComma ia1
-> Some ia1
3509 let build_comma ia1
= A.DPComma ia1
in
3510 let match_metalist ea
= None
in
3511 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
3512 let mktermval v = failwith
"not possible" in
3513 let special_cases ea
eas ebs
= None
in
3514 let no_ii x
= failwith
"not possible" in
3515 list_matcher match_dots build_dots match_comma build_comma
3516 match_metalist build_metalist mktermval
3517 special_cases define_parameter
X.distrf_define_params
no_ii eas ebs
3519 and define_parameter
= fun parama paramb
->
3520 match A.unwrap parama
, paramb
with
3521 A.DParam ida
, (idb
, ii
) ->
3522 let ib1 = tuple_of_list1 ii
in
3523 ident DontKnow ida
(idb
, ib1) >>= (fun ida
(idb
, ib1) ->
3524 return ((A.DParam ida
)+> A.rewrap parama
,(idb
, [ib1])))
3525 | (A.OptDParam _
| A.UniqueDParam _
), _
->
3526 failwith
"handling Opt/Unique for define parameters"
3527 | A.DPcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
3530 (*****************************************************************************)
3532 (*****************************************************************************)
3534 (* no global solution for positions here, because for a statement metavariable
3535 we want a MetaStmtVal, and for the others, it's not clear what we want *)
3537 let rec (rule_elem_node
: (A.rule_elem
, Control_flow_c.node
) matcher
) =
3540 x
>>= (fun a b
-> return (A.rewrap re a
, F.rewrap node b
))
3542 X.all_bound
(A.get_inherited re
) >&&>
3545 match A.unwrap re
, F.unwrap node
with
3547 (* note: the order of the clauses is important. *)
3549 | _
, F.Enter
| _
, F.Exit
| _
, F.ErrorExit
-> fail2()
3551 (* the metaRuleElem contains just '-' information. We dont need to add
3552 * stuff in the environment. If we need stuff in environment, because
3553 * there is a + S somewhere, then this will be done via MetaStmt, not
3555 * Can match TrueNode/FalseNode/... so must be placed before those cases.
3558 | A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
->
3559 let default = A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
in
3560 (match unwrap_node
with
3562 | F.TrueNode
| F.FalseNode
| F.AfterNode
3563 | F.LoopFallThroughNode
| F.FallThroughNode
3565 if X.mode
=*= PatternMode
3568 if mcode_contain_plus (mcodekind mcode)
3569 then failwith
"try add stuff on fake node"
3570 (* minusize or contextize a fake node is ok *)
3573 | F.EndStatement None
->
3574 if X.mode
=*= PatternMode
then return default
3576 (* DEAD CODE NOW ? only useful in -no_cocci_vs_c_3 ?
3577 if mcode_contain_plus (mcodekind mcode)
3579 let fake_info = Ast_c.fakeInfo() in
3580 distrf distrf_node (mcodekind mcode)
3581 (F.EndStatement (Some fake_info))
3582 else return unwrap_node
3586 | F.EndStatement
(Some i1
) ->
3587 tokenf mcode i1
>>= (fun mcode i1
->
3589 A.MetaRuleElem
(mcode,keep
, inherited
),
3590 F.EndStatement
(Some i1
)
3594 if X.mode
=*= PatternMode
then return default
3595 else failwith
"a MetaRuleElem can't transform a headfunc"
3597 if X.mode
=*= PatternMode
then return default
3599 X.distrf_node
(generalize_mcode mcode) node
>>= (fun mcode node
->
3601 A.MetaRuleElem
(mcode,keep
, inherited
),
3607 (* rene cant have found that a state containing a fake/exit/... should be
3609 * TODO: and F.Fake ?
3611 | _
, F.EndStatement _
| _
, F.CaseNode _
3612 | _
, F.TrueNode
| _
, F.FalseNode
| _
, F.AfterNode
3613 | _
, F.FallThroughNode
| _
, F.LoopFallThroughNode
3614 | _
, F.InLoopNode
-> fail2()
3616 (* really ? diff between pattern.ml and transformation.ml *)
3617 | _
, F.Fake
-> fail2()
3620 (* cas general: a Meta can match everything. It matches only
3621 * "header"-statement. We transform only MetaRuleElem, not MetaStmt.
3622 * So can't have been called in transform.
3624 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), F.Decl
(_
) -> fail
3626 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), unwrap_node
->
3627 (* todo: should not happen in transform mode *)
3629 (match Control_flow_c.extract_fullstatement node
with
3632 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_stmt stb
) in
3633 X.envf keep inherited
(ida
, Ast_c.MetaStmtVal stb
, max_min)
3635 (* no need tag ida, we can't be called in transform-mode *)
3637 A.MetaStmt
(ida
, keep
, metainfoMaybeTodo
, inherited
),
3645 | A.MetaStmtList _
, _
->
3646 failwith
"not handling MetaStmtList"
3648 | A.TopExp ea
, F.DefineExpr eb
->
3649 expression ea eb
>>= (fun ea eb
->
3655 | A.TopExp ea
, F.DefineType eb
->
3656 (match A.unwrap ea
with
3658 fullType ft eb
>>= (fun ft eb
->
3660 A.TopExp
(A.rewrap ea
(A.TypeExp
(ft
))),
3667 (* It is important to put this case before the one that fails because
3668 * of the lack of the counter part of a C construct in SmPL (for instance
3669 * there is not yet a CaseRange in SmPL). Even if SmPL don't handle
3670 * yet certain constructs, those constructs may contain expression
3671 * that we still want and can transform.
3674 | A.Exp exp
, nodeb
->
3676 (* kind of iso, initialisation vs affectation *)
3678 match A.unwrap exp
, nodeb
with
3679 | A.Assignment
(ea
, op
, eb
, true), F.Decl decl
->
3680 initialisation_to_affectation decl
+> F.rewrap node
3685 (* Now keep fullstatement inside the control flow node,
3686 * so that can then get in a MetaStmtVar the fullstatement to later
3687 * pp back when the S is in a +. But that means that
3688 * Exp will match an Ifnode even if there is no such exp
3689 * inside the condition of the Ifnode (because the exp may
3690 * be deeper, in the then branch). So have to not visit
3691 * all inside a node anymore.
3693 * update: j'ai choisi d'accrocher au noeud du CFG Ã la
3694 * fois le fullstatement et le partialstatement et appeler le
3695 * visiteur que sur le partialstatement.
3698 match Ast_cocci.get_pos re
with
3699 | None
-> expression
3703 Lib_parsing_c.max_min_by_pos
(Lib_parsing_c.ii_of_expr eb
) in
3704 let keep = Type_cocci.Unitary
in
3705 let inherited = false in
3706 let max_min _
= failwith
"no pos" in
3707 X.envf
keep inherited (pos
, B.MetaPosVal
(min
,max
), max_min)
3713 X.cocciExp
expfn exp
node >>= (fun exp
node ->
3721 X.cocciTy fullType
ty node >>= (fun ty node ->
3728 | A.TopInit init
, nodeb
->
3729 X.cocciInit initialiser init
node >>= (fun init
node ->
3737 | A.FunHeader
(mckstart
, allminus, fninfoa
, ida
, oparen
, paramsa, cparen
),
3738 F.FunHeader
({B.f_name
= nameidb
;
3739 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3743 f_old_c_style
= oldstyle
;
3748 then pr2 "OLD STYLE DECL NOT WELL SUPPORTED";
3751 (* fninfoa records the order in which the SP specified the various
3752 information, but this isn't taken into account in the matching.
3753 Could this be a problem for transformation? *)
3756 List.filter
(function A.FStorage
(s) -> true | _
-> false) fninfoa
3757 with [A.FStorage
(s)] -> Some
s | _
-> None
in
3759 match List.filter
(function A.FType
(s) -> true | _
-> false) fninfoa
3760 with [A.FType
(t
)] -> Some t
| _
-> None
in
3763 match List.filter
(function A.FInline
(i
) -> true | _
-> false) fninfoa
3764 with [A.FInline
(i
)] -> Some i
| _
-> None
in
3766 (match List.filter
(function A.FAttr
(a
) -> true | _
-> false) fninfoa
3767 with [A.FAttr
(a
)] -> failwith
"not checking attributes" | _
-> ());
3770 | ioparenb
::icparenb
::iifakestart
::iistob
->
3772 (* maybe important to put ident as the first tokens to transform.
3773 * It's related to transform_proto. So don't change order
3776 ident_cpp LocalFunction ida nameidb
>>= (fun ida nameidb
->
3777 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
3778 tokenf oparen ioparenb
>>= (fun oparen ioparenb
->
3779 tokenf cparen icparenb
>>= (fun cparen icparenb
->
3780 parameters
(seqstyle paramsa)
3781 (A.undots
paramsa) paramsb
>>=
3782 (fun paramsaundots paramsb
->
3783 let paramsa = redots
paramsa paramsaundots
in
3784 inline_optional_allminus
allminus
3785 inla (stob, iistob
) >>= (fun inla (stob, iistob
) ->
3786 storage_optional_allminus
allminus
3787 stoa (stob, iistob
) >>= (fun stoa (stob, iistob
) ->
3792 ("Not handling well variable length arguments func. "^
3793 "You have been warned");
3795 then minusize_list iidotsb
3796 else return ((),iidotsb
)
3797 ) >>= (fun () iidotsb
->
3799 fullType_optional_allminus
allminus tya retb
>>= (fun tya retb
->
3802 (match stoa with Some st
-> [A.FStorage st
] | None
-> []) ++
3803 (match inla with Some i
-> [A.FInline i
] | None
-> []) ++
3804 (match tya with Some t
-> [A.FType t
] | None
-> [])
3809 A.FunHeader
(mckstart
,allminus,fninfoa,ida
,oparen
,
3811 F.FunHeader
({B.f_name
= nameidb
;
3812 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3816 f_old_c_style
= oldstyle
; (* TODO *)
3818 ioparenb
::icparenb
::iifakestart
::iistob
)
3821 | _
-> raise Impossible
3829 | A.Decl
(mckstart
,allminus,decla
), F.Decl declb
->
3830 declaration
(mckstart
,allminus,decla
) declb
>>=
3831 (fun (mckstart
,allminus,decla
) declb
->
3833 A.Decl
(mckstart
,allminus,decla
),
3838 | A.SeqStart
mcode, F.SeqStart
(st
, level
, i1
) ->
3839 tokenf mcode i1
>>= (fun mcode i1
->
3842 F.SeqStart
(st
, level
, i1
)
3845 | A.SeqEnd
mcode, F.SeqEnd
(level
, i1
) ->
3846 tokenf mcode i1
>>= (fun mcode i1
->
3849 F.SeqEnd
(level
, i1
)
3852 | A.ExprStatement
(Some ea
, ia1
), F.ExprStatement
(st
, (Some eb
, ii
)) ->
3853 let ib1 = tuple_of_list1 ii
in
3854 expression ea eb
>>= (fun ea eb
->
3855 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3857 A.ExprStatement
(Some ea
, ia1
),
3858 F.ExprStatement
(st
, (Some eb
, [ib1]))
3862 | A.ExprStatement
(None
, ia1
), F.ExprStatement
(st
, (None
, ii
)) ->
3863 let ib1 = tuple_of_list1 ii
in
3864 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3866 A.ExprStatement
(None
, ia1
),
3867 F.ExprStatement
(st
, (None
, [ib1]))
3872 | A.IfHeader
(ia1
,ia2
, ea
, ia3
), F.IfHeader
(st
, (eb
,ii
)) ->
3873 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3874 expression ea eb
>>= (fun ea eb
->
3875 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3876 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3877 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3879 A.IfHeader
(ia1
, ia2
, ea
, ia3
),
3880 F.IfHeader
(st
, (eb
,[ib1;ib2
;ib3
]))
3883 | A.Else ia
, F.Else ib
->
3884 tokenf ia ib
>>= (fun ia ib
->
3885 return (A.Else ia
, F.Else ib
)
3888 | A.WhileHeader
(ia1
, ia2
, ea
, ia3
), F.WhileHeader
(st
, (eb
, ii
)) ->
3889 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3890 expression ea eb
>>= (fun ea eb
->
3891 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3892 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3893 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3895 A.WhileHeader
(ia1
, ia2
, ea
, ia3
),
3896 F.WhileHeader
(st
, (eb
, [ib1;ib2
;ib3
]))
3899 | A.DoHeader ia
, F.DoHeader
(st
, ib
) ->
3900 tokenf ia ib
>>= (fun ia ib
->
3905 | A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
), F.DoWhileTail
(eb
, ii
) ->
3906 let (ib1, ib2
, ib3
, ib4
) = tuple_of_list4 ii
in
3907 expression ea eb
>>= (fun ea eb
->
3908 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3909 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3910 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3911 tokenf ia4 ib4
>>= (fun ia4 ib4
->
3913 A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
),
3914 F.DoWhileTail
(eb
, [ib1;ib2
;ib3
;ib4
])
3916 | A.IteratorHeader
(ia1
, ia2
, eas, ia3
), F.MacroIterHeader
(st
, ((s,ebs
),ii
))
3918 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3920 ident DontKnow ia1
(s, ib1) >>= (fun ia1
(s, ib1) ->
3921 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3922 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3923 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
3924 let eas = redots
eas easundots
in
3926 A.IteratorHeader
(ia1
, ia2
, eas, ia3
),
3927 F.MacroIterHeader
(st
, ((s,ebs
), [ib1;ib2
;ib3
]))
3932 | A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3933 F.ForHeader
(st
, (((eb1opt
,ib3s
), (eb2opt
,ib4s
), (eb3opt
,ib4vide
)), ii
))
3935 assert (null ib4vide
);
3936 let (ib1, ib2
, ib5
) = tuple_of_list3 ii
in
3937 let ib3 = tuple_of_list1 ib3s
in
3938 let ib4 = tuple_of_list1 ib4s
in
3940 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3941 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3942 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3943 tokenf ia4
ib4 >>= (fun ia4
ib4 ->
3944 tokenf ia5 ib5
>>= (fun ia5 ib5
->
3945 option expression ea1opt eb1opt
>>= (fun ea1opt eb1opt
->
3946 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
3947 option expression ea3opt eb3opt
>>= (fun ea3opt eb3opt
->
3949 A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3950 F.ForHeader
(st
, (((eb1opt
,[ib3]), (eb2opt
,[ib4]), (eb3opt
,[])),
3956 | A.SwitchHeader
(ia1
,ia2
,ea
,ia3
), F.SwitchHeader
(st
, (eb
,ii
)) ->
3957 let (ib1, ib2
, ib3) = tuple_of_list3 ii
in
3958 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3959 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3960 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3961 expression ea eb
>>= (fun ea eb
->
3963 A.SwitchHeader
(ia1
,ia2
,ea
,ia3
),
3964 F.SwitchHeader
(st
, (eb
,[ib1;ib2
;ib3]))
3967 | A.Break
(ia1
, ia2
), F.Break
(st
, ((),ii
)) ->
3968 let (ib1, ib2
) = tuple_of_list2 ii
in
3969 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3970 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3973 F.Break
(st
, ((),[ib1;ib2
]))
3976 | A.Continue
(ia1
, ia2
), F.Continue
(st
, ((),ii
)) ->
3977 let (ib1, ib2
) = tuple_of_list2 ii
in
3978 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3979 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3981 A.Continue
(ia1
, ia2
),
3982 F.Continue
(st
, ((),[ib1;ib2
]))
3985 | A.Return
(ia1
, ia2
), F.Return
(st
, ((),ii
)) ->
3986 let (ib1, ib2
) = tuple_of_list2 ii
in
3987 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3988 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3990 A.Return
(ia1
, ia2
),
3991 F.Return
(st
, ((),[ib1;ib2
]))
3994 | A.ReturnExpr
(ia1
, ea
, ia2
), F.ReturnExpr
(st
, (eb
, ii
)) ->
3995 let (ib1, ib2
) = tuple_of_list2 ii
in
3996 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3997 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3998 expression ea eb
>>= (fun ea eb
->
4000 A.ReturnExpr
(ia1
, ea
, ia2
),
4001 F.ReturnExpr
(st
, (eb
, [ib1;ib2
]))
4006 | A.Include
(incla
,filea
),
4007 F.Include
{B.i_include
= (fileb
, ii
);
4008 B.i_rel_pos
= h_rel_pos
;
4009 B.i_is_in_ifdef
= inifdef
;
4012 assert (copt
=*= None
);
4014 let include_requirment =
4015 match mcodekind incla
, mcodekind filea
with
4016 | A.CONTEXT
(_
, A.BEFORE _
), _
->
4018 | _
, A.CONTEXT
(_
, A.AFTER _
) ->
4024 let (inclb
, iifileb
) = tuple_of_list2 ii
in
4025 if inc_file
(term filea
, include_requirment) (fileb
, h_rel_pos
)
4027 tokenf incla inclb
>>= (fun incla inclb
->
4028 tokenf filea iifileb
>>= (fun filea iifileb
->
4030 A.Include
(incla
, filea
),
4031 F.Include
{B.i_include
= (fileb
, [inclb
;iifileb
]);
4032 B.i_rel_pos
= h_rel_pos
;
4033 B.i_is_in_ifdef
= inifdef
;
4039 | A.Undef
(undefa
,ida
), F.DefineHeader
((idb
, ii
), B.Undef
) ->
4040 let (defineb
, iidb
, ieol
) = tuple_of_list3 ii
in
4041 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
4042 tokenf undefa defineb
>>= (fun undefa defineb
->
4044 A.Undef
(undefa
,ida
),
4045 F.DefineHeader
((idb
,[defineb
;iidb
;ieol
]),B.Undef
)
4050 | A.DefineHeader
(definea
,ida
,params
), F.DefineHeader
((idb
, ii
), defkind
) ->
4051 let (defineb
, iidb
, ieol
) = tuple_of_list3 ii
in
4052 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
4053 tokenf definea defineb
>>= (fun definea defineb
->
4054 (match A.unwrap params
, defkind
with
4055 | A.NoParams
, B.DefineVar
->
4057 A.NoParams
+> A.rewrap params
,
4060 | A.DParams
(lpa
,eas,rpa
), (B.DefineFunc
(ebs
, ii
)) ->
4061 let (lpb
, rpb
) = tuple_of_list2 ii
in
4062 tokenf lpa lpb
>>= (fun lpa lpb
->
4063 tokenf rpa rpb
>>= (fun rpa rpb
->
4065 define_params
(seqstyle eas) (A.undots
eas) ebs
>>=
4066 (fun easundots ebs
->
4067 let eas = redots
eas easundots
in
4069 A.DParams
(lpa
,eas,rpa
) +> A.rewrap params
,
4070 B.DefineFunc
(ebs
,[lpb
;rpb
])
4074 ) >>= (fun params defkind
->
4076 A.DefineHeader
(definea
, ida
, params
),
4077 F.DefineHeader
((idb
,[defineb
;iidb
;ieol
]),defkind
)
4082 | A.Default
(def
,colon
), F.Default
(st
, ((),ii
)) ->
4083 let (ib1, ib2
) = tuple_of_list2 ii
in
4084 tokenf def
ib1 >>= (fun def
ib1 ->
4085 tokenf colon ib2
>>= (fun colon ib2
->
4087 A.Default
(def
,colon
),
4088 F.Default
(st
, ((),[ib1;ib2
]))
4093 | A.Case
(case
,ea
,colon
), F.Case
(st
, (eb
,ii
)) ->
4094 let (ib1, ib2
) = tuple_of_list2 ii
in
4095 tokenf case
ib1 >>= (fun case
ib1 ->
4096 expression ea eb
>>= (fun ea eb
->
4097 tokenf colon ib2
>>= (fun colon ib2
->
4099 A.Case
(case
,ea
,colon
),
4100 F.Case
(st
, (eb
,[ib1;ib2
]))
4103 (* only occurs in the predicates generated by asttomember *)
4104 | A.DisjRuleElem
eas, _
->
4106 List.fold_left
(fun acc ea
-> acc
>|+|> (rule_elem_node ea
node)) fail)
4107 >>= (fun ea eb
-> return (A.unwrap ea
,F.unwrap eb
))
4109 | _
, F.ExprStatement
(_
, (None
, ii
)) -> fail (* happen ? *)
4111 | A.Label
(id
,dd
), F.Label
(st
, nameb
, ((),ii
)) ->
4112 let (ib2
) = tuple_of_list1 ii
in
4113 ident_cpp DontKnow id nameb
>>= (fun ida nameb
->
4114 tokenf dd ib2
>>= (fun dd ib2
->
4117 F.Label
(st
,nameb
, ((),[ib2
]))
4120 | A.Goto
(goto
,id
,sem
), F.Goto
(st
,nameb
, ((),ii
)) ->
4121 let (ib1,ib3) = tuple_of_list2 ii
in
4122 tokenf goto
ib1 >>= (fun goto
ib1 ->
4123 ident_cpp DontKnow id nameb
>>= (fun id nameb
->
4124 tokenf sem
ib3 >>= (fun sem
ib3 ->
4126 A.Goto
(goto
,id
,sem
),
4127 F.Goto
(st
,nameb
, ((),[ib1;ib3]))
4130 (* have not a counter part in coccinelle, for the moment *)
4131 (* todo?: print a warning at least ? *)
4137 | _
, (F.IfdefEndif _
|F.IfdefElse _
|F.IfdefHeader _
)
4141 (F.MacroStmt
(_
, _
)| F.DefineDoWhileZeroHeader _
| F.EndNode
|F.TopNode
)
4144 (F.Label
(_
, _
, _
)|F.Break
(_
, _
)|F.Continue
(_
, _
)|F.Default
(_
, _
)|
4145 F.Case
(_
, _
)|F.Include _
|F.Goto _
|F.ExprStatement _
|
4146 F.DefineType _
|F.DefineExpr _
|F.DefineTodo
|
4147 F.DefineHeader
(_
, _
)|F.ReturnExpr
(_
, _
)|F.Return
(_
, _
)|
4148 F.MacroIterHeader
(_
, _
)|
4149 F.SwitchHeader
(_
, _
)|F.ForHeader
(_
, _
)|F.DoWhileTail _
|F.DoHeader
(_
, _
)|
4150 F.WhileHeader
(_
, _
)|F.Else _
|F.IfHeader
(_
, _
)|
4151 F.SeqEnd
(_
, _
)|F.SeqStart
(_
, _
, _
)|
4152 F.Decl _
|F.FunHeader _
)