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.
26 * Copyright 2010, INRIA, University of Copenhagen
27 * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
28 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
29 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
30 * This file is part of Coccinelle.
32 * Coccinelle is free software: you can redistribute it and/or modify
33 * it under the terms of the GNU General Public License as published by
34 * the Free Software Foundation, according to version 2 of the License.
36 * Coccinelle is distributed in the hope that it will be useful,
37 * but WITHOUT ANY WARRANTY; without even the implied warranty of
38 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
39 * GNU General Public License for more details.
41 * You should have received a copy of the GNU General Public License
42 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
44 * The authors reserve the right to distribute this or future versions of
45 * Coccinelle under other licenses.
49 (* Yoann Padioleau, Julia Lawall
51 * Copyright (C) 2006, 2007, 2008 Ecole des Mines de Nantes
52 * Copyright (C) 2009, 2010 DIKU, INRIA, LIP6
54 * This program is free software; you can redistribute it and/or
55 * modify it under the terms of the GNU General Public License (GPL)
56 * version 2 as published by the Free Software Foundation.
58 * This program is distributed in the hope that it will be useful,
59 * but WITHOUT ANY WARRANTY; without even the implied warranty of
60 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
61 * file license.txt for more details.
63 * This file was part of Coccinelle.
71 module F
= Control_flow_c
73 module Flag
= Flag_matcher
75 (*****************************************************************************)
77 (*****************************************************************************)
78 let pr2, pr2_once
= Common.mk_pr2_wrappers
Flag_matcher.verbose_matcher
80 let (+++) a b
= match a
with Some x
-> Some x
| None
-> b
82 (*****************************************************************************)
84 (*****************************************************************************)
86 type sequence
= Ordered
| Unordered
89 match A.unwrap eas
with
91 | A.CIRCLES _
-> Unordered
92 | A.STARS _
-> failwith
"not handling stars"
94 let (redots
: 'a
A.dots
-> 'a list
-> 'a
A.dots
)=fun eas easundots
->
96 match A.unwrap eas
with
97 | A.DOTS _
-> A.DOTS easundots
98 | A.CIRCLES _
-> A.CIRCLES easundots
99 | A.STARS _
-> A.STARS easundots
103 let (need_unordered_initialisers
: B.initialiser
B.wrap2 list
-> bool) =
105 ibs
+> List.exists
(fun (ib
, icomma
) ->
106 match B.unwrap ib
with
107 | B.InitDesignators _
115 (* For the #include <linux/...> in the .cocci, need to find where is
116 * the '+' attached to this element, to later find the first concrete
117 * #include <linux/xxx.h> or last one in the series of #includes in the
120 type include_requirement
=
127 (* todo? put in semantic_c.ml *)
130 | LocalFunction
(* entails Function *)
134 let term mc
= A.unwrap_mcode mc
135 let mcodekind mc
= A.get_mcodekind mc
138 let mcode_contain_plus = function
139 | A.CONTEXT
(_
,A.NOTHING
) -> false
140 | A.CONTEXT _
-> true
141 | A.MINUS
(_
,_
,_
,[]) -> false
142 | A.MINUS
(_
,_
,_
,x
::xs
) -> true
143 | A.PLUS _
-> raise Impossible
145 let mcode_simple_minus = function
146 | A.MINUS
(_
,_
,_
,[]) -> true
150 (* In transformation.ml sometime I build some mcodekind myself and
151 * julia has put None for the pos. But there is no possible raise
152 * NoMatch in those cases because it is for the minusall trick or for
153 * the distribute, so either have to build those pos, in fact a range,
154 * because for the distribute have to erase a fullType with one
155 * mcodekind, or add an argument to tag_with_mck such as "safe" that
156 * don't do the check_pos. Hence this DontCarePos constructor. *)
160 {A.line
= 0; A.column
=0; A.strbef
=[]; A.straft
=[];},
161 (A.MINUS
(A.DontCarePos
,[],-1,[])),
164 let generalize_mcode ia
=
165 let (s1
, i
, mck
, pos
) = ia
in
168 | A.PLUS _
-> raise Impossible
169 | A.CONTEXT
(A.NoPos
,x
) ->
170 A.CONTEXT
(A.DontCarePos
,x
)
171 | A.MINUS
(A.NoPos
,inst
,adj
,x
) ->
172 A.MINUS
(A.DontCarePos
,inst
,adj
,x
)
174 | A.CONTEXT
((A.FixPos _
|A.DontCarePos
), _
)
175 | A.MINUS
((A.FixPos _
|A.DontCarePos
), _
, _
, _
)
179 (s1
, i
, new_mck, pos
)
183 (*---------------------------------------------------------------------------*)
185 (* 0x0 is equivalent to 0, value format isomorphism *)
186 let equal_c_int s1 s2
=
188 int_of_string s1
=|= int_of_string s2
189 with Failure
("int_of_string") ->
194 (*---------------------------------------------------------------------------*)
195 (* Normally A should reuse some types of Ast_c, so those
196 * functions should not exist.
198 * update: but now Ast_c depends on A, so can't make too
199 * A depends on Ast_c, so have to stay with those equal_xxx
203 let equal_unaryOp a b
=
205 | A.GetRef
, B.GetRef
-> true
206 | A.DeRef
, B.DeRef
-> true
207 | A.UnPlus
, B.UnPlus
-> true
208 | A.UnMinus
, B.UnMinus
-> true
209 | A.Tilde
, B.Tilde
-> true
210 | A.Not
, B.Not
-> true
211 | _
, B.GetRefLabel
-> false (* todo cocci? *)
212 | _
, (B.Not
|B.Tilde
|B.UnMinus
|B.UnPlus
|B.DeRef
|B.GetRef
) -> false
216 let equal_arithOp a b
=
218 | A.Plus
, B.Plus
-> true
219 | A.Minus
, B.Minus
-> true
220 | A.Mul
, B.Mul
-> true
221 | A.Div
, B.Div
-> true
222 | A.Mod
, B.Mod
-> true
223 | A.DecLeft
, B.DecLeft
-> true
224 | A.DecRight
, B.DecRight
-> true
225 | A.And
, B.And
-> true
226 | A.Or
, B.Or
-> true
227 | A.Xor
, B.Xor
-> true
228 | _
, (B.Xor
|B.Or
|B.And
|B.DecRight
|B.DecLeft
|B.Mod
|B.Div
|B.Mul
|B.Minus
|B.Plus
)
231 let equal_logicalOp a b
=
233 | A.Inf
, B.Inf
-> true
234 | A.Sup
, B.Sup
-> true
235 | A.InfEq
, B.InfEq
-> true
236 | A.SupEq
, B.SupEq
-> true
237 | A.Eq
, B.Eq
-> true
238 | A.NotEq
, B.NotEq
-> true
239 | A.AndLog
, B.AndLog
-> true
240 | A.OrLog
, B.OrLog
-> true
241 | _
, (B.OrLog
|B.AndLog
|B.NotEq
|B.Eq
|B.SupEq
|B.InfEq
|B.Sup
|B.Inf
)
244 let equal_assignOp a b
=
246 | A.SimpleAssign
, B.SimpleAssign
-> true
247 | A.OpAssign a
, B.OpAssign b
-> equal_arithOp a b
248 | _
, (B.OpAssign _
|B.SimpleAssign
) -> false
250 let equal_fixOp a b
=
252 | A.Dec
, B.Dec
-> true
253 | A.Inc
, B.Inc
-> true
254 | _
, (B.Inc
|B.Dec
) -> false
256 let equal_binaryOp a b
=
258 | A.Arith a
, B.Arith b
-> equal_arithOp a b
259 | A.Logical a
, B.Logical b
-> equal_logicalOp a b
260 | _
, (B.Logical _
| B.Arith _
) -> false
262 let equal_structUnion a b
=
264 | A.Struct
, B.Struct
-> true
265 | A.Union
, B.Union
-> true
266 | _
, (B.Struct
|B.Union
) -> false
270 | A.Signed
, B.Signed
-> true
271 | A.Unsigned
, B.UnSigned
-> true
272 | _
, (B.UnSigned
|B.Signed
) -> false
274 let equal_storage a b
=
276 | A.Static
, B.Sto
B.Static
277 | A.Auto
, B.Sto
B.Auto
278 | A.Register
, B.Sto
B.Register
279 | A.Extern
, B.Sto
B.Extern
281 | _
, (B.NoSto
| B.StoTypedef
) -> false
282 | _
, (B.Sto
(B.Register
|B.Static
|B.Auto
|B.Extern
)) -> false
285 (*---------------------------------------------------------------------------*)
287 let equal_metavarval valu valu'
=
288 match valu
, valu'
with
289 | Ast_c.MetaIdVal
(a
,_
), Ast_c.MetaIdVal
(b
,_
) -> a
=$
= b
290 | Ast_c.MetaFuncVal a
, Ast_c.MetaFuncVal b
-> a
=$
= b
291 | Ast_c.MetaLocalFuncVal a
, Ast_c.MetaLocalFuncVal b
->
292 (* do something more ? *)
295 (* al_expr before comparing !!! and accept when they match.
296 * Note that here we have Astc._expression, so it is a match
297 * modulo isomorphism (there is no metavariable involved here,
298 * just isomorphisms). => TODO call isomorphism_c_c instead of
299 * =*=. Maybe would be easier to transform ast_c in ast_cocci
300 * and call the iso engine of julia. *)
301 | Ast_c.MetaExprVal
(a
,_
), Ast_c.MetaExprVal
(b
,_
) ->
302 Lib_parsing_c.al_expr a
=*= Lib_parsing_c.al_expr b
303 | Ast_c.MetaExprListVal a
, Ast_c.MetaExprListVal b
->
304 Lib_parsing_c.al_arguments a
=*= Lib_parsing_c.al_arguments b
306 | Ast_c.MetaDeclVal a
, Ast_c.MetaDeclVal b
->
307 Lib_parsing_c.al_declaration a
=*= Lib_parsing_c.al_declaration b
308 | Ast_c.MetaFieldVal a
, Ast_c.MetaFieldVal b
->
309 Lib_parsing_c.al_field a
=*= Lib_parsing_c.al_field b
310 | Ast_c.MetaStmtVal a
, Ast_c.MetaStmtVal b
->
311 Lib_parsing_c.al_statement a
=*= Lib_parsing_c.al_statement b
312 | Ast_c.MetaInitVal a
, Ast_c.MetaInitVal b
->
313 Lib_parsing_c.al_init a
=*= Lib_parsing_c.al_init b
314 | Ast_c.MetaTypeVal a
, Ast_c.MetaTypeVal b
->
315 (* old: Lib_parsing_c.al_type a =*= Lib_parsing_c.al_type b *)
318 | Ast_c.MetaListlenVal a
, Ast_c.MetaListlenVal b
-> a
=|= b
320 | Ast_c.MetaParamVal a
, Ast_c.MetaParamVal b
->
321 Lib_parsing_c.al_param a
=*= Lib_parsing_c.al_param b
322 | Ast_c.MetaParamListVal a
, Ast_c.MetaParamListVal b
->
323 Lib_parsing_c.al_params a
=*= Lib_parsing_c.al_params b
325 | Ast_c.MetaPosVal
(posa1
,posa2
), Ast_c.MetaPosVal
(posb1
,posb2
) ->
326 Ast_cocci.equal_pos posa1 posb1
&& Ast_cocci.equal_pos posa2 posb2
328 | Ast_c.MetaPosValList l1
, Ast_c.MetaPosValList l2
->
330 (function (fla
,cea
,posa1
,posa2
) ->
332 (function (flb
,ceb
,posb1
,posb2
) ->
333 fla
=$
= flb
&& cea
=$
= ceb
&&
334 Ast_c.equal_posl posa1 posb1
&& Ast_c.equal_posl posa2 posb2
)
338 | (B.MetaPosValList _
|B.MetaListlenVal _
|B.MetaPosVal _
|B.MetaStmtVal _
339 |B.MetaDeclVal _
|B.MetaFieldVal _
|B.MetaTypeVal _
|B.MetaInitVal _
340 |B.MetaParamListVal _
|B.MetaParamVal _
|B.MetaExprListVal _
341 |B.MetaExprVal _
|B.MetaLocalFuncVal _
|B.MetaFuncVal _
|B.MetaIdVal _
345 (* probably only one argument needs to be stripped, because inherited
346 metavariables containing expressions are stripped in advance. But don't
347 know which one is which... *)
348 let equal_inh_metavarval valu valu'
=
349 match valu
, valu'
with
350 | Ast_c.MetaIdVal
(a
,_
), Ast_c.MetaIdVal
(b
,_
) -> a
=$
= b
351 | Ast_c.MetaFuncVal a
, Ast_c.MetaFuncVal b
-> a
=$
= b
352 | Ast_c.MetaLocalFuncVal a
, Ast_c.MetaLocalFuncVal b
->
353 (* do something more ? *)
356 (* al_expr before comparing !!! and accept when they match.
357 * Note that here we have Astc._expression, so it is a match
358 * modulo isomorphism (there is no metavariable involved here,
359 * just isomorphisms). => TODO call isomorphism_c_c instead of
360 * =*=. Maybe would be easier to transform ast_c in ast_cocci
361 * and call the iso engine of julia. *)
362 | Ast_c.MetaExprVal
(a
,_
), Ast_c.MetaExprVal
(b
,_
) ->
363 Lib_parsing_c.al_inh_expr a
=*= Lib_parsing_c.al_inh_expr b
364 | Ast_c.MetaExprListVal a
, Ast_c.MetaExprListVal b
->
365 Lib_parsing_c.al_inh_arguments a
=*= Lib_parsing_c.al_inh_arguments b
367 | Ast_c.MetaDeclVal a
, Ast_c.MetaDeclVal b
->
368 Lib_parsing_c.al_inh_declaration a
=*= Lib_parsing_c.al_inh_declaration b
369 | Ast_c.MetaFieldVal a
, Ast_c.MetaFieldVal b
->
370 Lib_parsing_c.al_inh_field a
=*= Lib_parsing_c.al_inh_field b
371 | Ast_c.MetaStmtVal a
, Ast_c.MetaStmtVal b
->
372 Lib_parsing_c.al_inh_statement a
=*= Lib_parsing_c.al_inh_statement b
373 | Ast_c.MetaInitVal a
, Ast_c.MetaInitVal b
->
374 Lib_parsing_c.al_inh_init a
=*= Lib_parsing_c.al_inh_init b
375 | Ast_c.MetaTypeVal a
, Ast_c.MetaTypeVal b
->
376 (* old: Lib_parsing_c.al_inh_type a =*= Lib_parsing_c.al_inh_type b *)
379 | Ast_c.MetaListlenVal a
, Ast_c.MetaListlenVal b
-> a
=|= b
381 | Ast_c.MetaParamVal a
, Ast_c.MetaParamVal b
->
382 Lib_parsing_c.al_param a
=*= Lib_parsing_c.al_param b
383 | Ast_c.MetaParamListVal a
, Ast_c.MetaParamListVal b
->
384 Lib_parsing_c.al_params a
=*= Lib_parsing_c.al_params b
386 | Ast_c.MetaPosVal
(posa1
,posa2
), Ast_c.MetaPosVal
(posb1
,posb2
) ->
387 Ast_cocci.equal_pos posa1 posb1
&& Ast_cocci.equal_pos posa2 posb2
389 | Ast_c.MetaPosValList l1
, Ast_c.MetaPosValList l2
->
391 (function (fla
,cea
,posa1
,posa2
) ->
393 (function (flb
,ceb
,posb1
,posb2
) ->
394 fla
=$
= flb
&& cea
=$
= ceb
&&
395 Ast_c.equal_posl posa1 posb1
&& Ast_c.equal_posl posa2 posb2
)
399 | (B.MetaPosValList _
|B.MetaListlenVal _
|B.MetaPosVal _
|B.MetaStmtVal _
400 |B.MetaDeclVal _
|B.MetaFieldVal _
|B.MetaTypeVal _
|B.MetaInitVal _
401 |B.MetaParamListVal _
|B.MetaParamVal _
|B.MetaExprListVal _
402 |B.MetaExprVal _
|B.MetaLocalFuncVal _
|B.MetaFuncVal _
|B.MetaIdVal _
407 (*---------------------------------------------------------------------------*)
408 (* could put in ast_c.ml, next to the split/unsplit_comma *)
409 let split_signb_baseb_ii (baseb
, ii
) =
410 let iis = ii
+> List.map
(fun info
-> (B.str_of_info info
), info
) in
411 match baseb
, iis with
413 | B.Void
, ["void",i1
] -> None
, [i1
]
415 | B.FloatType
(B.CFloat
),["float",i1
] -> None
, [i1
]
416 | B.FloatType
(B.CDouble
),["double",i1
] -> None
, [i1
]
417 | B.FloatType
(B.CLongDouble
),["long",i1
;"double",i2
] -> None
,[i1
;i2
]
419 | B.IntType
(B.CChar
), ["char",i1
] -> None
, [i1
]
422 | B.IntType
(B.Si
(sign
, base
)), xs
->
426 | (B.Signed
,(("signed",i1
)::rest
)) -> (Some
(B.Signed
,i1
),rest
)
427 | (B.Signed
,rest
) -> (None
,rest
)
428 | (B.UnSigned
,(("unsigned",i1
)::rest
)) -> (Some
(B.UnSigned
,i1
),rest
)
429 | (B.UnSigned
,rest
) -> (* is this case possible? *) (None
,rest
) in
430 (* The original code only allowed explicit signed and unsigned for char,
431 while this code allows char by itself. Not sure that needs to be
432 checked for here. If it does, then add a special case. *)
434 match (base
,rest
) with
435 B.CInt
, ["int",i1
] -> [i1
]
438 | B.CInt
, ["",i1
] -> (* no type is specified at all *)
439 (match i1
.B.pinfo
with
441 | _
-> failwith
("unrecognized signed int: "^
442 (String.concat
" "(List.map fst
iis))))
444 | B.CChar2
, ["char",i2
] -> [i2
]
446 | B.CShort
, ["short",i1
] -> [i1
]
447 | B.CShort
, ["short",i1
;"int",i2
] -> [i1
;i2
]
449 | B.CLong
, ["long",i1
] -> [i1
]
450 | B.CLong
, ["long",i1
;"int",i2
] -> [i1
;i2
]
452 | B.CLongLong
, ["long",i1
;"long",i2
] -> [i1
;i2
]
453 | B.CLongLong
, ["long",i1
;"long",i2
;"int",i3
] -> [i1
;i2
;i3
]
456 failwith
("strange type1, maybe because of weird order: "^
457 (String.concat
" " (List.map fst
iis))) in
460 | B.SizeType
, ["size_t",i1
] -> None
, [i1
]
461 | B.SSizeType
, ["ssize_t",i1
] -> None
, [i1
]
462 | B.PtrDiffType
, ["ptrdiff_t",i1
] -> None
, [i1
]
464 | _
-> failwith
("strange type2, maybe because of weird order: "^
465 (String.concat
" " (List.map fst
iis)))
467 (*---------------------------------------------------------------------------*)
469 let rec unsplit_icomma xs
=
473 (match A.unwrap y
with
475 (x
, y
)::unsplit_icomma xs
476 | _
-> failwith
"wrong ast_cocci in initializer"
479 failwith
("wrong ast_cocci in initializer, should have pair " ^
484 let resplit_initialiser ibs iicomma
=
485 match iicomma
, ibs
with
488 failwith
"should have a iicomma, do you generate fakeInfo in parser?"
490 failwith
"shouldn't have a iicomma"
491 | [iicomma
], x
::xs
->
492 let elems = List.map fst
(x
::xs
) in
493 let commas = List.map snd
(x
::xs
) +> List.flatten
in
494 let commas = commas @ [iicomma
] in
496 | _
-> raise Impossible
500 let rec split_icomma xs
=
503 | (x
,y
)::xs
-> x
::y
::split_icomma xs
505 let rec unsplit_initialiser ibs_unsplit
=
506 match ibs_unsplit
with
507 | [] -> [], [] (* empty iicomma *)
509 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
510 (x
, [])::xs
, lastcomma
512 and unsplit_initialiser_bis comma_before
= function
513 | [] -> [], [comma_before
]
515 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
516 (x
, [comma_before
])::xs
, lastcomma
521 (*---------------------------------------------------------------------------*)
522 (* coupling: same in type_annotater_c.ml *)
523 let structdef_to_struct_name ty
=
525 | qu
, (B.StructUnion
(su
, sopt
, fields
), iis) ->
527 | Some s
, [i1
;i2
;i3
;i4
] ->
528 qu
, (B.StructUnionName
(su
, s
), [i1
;i2
])
532 | x
-> raise Impossible
534 | _
-> raise Impossible
536 (*---------------------------------------------------------------------------*)
537 let one_initialisation_to_affectation x
=
538 let ({B.v_namei
= var
;
539 B.v_type
= returnType
;
540 B.v_type_bis
= tybis
;
541 B.v_storage
= storage
;
545 | Some
(name
, iniopt
) ->
547 | Some
(iini
, (B.InitExpr e
, ii_empty2
)) ->
550 Ast_c.NotLocalDecl
-> Ast_c.NotLocalVar
552 Ast_c.LocalVar
(Ast_c.info_of_type returnType
) in
554 (* old: Lib_parsing_c.al_type returnType
555 * but this type has not the typename completed so
556 * instead try to use tybis
559 | Some ty_with_typename_completed
-> ty_with_typename_completed
560 | None
-> raise Impossible
563 let typ = ref (Some
(typexp,local), Ast_c.NotTest
) in
565 let idexpr = Ast_c.mk_e_bis
(B.Ident
ident) typ Ast_c.noii
in
567 Ast_c.mk_e
(B.Assignment
(idexpr,B.SimpleAssign
, e
)) [iini
] in
572 let initialisation_to_affectation decl
=
574 | B.MacroDecl _
-> F.Decl decl
575 | B.DeclList
(xs
, iis) ->
577 (* todo?: should not do that if the variable is an array cos
578 * will have x[] = , mais de toute facon ca sera pas un InitExp
580 let possible_assignment =
584 match prev
,one_initialisation_to_affectation x
with
586 | None
,Some x
-> Some x
587 | Some prev
,Some x
->
588 (* [] is clearly an invalid ii value for a sequence.
589 hope that no one looks at it, since nothing will
590 match the sequence. Fortunately, SmPL doesn't
591 support , expressions. *)
592 Some
(Ast_c.mk_e
(Ast_c.Sequence
(prev
, x
)) []))
594 match possible_assignment with
595 Some x
-> F.DefineExpr x
596 | None
-> F.Decl decl
598 (*****************************************************************************)
599 (* Functor parameter combinators *)
600 (*****************************************************************************)
602 * src: papers on parser combinators in haskell (cf a pearl by meijer in ICFP)
604 * version0: was not tagging the SP, so just tag the C
606 * (tin -> 'c tout) -> ('c -> (tin -> 'b tout)) -> (tin -> 'b tout)
607 * val return : 'b -> tin -> 'b tout
608 * val fail : tin -> 'b tout
610 * version1: now also tag the SP so return a ('a * 'b)
613 type mode
= PatternMode
| TransformMode
621 type ('a
, 'b
) matcher
= 'a
-> 'b
-> tin
-> ('a
* 'b
) tout
626 (tin
-> ('a
* 'b
) tout
) ->
627 ('a
-> 'b
-> (tin
-> ('c
* 'd
) tout
)) ->
628 (tin
-> ('c
* 'd
) tout
)
630 val return
: ('a
* 'b
) -> tin
-> ('a
*'b
) tout
631 val fail
: tin
-> ('a
* 'b
) tout
643 val (>&&>) : (tin
-> bool) -> (tin
-> 'x tout
) -> (tin
-> 'x tout
)
645 val tokenf
: ('a
A.mcode
, B.info
) matcher
646 val tokenf_mck
: (A.mcodekind, B.info
) matcher
649 (A.meta_name
A.mcode
, B.expression
) matcher
651 (A.meta_name
A.mcode
, (Ast_c.argument
, Ast_c.il
) either list
) matcher
653 (A.meta_name
A.mcode
, Ast_c.fullType
) matcher
655 (A.meta_name
A.mcode
,
656 (Ast_c.parameterType
, Ast_c.il
) either list
) matcher
658 (A.meta_name
A.mcode
, Ast_c.parameterType
) matcher
660 (A.meta_name
A.mcode
, Ast_c.initialiser
) matcher
662 (A.meta_name
A.mcode
, (Ast_c.initialiser
, Ast_c.il
) either list
) matcher
664 (A.meta_name
A.mcode
, Ast_c.declaration
) matcher
666 (A.meta_name
A.mcode
, Ast_c.field
) matcher
668 (A.meta_name
A.mcode
, Control_flow_c.node
) matcher
670 val distrf_define_params
:
671 (A.meta_name
A.mcode
, (string Ast_c.wrap
, Ast_c.il
) either list
) matcher
673 val distrf_enum_fields
:
674 (A.meta_name
A.mcode
, (B.oneEnumType
, B.il
) either list
) matcher
676 val distrf_struct_fields
:
677 (A.meta_name
A.mcode
, B.field list
) matcher
680 (A.meta_name
A.mcode
, (B.constant
, string) either
B.wrap
) matcher
683 (A.expression
, B.expression
) matcher
-> (A.expression
, F.node
) matcher
686 (A.expression
, B.expression
) matcher
->
687 (A.expression
, B.expression
) matcher
690 (A.fullType
, B.fullType
) matcher
-> (A.fullType
, F.node
) matcher
693 (A.initialiser
, B.initialiser
) matcher
-> (A.initialiser
, F.node
) matcher
696 A.keep_binding
-> A.inherited
->
697 A.meta_name
A.mcode
* Ast_c.metavar_binding_kind
*
698 (unit -> Common.filename
* string * Ast_c.posl
* Ast_c.posl
) ->
699 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
701 val check_idconstraint
:
702 ('a
-> 'b
-> bool) -> 'a
-> 'b
->
703 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
705 val check_constraints_ne
:
706 ('a
, 'b
) matcher
-> 'a list
-> 'b
->
707 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
709 val all_bound
: A.meta_name list
-> (tin
-> bool)
711 val optional_storage_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
712 val optional_qualifier_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
713 val value_format_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
718 (*****************************************************************************)
719 (* Functor code, "Cocci vs C" *)
720 (*****************************************************************************)
723 functor (X
: PARAM
) ->
726 type ('a
, 'b
) matcher
= 'a
-> 'b
-> X.tin
-> ('a
* 'b
) X.tout
729 let return = X.return
732 let (>||>) = X.(>||>)
733 let (>|+|>) = X.(>|+|>)
734 let (>&&>) = X.(>&&>)
736 let tokenf = X.tokenf
738 (* should be raise Impossible when called from transformation.ml *)
741 | PatternMode
-> fail
742 | TransformMode
-> raise Impossible
745 let (option: ('a
,'b
) matcher
-> ('a
option,'b
option) matcher
)= fun f t1 t2
->
747 | (Some t1
, Some t2
) ->
748 f t1 t2
>>= (fun t1 t2
->
749 return (Some t1
, Some t2
)
751 | (None
, None
) -> return (None
, None
)
754 (* Dots are sometimes used as metavariables, since like metavariables they
755 can match other things. But they no longer have the same type. Perhaps these
756 functions could be avoided by introducing an appropriate level of polymorphism,
757 but I don't know how to declare polymorphism across functors *)
758 let dots2metavar (_
,info
,mcodekind,pos
) =
759 (("","..."),info
,mcodekind,pos
)
760 let metavar2dots (_
,info
,mcodekind,pos
) = ("...",info
,mcodekind,pos
)
762 let satisfies_regexpconstraint c id
: bool =
764 A.IdRegExp
(_
,recompiled
) -> Str.string_match recompiled id
0
765 | A.IdNotRegExp
(_
,recompiled
) -> not
(Str.string_match recompiled id
0)
767 let satisfies_iconstraint c id
: bool =
770 let satisfies_econstraint c exp
: bool =
771 let warning s
= pr2_once
("WARNING: "^s
); false in
772 match Ast_c.unwrap_expr exp
with
773 Ast_c.Ident
(name
) ->
775 Ast_c.RegularName rname
->
776 satisfies_regexpconstraint c
(Ast_c.unwrap_st rname
)
777 | Ast_c.CppConcatenatedName _
->
779 "Unable to apply a constraint on a CppConcatenatedName identifier!"
780 | Ast_c.CppVariadicName _
->
782 "Unable to apply a constraint on a CppVariadicName identifier!"
783 | Ast_c.CppIdentBuilder _
->
785 "Unable to apply a constraint on a CppIdentBuilder identifier!")
786 | Ast_c.Constant cst
->
788 | Ast_c.String
(str
, _
) -> satisfies_regexpconstraint c str
789 | Ast_c.MultiString strlist
->
790 warning "Unable to apply a constraint on an multistring constant!"
791 | Ast_c.Char
(char
, _
) -> satisfies_regexpconstraint c char
792 | Ast_c.Int
(int , _
) -> satisfies_regexpconstraint c
int
793 | Ast_c.Float
(float, _
) -> satisfies_regexpconstraint c
float)
794 | _
-> warning "Unable to apply a constraint on an expression!"
797 (* ------------------------------------------------------------------------- *)
798 (* This has to be up here to allow adequate polymorphism *)
800 let list_matcher match_dots rebuild_dots match_comma rebuild_comma
801 match_metalist rebuild_metalist mktermval special_cases
802 element distrf get_iis
= fun eas ebs
->
803 let rec loop = function
804 [], [] -> return ([], [])
805 | [], eb
::ebs
-> fail
807 X.all_bound
(A.get_inherited ea
) >&&>
809 (match match_dots ea
, ebs
with
810 Some
(mcode
, optexpr
), ys
->
811 (* todo: if optexpr, then a WHEN and so may have to filter yys *)
812 if optexpr
<> None
then failwith
"not handling when in a list";
814 (* '...' can take more or less the beginnings of the arguments *)
816 Common.zip
(Common.inits ys
) (Common.tails ys
) in
818 (startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
821 (* allow '...', and maybe its associated ',' to match nothing.
822 * for the associated ',' see below how we handle the EComma
827 if mcode_contain_plus (mcodekind mcode
)
830 "I have no token that I could accroche myself on"*)
831 else return (dots2metavar mcode
, [])
833 (* subtil: we dont want the '...' to match until the
834 * comma. cf -test pb_params_iso. We would get at
835 * "already tagged" error.
836 * this is because both f (... x, ...) and f (..., x, ...)
837 * would match a f(x,3) with our "optional-comma" strategy.
839 (match Common.last startxs
with
841 | Left _
-> distrf
(dots2metavar mcode
) startxs
))
843 >>= (fun mcode startxs
->
844 let mcode = metavar2dots mcode in
845 loop (eas
, endxs
) >>= (fun eas endxs
->
847 (rebuild_dots
(mcode, optexpr
) +> A.rewrap ea
) ::eas
,
855 (match match_comma ea
, ebs
with
856 | Some ia1
, Right ii
::ebs
->
858 (let ib1 = tuple_of_list1 ii
in
859 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
860 loop (eas
, ebs
) >>= (fun eas ebs
->
862 (rebuild_comma ia1
+> A.rewrap ea
)::eas
,
867 (* allow ',' to maching nothing. optional comma trick *)
869 (if mcode_contain_plus (mcodekind ia1
)
871 else loop (eas
, ebs
))
874 (match match_metalist ea
, ebs
with
875 Some
(ida
,leninfo
,keep
,inherited
), ys
->
877 Common.zip
(Common.inits ys
) (Common.tails ys
) in
879 (startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
884 if mcode_contain_plus (mcodekind ida
)
886 (* failwith "no token that I could accroche myself on" *)
889 (match Common.last startxs
with
896 let startxs'
= Ast_c.unsplit_comma
startxs in
897 let len = List.length
startxs'
in
900 | A.MetaListLen
(lenname
,lenkeep
,leninherited
) ->
901 let max_min _
= failwith
"no pos" in
902 X.envf lenkeep leninherited
903 (lenname
, Ast_c.MetaListlenVal
(len), max_min)
906 then (function f
-> f
())
907 else (function f
-> fail)
908 | A.AnyListLen
-> function f
-> f
()
912 Lib_parsing_c.lin_col_by_pos
(get_iis
startxs) in
913 X.envf keep inherited
914 (ida
, mktermval
startxs'
, max_min)
917 then return (ida
, [])
918 else distrf ida
(Ast_c.split_comma
startxs'
))
919 >>= (fun ida
startxs ->
920 loop (eas
, endxs
) >>= (fun eas endxs
->
922 (rebuild_metalist
(ida
,leninfo
,keep
,inherited
))
931 special_cases ea eas ebs
in
932 match try_matches with
937 element ea eb
>>= (fun ea eb
->
938 loop (eas
, ebs
) >>= (fun eas ebs
->
939 return (ea
::eas
, Left eb
::ebs
)))
940 | (Right y
)::ys
-> raise Impossible
944 (*---------------------------------------------------------------------------*)
956 (*---------------------------------------------------------------------------*)
957 let rec (expression
: (A.expression
, Ast_c.expression
) matcher
) =
959 if A.get_test_exp ea
&& not
(Ast_c.is_test eb
) then fail
961 X.all_bound
(A.get_inherited ea
) >&&>
962 let wa x
= A.rewrap ea x
in
963 match A.unwrap ea
, eb
with
965 (* general case: a MetaExpr can match everything *)
966 | A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
),
967 (((expr
, opttypb
), ii
) as expb
) ->
969 (* old: before have a MetaConst. Now we factorize and use 'form' to
970 * differentiate between different cases *)
971 let rec matches_id = function
972 B.Ident
(name
) -> true
973 | B.Cast
(ty
,e
) -> matches_id (B.unwrap_expr e
)
976 match (form
,expr
) with
979 let rec matches = function
980 B.Constant
(c
) -> true
981 | B.Ident
(nameidb
) ->
982 let s = Ast_c.str_of_name nameidb
in
983 if s =~
"^[A-Z_][A-Z_0-9]*$"
985 pr2_once
("warning: " ^
s ^
" treated as a constant");
989 | B.Cast
(ty
,e
) -> matches (B.unwrap_expr e
)
990 | B.Unary
(e
,B.UnMinus
) -> matches (B.unwrap_expr e
)
991 | B.SizeOfExpr
(exp
) -> true
992 | B.SizeOfType
(ty
) -> true
998 (Some
(_
,Ast_c.LocalVar _
),_
) -> true
1000 | (A.ID
,e
) -> matches_id e
in
1004 (let (opttypb
,_testb
) = !opttypb
in
1005 match opttypa
, opttypb
with
1006 | None
, _
-> return ((),())
1008 pr2_once
("Missing type information. Certainly a pb in " ^
1009 "annotate_typer.ml");
1012 | Some tas
, Some tb
->
1013 tas
+> List.fold_left
(fun acc ta
->
1014 acc
>|+|> compatible_type ta tb
) fail
1017 let meta_expr_val l x
= Ast_c.MetaExprVal
(x
,l
) in
1018 match constraints
with
1019 Ast_cocci.NoConstraint
-> return (meta_expr_val [],())
1020 | Ast_cocci.NotIdCstrt cstrt
->
1021 X.check_idconstraint
satisfies_econstraint cstrt eb
1022 (fun () -> return (meta_expr_val [],()))
1023 | Ast_cocci.NotExpCstrt cstrts
->
1024 X.check_constraints_ne expression cstrts eb
1025 (fun () -> return (meta_expr_val [],()))
1026 | Ast_cocci.SubExpCstrt cstrts
->
1027 return (meta_expr_val cstrts
,()))
1031 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_expr expb
) in
1032 X.envf keep inherited
(ida
, wrapper expb
, max_min)
1034 X.distrf_e ida expb
>>=
1037 A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
)+>
1045 * | A.MetaExpr(ida,false,opttypa,_inherited), expb ->
1046 * D.distribute_mck (mcodekind ida) D.distribute_mck_e expb binding
1048 * but bug! because if have not tagged SP, then transform without doing
1049 * any checks. Hopefully now have tagged SP technique.
1054 * | A.Edots _, _ -> raise Impossible.
1056 * In fact now can also have the Edots inside normal expression, not
1057 * just in arg lists. in 'x[...];' less: in if(<... x ... y ...>)
1059 | A.Edots
(mcode, None
), expb
->
1060 X.distrf_e
(dots2metavar mcode) expb
>>= (fun mcode expb
->
1062 A.Edots
(metavar2dots mcode, None
) +> A.rewrap ea
,
1067 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
1070 | A.Ident ida
, ((B.Ident
(nameidb
), typ),noii
) ->
1072 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1074 ((A.Ident ida
)) +> wa,
1075 ((B.Ident
(nameidb
), typ),Ast_c.noii
)
1081 | A.MetaErr _
, _
-> failwith
"not handling MetaErr"
1083 (* todo?: handle some isomorphisms in int/float ? can have different
1084 * format : 1l can match a 1.
1086 * todo: normally string can contain some metavar too, so should
1087 * recurse on the string
1089 | A.Constant
(ia1
), ((B.Constant
(ib
) , typ),ii
) ->
1090 (* for everything except the String case where can have multi elems *)
1092 let ib1 = tuple_of_list1 ii
in
1093 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1095 ((A.Constant ia1
)) +> wa,
1096 ((B.Constant
(ib
), typ),[ib1])
1099 (match term ia1
, ib
with
1100 | A.Int x
, B.Int
(y
,_
) ->
1101 X.value_format_flag
(fun use_value_equivalence
->
1102 if use_value_equivalence
1112 | A.Char x
, B.Char
(y
,_
) when x
=$
= y
(* todo: use kind ? *)
1114 | A.Float x
, B.Float
(y
,_
) when x
=$
= y
(* todo: use floatType ? *)
1117 | A.String sa
, B.String
(sb
,_kind
) when sa
=$
= sb
->
1120 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1122 ((A.Constant ia1
)) +> wa,
1123 ((B.Constant
(ib
), typ),[ib1])
1125 | _
-> fail (* multi string, not handled *)
1128 | _
, B.MultiString _
-> (* todo cocci? *) fail
1129 | _
, (B.String _
| B.Float _
| B.Char _
| B.Int _
) -> fail
1133 | A.FunCall
(ea
, ia1
, eas
, ia2
), ((B.FunCall
(eb
, ebs
), typ),ii
) ->
1134 (* todo: do special case to allow IdMetaFunc, cos doing the
1135 * recursive call will be too late, match_ident will not have the
1136 * info whether it was a function. todo: but how detect when do
1137 * x.field = f; how know that f is a Func ? By having computed
1138 * some information before the matching!
1140 * Allow match with FunCall containing types. Now ast_cocci allow
1141 * type in parameter, and morover ast_cocci allow f(...) and those
1142 * ... could match type.
1144 let (ib1, ib2
) = tuple_of_list2 ii
in
1145 expression ea eb
>>= (fun ea eb
->
1146 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1147 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1148 arguments
(seqstyle eas
) (A.undots eas
) ebs
>>= (fun easundots ebs
->
1149 let eas = redots
eas easundots
in
1151 ((A.FunCall
(ea
, ia1
, eas, ia2
)) +> wa,
1152 ((B.FunCall
(eb
, ebs
),typ), [ib1;ib2
])
1158 | A.Assignment
(ea1
, opa
, ea2
, simple
),
1159 ((B.Assignment
(eb1
, opb
, eb2
), typ),ii
) ->
1160 let (opbi
) = tuple_of_list1 ii
in
1161 if equal_assignOp (term opa
) opb
1163 expression ea1 eb1
>>= (fun ea1 eb1
->
1164 expression ea2 eb2
>>= (fun ea2 eb2
->
1165 tokenf opa opbi
>>= (fun opa opbi
->
1167 (A.Assignment
(ea1
, opa
, ea2
, simple
)) +> wa,
1168 ((B.Assignment
(eb1
, opb
, eb2
), typ), [opbi
])
1172 | A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
),((B.CondExpr
(eb1
,eb2opt
,eb3
),typ),ii
) ->
1173 let (ib1, ib2
) = tuple_of_list2 ii
in
1174 expression ea1 eb1
>>= (fun ea1 eb1
->
1175 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
1176 expression ea3 eb3
>>= (fun ea3 eb3
->
1177 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1178 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1180 ((A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
))) +> wa,
1181 ((B.CondExpr
(eb1
, eb2opt
, eb3
),typ), [ib1;ib2
])
1184 (* todo?: handle some isomorphisms here ? *)
1185 | A.Postfix
(ea
, opa
), ((B.Postfix
(eb
, opb
), typ),ii
) ->
1186 let opbi = tuple_of_list1 ii
in
1187 if equal_fixOp (term opa
) opb
1189 expression ea eb
>>= (fun ea eb
->
1190 tokenf opa
opbi >>= (fun opa
opbi ->
1192 ((A.Postfix
(ea
, opa
))) +> wa,
1193 ((B.Postfix
(eb
, opb
), typ),[opbi])
1198 | A.Infix
(ea
, opa
), ((B.Infix
(eb
, opb
), typ),ii
) ->
1199 let opbi = tuple_of_list1 ii
in
1200 if equal_fixOp (term opa
) opb
1202 expression ea eb
>>= (fun ea eb
->
1203 tokenf opa
opbi >>= (fun opa
opbi ->
1205 ((A.Infix
(ea
, opa
))) +> wa,
1206 ((B.Infix
(eb
, opb
), typ),[opbi])
1210 | A.Unary
(ea
, opa
), ((B.Unary
(eb
, opb
), typ),ii
) ->
1211 let opbi = tuple_of_list1 ii
in
1212 if equal_unaryOp (term opa
) opb
1214 expression ea eb
>>= (fun ea eb
->
1215 tokenf opa
opbi >>= (fun opa
opbi ->
1217 ((A.Unary
(ea
, opa
))) +> wa,
1218 ((B.Unary
(eb
, opb
), typ),[opbi])
1222 | A.Binary
(ea1
, opa
, ea2
), ((B.Binary
(eb1
, opb
, eb2
), typ),ii
) ->
1223 let opbi = tuple_of_list1 ii
in
1224 if equal_binaryOp (term opa
) opb
1226 expression ea1 eb1
>>= (fun ea1 eb1
->
1227 expression ea2 eb2
>>= (fun ea2 eb2
->
1228 tokenf opa
opbi >>= (fun opa
opbi ->
1230 ((A.Binary
(ea1
, opa
, ea2
))) +> wa,
1231 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1235 | A.Nested
(ea1
, opa
, ea2
), eb
->
1237 expression ea1 eb
>|+|>
1239 ((B.Binary
(eb1
, opb
, eb2
), typ),ii
)
1240 when equal_binaryOp (term opa
) opb
->
1241 let opbi = tuple_of_list1 ii
in
1243 (expression ea1 eb1
>>= (fun ea1 eb1
->
1244 expression ea2 eb2
>>= (fun ea2 eb2
->
1245 tokenf opa
opbi >>= (fun opa
opbi ->
1247 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1248 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1251 (expression ea2 eb1
>>= (fun ea2 eb1
->
1252 expression ea1 eb2
>>= (fun ea1 eb2
->
1253 tokenf opa
opbi >>= (fun opa
opbi ->
1255 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1256 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1259 (loop eb1
>>= (fun ea1 eb1
->
1260 expression ea2 eb2
>>= (fun ea2 eb2
->
1261 tokenf opa
opbi >>= (fun opa
opbi ->
1263 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1264 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1267 (expression ea2 eb1
>>= (fun ea2 eb1
->
1268 loop eb2
>>= (fun ea1 eb2
->
1269 tokenf opa
opbi >>= (fun opa
opbi ->
1271 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1272 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1274 left_to_right >|+|> right_to_left >|+|> in_left >|+|> in_right
1278 (* todo?: handle some isomorphisms here ? (with pointers = Unary Deref) *)
1279 | A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
),((B.ArrayAccess
(eb1
, eb2
), typ),ii
) ->
1280 let (ib1, ib2
) = tuple_of_list2 ii
in
1281 expression ea1 eb1
>>= (fun ea1 eb1
->
1282 expression ea2 eb2
>>= (fun ea2 eb2
->
1283 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1284 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1286 ((A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
))) +> wa,
1287 ((B.ArrayAccess
(eb1
, eb2
),typ), [ib1;ib2
])
1290 (* todo?: handle some isomorphisms here ? *)
1291 | A.RecordAccess
(ea
, ia1
, ida
), ((B.RecordAccess
(eb
, idb
), typ),ii
) ->
1292 let (ib1) = tuple_of_list1 ii
in
1293 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
1294 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1295 expression ea eb
>>= (fun ea eb
->
1297 ((A.RecordAccess
(ea
, ia1
, ida
))) +> wa,
1298 ((B.RecordAccess
(eb
, idb
), typ), [ib1])
1303 | A.RecordPtAccess
(ea
,ia1
,ida
),((B.RecordPtAccess
(eb
, idb
), typ), ii
) ->
1304 let (ib1) = tuple_of_list1 ii
in
1305 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
1306 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1307 expression ea eb
>>= (fun ea eb
->
1309 ((A.RecordPtAccess
(ea
, ia1
, ida
))) +> wa,
1310 ((B.RecordPtAccess
(eb
, idb
), typ), [ib1])
1314 (* todo?: handle some isomorphisms here ?
1315 * todo?: do some iso-by-absence on cast ?
1316 * by trying | ea, B.Case (typb, eb) -> match_e_e ea eb ?
1319 | A.Cast
(ia1
, typa
, ia2
, ea
), ((B.Cast
(typb
, eb
), typ),ii
) ->
1320 let (ib1, ib2
) = tuple_of_list2 ii
in
1321 fullType typa typb
>>= (fun typa typb
->
1322 expression ea eb
>>= (fun ea eb
->
1323 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1324 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1326 ((A.Cast
(ia1
, typa
, ia2
, ea
))) +> wa,
1327 ((B.Cast
(typb
, eb
),typ),[ib1;ib2
])
1330 | A.SizeOfExpr
(ia1
, ea
), ((B.SizeOfExpr
(eb
), typ),ii
) ->
1331 let ib1 = tuple_of_list1 ii
in
1332 expression ea eb
>>= (fun ea eb
->
1333 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1335 ((A.SizeOfExpr
(ia1
, ea
))) +> wa,
1336 ((B.SizeOfExpr
(eb
), typ),[ib1])
1339 | A.SizeOfType
(ia1
, ia2
, typa
, ia3
), ((B.SizeOfType typb
, typ),ii
) ->
1340 let (ib1,ib2
,ib3
) = tuple_of_list3 ii
in
1341 fullType typa typb
>>= (fun typa typb
->
1342 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1343 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1344 tokenf ia3 ib3
>>= (fun ia3 ib3
->
1346 ((A.SizeOfType
(ia1
, ia2
, typa
, ia3
))) +> wa,
1347 ((B.SizeOfType
(typb
),typ),[ib1;ib2
;ib3
])
1351 (* todo? iso ? allow all the combinations ? *)
1352 | A.Paren
(ia1
, ea
, ia2
), ((B.ParenExpr
(eb
), typ),ii
) ->
1353 let (ib1, ib2
) = tuple_of_list2 ii
in
1354 expression ea eb
>>= (fun ea eb
->
1355 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1356 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1358 ((A.Paren
(ia1
, ea
, ia2
))) +> wa,
1359 ((B.ParenExpr
(eb
), typ), [ib1;ib2
])
1362 | A.NestExpr
(starter
,exps
,ender
,None
,true), eb
->
1363 (match A.get_mcodekind starter
with
1364 A.MINUS _
-> failwith
"TODO: only context nests supported"
1366 (match A.unwrap exps
with
1368 X.cocciExpExp expression exp eb
>>= (fun exp eb
->
1371 (starter
,A.rewrap exps
(A.DOTS
[exp
]),ender
,None
,true)) +> wa,
1377 "for nestexpr, only handling the case with dots and only one exp")
1379 | A.NestExpr _
, _
->
1380 failwith
"only handling multi and no when code in a nest expr"
1382 (* only in arg lists or in define body *)
1383 | A.TypeExp _
, _
-> fail
1385 (* only in arg lists *)
1386 | A.MetaExprList _
, _
1393 | A.DisjExpr
eas, eb
->
1394 eas +> List.fold_left
(fun acc ea
-> acc
>|+|> (expression ea eb
)) fail
1396 | A.UniqueExp _
,_
| A.OptExp _
,_
->
1397 failwith
"not handling Opt/Unique/Multi on expr"
1399 (* Because of Exp cant put a raise Impossible; have to put a fail *)
1401 (* have not a counter part in coccinelle, for the moment *)
1402 | _
, ((B.Sequence _
,_
),_
)
1403 | _
, ((B.StatementExpr _
,_
),_
)
1404 | _
, ((B.Constructor _
,_
),_
)
1409 (((B.Cast
(_
, _
)|B.ParenExpr _
|B.SizeOfType _
|B.SizeOfExpr _
|
1410 B.RecordPtAccess
(_
, _
)|
1411 B.RecordAccess
(_
, _
)|B.ArrayAccess
(_
, _
)|
1412 B.Binary
(_
, _
, _
)|B.Unary
(_
, _
)|
1413 B.Infix
(_
, _
)|B.Postfix
(_
, _
)|
1414 B.Assignment
(_
, _
, _
)|B.CondExpr
(_
, _
, _
)|
1415 B.FunCall
(_
, _
)|B.Constant _
|B.Ident _
),
1423 (* ------------------------------------------------------------------------- *)
1424 and (ident_cpp
: info_ident
-> (A.ident, B.name
) matcher
) =
1425 fun infoidb ida idb
->
1427 | B.RegularName
(s, iis) ->
1428 let iis = tuple_of_list1
iis in
1429 ident infoidb ida
(s, iis) >>= (fun ida
(s,iis) ->
1432 (B.RegularName
(s, [iis]))
1434 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
1436 (* This should be moved to the Id case of ident. Metavariables
1437 should be allowed to be bound to such variables. But doing so
1438 would require implementing an appropriate distr function *)
1441 and (ident: info_ident
-> (A.ident, string * Ast_c.info
) matcher
) =
1442 fun infoidb ida
((idb
, iib
)) -> (* (idb, iib) as ib *)
1443 let check_constraints constraints idb
=
1444 let meta_id_val l x
= Ast_c.MetaIdVal
(x
,l
) in
1445 match constraints
with
1446 A.IdNoConstraint
-> return (meta_id_val [],())
1447 | A.IdNegIdSet
(str
,meta
) ->
1448 X.check_idconstraint
satisfies_iconstraint str idb
1449 (fun () -> return (meta_id_val meta
,()))
1450 | A.IdRegExpConstraint re
->
1451 X.check_idconstraint
satisfies_regexpconstraint re idb
1452 (fun () -> return (meta_id_val [],())) in
1453 X.all_bound
(A.get_inherited ida
) >&&>
1454 match A.unwrap ida
with
1456 if (term sa
) =$
= idb
then
1457 tokenf sa iib
>>= (fun sa iib
->
1459 ((A.Id sa
)) +> A.rewrap ida
,
1464 | A.MetaId
(mida
,constraints
,keep
,inherited
) ->
1465 check_constraints constraints idb
>>=
1467 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1468 (* use drop_pos for ids so that the pos is not added a second time in
1469 the call to tokenf *)
1470 X.envf keep inherited
(A.drop_pos mida
, wrapper idb
, max_min)
1472 tokenf mida iib
>>= (fun mida iib
->
1474 ((A.MetaId
(mida
, constraints
, keep
, inherited
)) +> A.rewrap ida
,
1479 | A.MetaFunc
(mida
,constraints
,keep
,inherited
) ->
1481 check_constraints constraints idb
>>=
1483 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1484 X.envf keep inherited
(A.drop_pos mida
,Ast_c.MetaFuncVal idb
,max_min)
1486 tokenf mida iib
>>= (fun mida iib
->
1488 ((A.MetaFunc
(mida
,constraints
,keep
,inherited
)))+>A.rewrap ida
,
1493 | LocalFunction
| Function
-> is_function()
1495 failwith
"MetaFunc, need more semantic info about id"
1496 (* the following implementation could possibly be useful, if one
1497 follows the convention that a macro is always in capital letters
1498 and that a macro is not a function.
1499 (if idb =~ "^[A-Z_][A-Z_0-9]*$" then fail else is_function())*)
1502 | A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
) ->
1505 check_constraints constraints idb
>>=
1507 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1508 X.envf keep inherited
1509 (A.drop_pos mida
,Ast_c.MetaLocalFuncVal idb
, max_min)
1511 tokenf mida iib
>>= (fun mida iib
->
1513 ((A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
)))
1519 | DontKnow
-> failwith
"MetaLocalFunc, need more semantic info about id"
1522 | A.OptIdent _
| A.UniqueIdent _
->
1523 failwith
"not handling Opt/Unique for ident"
1525 (* ------------------------------------------------------------------------- *)
1526 and (arguments
: sequence
->
1527 (A.expression list
, Ast_c.argument
Ast_c.wrap2 list
) matcher
) =
1528 fun seqstyle eas ebs
->
1530 | Unordered
-> failwith
"not handling ooo"
1532 arguments_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1533 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1535 (* because '...' can match nothing, need to take care when have
1536 * ', ...' or '...,' as in f(..., X, Y, ...). It must match
1537 * f(1,2) for instance.
1538 * So I have added special cases such as (if startxs = []) and code
1539 * in the Ecomma matching rule.
1541 * old: Must do some try, for instance when f(...,X,Y,...) have to
1542 * test the transfo for all the combinaitions and if multiple transfo
1543 * possible ? pb ? => the type is to return a expression option ? use
1544 * some combinators to help ?
1545 * update: with the tag-SP approach, no more a problem.
1548 and arguments_bis
= fun eas ebs
->
1550 match A.unwrap ea
with
1551 A.Edots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
1553 let build_dots (mcode, optexpr
) = A.Edots
(mcode, optexpr
) in
1554 let match_comma ea
=
1555 match A.unwrap ea
with
1556 A.EComma ia1
-> Some ia1
1558 let build_comma ia1
= A.EComma ia1
in
1559 let match_metalist ea
=
1560 match A.unwrap ea
with
1561 A.MetaExprList
(ida
,leninfo
,keep
,inherited
) ->
1562 Some
(ida
,leninfo
,keep
,inherited
)
1564 let build_metalist (ida
,leninfo
,keep
,inherited
) =
1565 A.MetaExprList
(ida
,leninfo
,keep
,inherited
) in
1566 let mktermval v
= Ast_c.MetaExprListVal v
in
1567 let special_cases ea
eas ebs
= None
in
1568 list_matcher match_dots build_dots match_comma build_comma
1569 match_metalist build_metalist mktermval
1570 special_cases argument
X.distrf_args
1571 Lib_parsing_c.ii_of_args
eas ebs
1573 and argument arga argb
=
1574 X.all_bound
(A.get_inherited arga
) >&&>
1575 match A.unwrap arga
, argb
with
1577 Right
(B.ArgType
{B.p_register
=b
,iib
; p_namei
=sopt
;p_type
=tyb
}) ->
1578 if b
|| sopt
<> None
1580 (* failwith "the argument have a storage and ast_cocci does not have"*)
1583 (* b = false and sopt = None *)
1584 fullType tya tyb
>>= (fun tya tyb
->
1586 (A.TypeExp tya
) +> A.rewrap arga
,
1587 (Right
(B.ArgType
{B.p_register
=(b
,iib
);
1592 | A.TypeExp tya
, _
-> fail
1593 | _
, Right
(B.ArgType _
) -> fail
1595 expression arga argb
>>= (fun arga argb
->
1596 return (arga
, Left argb
)
1598 | _
, Right
(B.ArgAction y
) -> fail
1601 (* ------------------------------------------------------------------------- *)
1602 (* todo? facto code with argument ? *)
1603 and (parameters
: sequence
->
1604 (A.parameterTypeDef list
, Ast_c.parameterType
Ast_c.wrap2 list
)
1606 fun seqstyle eas ebs
->
1608 | Unordered
-> failwith
"not handling ooo"
1610 parameters_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1611 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1615 and parameters_bis
eas ebs
=
1617 match A.unwrap ea
with
1618 A.Pdots
(mcode) -> Some
(mcode, None
)
1620 let build_dots (mcode, _optexpr
) = A.Pdots
(mcode) in
1621 let match_comma ea
=
1622 match A.unwrap ea
with
1623 A.PComma ia1
-> Some ia1
1625 let build_comma ia1
= A.PComma ia1
in
1626 let match_metalist ea
=
1627 match A.unwrap ea
with
1628 A.MetaParamList
(ida
,leninfo
,keep
,inherited
) ->
1629 Some
(ida
,leninfo
,keep
,inherited
)
1631 let build_metalist (ida
,leninfo
,keep
,inherited
) =
1632 A.MetaParamList
(ida
,leninfo
,keep
,inherited
) in
1633 let mktermval v
= Ast_c.MetaParamListVal v
in
1634 let special_cases ea
eas ebs
=
1635 (* a case where one smpl parameter matches a list of C parameters *)
1636 match A.unwrap ea
,ebs
with
1637 A.VoidParam ta
, ys
->
1639 (match eas, ebs
with
1641 let {B.p_register
=(hasreg
,iihasreg
);
1643 p_type
=tb
; } = eb
in
1645 if idbopt
=*= None
&& not hasreg
1648 | (qub
, (B.BaseType
B.Void
,_
)) ->
1649 fullType ta tb
>>= (fun ta tb
->
1651 [(A.VoidParam ta
) +> A.rewrap ea
],
1652 [Left
{B.p_register
=(hasreg
, iihasreg
);
1660 list_matcher match_dots build_dots match_comma build_comma
1661 match_metalist build_metalist mktermval
1662 special_cases parameter
X.distrf_params
1663 Lib_parsing_c.ii_of_params
eas ebs
1666 let split_register_param = fun (hasreg, idb, ii_b_s) ->
1667 match hasreg, idb, ii_b_s with
1668 | false, Some s, [i1] -> Left (s, [], i1)
1669 | true, Some s, [i1;i2] -> Left (s, [i1], i2)
1670 | _, None, ii -> Right ii
1671 | _ -> raise Impossible
1675 and parameter
= fun parama paramb
->
1676 match A.unwrap parama
, paramb
with
1677 A.MetaParam
(ida
,keep
,inherited
), eb
->
1678 (* todo: use quaopt, hasreg ? *)
1680 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_param eb
) in
1681 X.envf keep inherited
(ida
,Ast_c.MetaParamVal eb
,max_min) (fun () ->
1682 X.distrf_param ida eb
1683 ) >>= (fun ida eb
->
1684 return (A.MetaParam
(ida
,keep
,inherited
)+> A.rewrap parama
,eb
))
1685 | A.Param
(typa
, idaopt
), eb
->
1686 let {B.p_register
= (hasreg
,iihasreg
);
1687 p_namei
= nameidbopt
;
1688 p_type
= typb
;} = paramb
in
1690 fullType typa typb
>>= (fun typa typb
->
1691 match idaopt
, nameidbopt
with
1692 | Some ida
, Some nameidb
->
1693 (* todo: if minus on ida, should also minus the iihasreg ? *)
1694 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1696 A.Param
(typa
, Some ida
)+> A.rewrap parama
,
1697 {B.p_register
= (hasreg
, iihasreg
);
1698 p_namei
= Some
(nameidb
);
1704 A.Param
(typa
, None
)+> A.rewrap parama
,
1705 {B.p_register
=(hasreg
,iihasreg
);
1709 (* why handle this case ? because of transform_proto ? we may not
1710 * have an ident in the proto.
1711 * If have some plus on ida ? do nothing about ida ?
1713 (* not anymore !!! now that julia is handling the proto.
1714 | _, Right iihasreg ->
1717 ((hasreg, None, typb), iihasreg)
1721 | Some _
, None
-> fail
1722 | None
, Some _
-> fail)
1723 | (A.OptParam _
| A.UniqueParam _
), _
->
1724 failwith
"not handling Opt/Unique for Param"
1725 | A.Pcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
1728 (* ------------------------------------------------------------------------- *)
1729 and (declaration
: (A.mcodekind * bool * A.declaration
,B.declaration
) matcher
) =
1730 fun (mckstart
, allminus
, decla
) declb
->
1731 X.all_bound
(A.get_inherited decla
) >&&>
1732 match A.unwrap decla
, declb
with
1734 (* Un MetaDecl est introduit dans l'asttoctl pour sauter au dessus
1735 * de toutes les declarations qui sont au debut d'un fonction et
1736 * commencer le reste du match au premier statement. Alors, ca matche
1737 * n'importe quelle declaration. On n'a pas besoin d'ajouter
1738 * quoi que ce soit dans l'environnement. C'est une sorte de DDots.
1740 * When the SP want to remove the whole function, the minus is not
1741 * on the MetaDecl but on the MetaRuleElem. So there should
1742 * be no transform of MetaDecl, just matching are allowed.
1745 | A.MetaDecl
(ida
,keep
,inherited
), _
->
1747 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_decl declb
) in
1748 X.envf keep inherited
(ida
, Ast_c.MetaDeclVal declb
, max_min) (fun () ->
1749 X.distrf_decl ida declb
1750 ) >>= (fun ida declb
->
1751 return ((mckstart
, allminus
,
1752 (A.MetaDecl
(ida
, keep
, inherited
))+> A.rewrap decla
),
1754 | _
, (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
)) ->
1755 onedecl allminus decla
(var
,iiptvirgb
,iisto
) >>=
1756 (fun decla
(var
,iiptvirgb
,iisto
)->
1757 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1759 (mckstart
, allminus
, decla
),
1760 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1763 | _
, (B.DeclList
(xs
, iiptvirgb
::iifakestart
::iisto
)) ->
1764 if X.mode
=*= PatternMode
1766 xs
+> List.fold_left
(fun acc var
->
1768 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1769 onedecl allminus decla
(var
, iiptvirgb
, iisto
) >>=
1770 (fun decla
(var
, iiptvirgb
, iisto
) ->
1772 (mckstart
, allminus
, decla
),
1773 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1777 failwith
"More that one variable in decl. Have to split to transform."
1779 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
), B.MacroDecl
((sb
,ebs
),ii
) ->
1780 let (iisb
, lpb
, rpb
, iiendb
, iifakestart
, iistob
) =
1782 | iisb
::lpb
::rpb
::iiendb
::iifakestart
::iisto
->
1783 (iisb
,lpb
,rpb
,iiendb
, iifakestart
,iisto
)
1784 | _
-> raise Impossible
1787 then minusize_list iistob
1788 else return ((), iistob
)
1789 ) >>= (fun () iistob
->
1791 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1792 ident DontKnow sa
(sb
, iisb
) >>= (fun sa
(sb
, iisb
) ->
1793 tokenf lpa lpb
>>= (fun lpa lpb
->
1794 tokenf rpa rpb
>>= (fun rpa rpb
->
1795 tokenf enda iiendb
>>= (fun enda iiendb
->
1796 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
1797 let eas = redots
eas easundots
in
1800 (mckstart
, allminus
,
1801 (A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
)) +> A.rewrap decla
),
1802 (B.MacroDecl
((sb
,ebs
),
1803 [iisb
;lpb
;rpb
;iiendb
;iifakestart
] ++ iistob
))
1806 | _
, (B.MacroDecl _
|B.DeclList _
) -> fail
1809 and onedecl
= fun allminus decla
(declb
, iiptvirgb
, iistob
) ->
1810 X.all_bound
(A.get_inherited decla
) >&&>
1811 match A.unwrap decla
, declb
with
1813 (* kind of typedef iso, we must unfold, it's for the case
1814 * T { }; that we want to match against typedef struct { } xx_t;
1817 | A.TyDecl
(tya0
, ptvirga
),
1818 ({B.v_namei
= Some
(nameidb
, None
);
1820 B.v_storage
= (B.StoTypedef
, inl
);
1823 B.v_type_bis
= typb0bis
;
1826 (match A.unwrap tya0
, typb0
with
1827 | A.Type
(cv1
,tya1
), ((qu
,il
),typb1
) ->
1829 (match A.unwrap tya1
, typb1
with
1830 | A.StructUnionDef
(tya2
, lba
, declsa
, rba
),
1831 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
1833 let (iisub
, iisbopt
, lbb
, rbb
) =
1836 let (iisub
, lbb
, rbb
) = tuple_of_list3 ii
in
1837 (iisub
, [], lbb
, rbb
)
1840 "warning: both a typedef (%s) and struct name introduction (%s)"
1841 (Ast_c.str_of_name nameidb
) s
1843 pr2 "warning: I will consider only the typedef";
1844 let (iisub
, iisb
, lbb
, rbb
) = tuple_of_list4 ii
in
1845 (iisub
, [iisb
], lbb
, rbb
)
1848 structdef_to_struct_name
1849 (Ast_c.nQ
, (B.StructUnion
(sub
, sbopt
, declsb
), ii
))
1852 Ast_c.nQ
,((B.TypeName
(nameidb
, Some
1853 (Lib_parsing_c.al_type
structnameb))), [])
1856 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1857 tokenf lba lbb
>>= (fun lba lbb
->
1858 tokenf rba rbb
>>= (fun rba rbb
->
1859 struct_fields
(A.undots declsa
) declsb
>>=(fun undeclsa declsb
->
1860 let declsa = redots
declsa undeclsa
in
1862 (match A.unwrap tya2
with
1863 | A.Type
(cv3
, tya3
) ->
1864 (match A.unwrap tya3
with
1865 | A.MetaType
(ida
,keep
, inherited
) ->
1867 fullType tya2
fake_typeb >>= (fun tya2
fake_typeb ->
1869 A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1 in
1870 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1873 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1874 [iisub
] @ iisbopt
@ [lbb
;rbb
] in
1875 let typb0 = ((qu
, il
), typb1) in
1877 match fake_typeb with
1878 | _nQ
, ((B.TypeName
(nameidb
, _typ
)),[]) ->
1881 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1882 (({B.v_namei
= Some
(nameidb
, None
);
1884 B.v_storage
= (B.StoTypedef
, inl
);
1887 B.v_type_bis
= typb0bis
;
1889 iivirg
),iiptvirgb
,iistob
)
1891 | _
-> raise Impossible
1894 (* do we need EnumName here too? *)
1895 | A.StructUnionName
(sua
, sa
) ->
1896 fullType tya2
structnameb >>= (fun tya2
structnameb ->
1898 let tya1 = A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1
1900 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1902 match structnameb with
1903 | _nQ
, (B.StructUnionName
(sub
, s), [iisub
;iisbopt
]) ->
1905 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1906 [iisub
;iisbopt
;lbb
;rbb
] in
1907 let typb0 = ((qu
, il
), typb1) in
1910 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1911 (({B.v_namei
= Some
(nameidb
, None
);
1913 B.v_storage
= (B.StoTypedef
, inl
);
1916 B.v_type_bis
= typb0bis
;
1918 iivirg
),iiptvirgb
,iistob
)
1920 | _
-> raise Impossible
1922 | _
-> raise Impossible
1931 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1932 ({B.v_namei
= Some
(nameidb
, _
);B.v_storage
= (B.StoTypedef
,_
);}, iivirg
)
1935 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1936 ({B.v_namei
=Some
(nameidb
, _
);B.v_storage
=(B.StoTypedef
,_
);}, iivirg
)
1941 (* could handle iso here but handled in standard.iso *)
1942 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1943 ({B.v_namei
= Some
(nameidb
, None
);
1948 B.v_type_bis
= typbbis
;
1951 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1952 fullType typa typb
>>= (fun typa typb
->
1953 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1954 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1955 (fun stoa
(stob
, iistob
) ->
1957 (A.UnInit
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
1958 (({B.v_namei
= Some
(nameidb
, None
);
1963 B.v_type_bis
= typbbis
;
1968 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1969 ({B.v_namei
= Some
(nameidb
, Some
(iieqb
, inib
));
1974 B.v_type_bis
= typbbis
;
1977 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1978 tokenf eqa iieqb
>>= (fun eqa iieqb
->
1979 fullType typa typb
>>= (fun typa typb
->
1980 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1981 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1982 (fun stoa
(stob
, iistob
) ->
1983 initialiser inia inib
>>= (fun inia inib
->
1985 (A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
)) +> A.rewrap decla
,
1986 (({B.v_namei
= Some
(nameidb
, Some
(iieqb
, inib
));
1991 B.v_type_bis
= typbbis
;
1996 (* do iso-by-absence here ? allow typedecl and var ? *)
1997 | A.TyDecl
(typa
, ptvirga
),
1998 ({B.v_namei
= None
; B.v_type
= typb
;
2002 B.v_type_bis
= typbbis
;
2005 if stob
=*= (B.NoSto
, false)
2007 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2008 fullType typa typb
>>= (fun typa typb
->
2010 (A.TyDecl
(typa
, ptvirga
)) +> A.rewrap decla
,
2011 (({B.v_namei
= None
;
2016 B.v_type_bis
= typbbis
;
2017 }, iivirg
), iiptvirgb
, iistob
)
2022 | A.Typedef
(stoa
, typa
, ida
, ptvirga
),
2023 ({B.v_namei
= Some
(nameidb
, None
);
2025 B.v_storage
= (B.StoTypedef
,inline
);
2028 B.v_type_bis
= typbbis
;
2031 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2032 fullType typa typb
>>= (fun typa typb
->
2035 tokenf stoa iitypedef
>>= (fun stoa iitypedef
->
2036 return (stoa
, [iitypedef
])
2038 | _
-> failwith
"weird, have both typedef and inline or nothing";
2039 ) >>= (fun stoa iistob
->
2040 (match A.unwrap ida
with
2041 | A.MetaType
(_
,_
,_
) ->
2044 Ast_c.nQ
, ((B.TypeName
(nameidb
, Ast_c.noTypedefDef
())), [])
2046 fullTypebis ida
fake_typeb >>= (fun ida
fake_typeb ->
2047 match fake_typeb with
2048 | _nQ
, ((B.TypeName
(nameidb
, _typ
)), []) ->
2049 return (ida
, nameidb
)
2050 | _
-> raise Impossible
2055 | B.RegularName
(sb
, iidb
) ->
2056 let iidb1 = tuple_of_list1 iidb
in
2060 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
2062 (A.TypeName sa
) +> A.rewrap ida
,
2063 B.RegularName
(sb
, [iidb1])
2067 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
2071 | _
-> raise Impossible
2073 ) >>= (fun ida nameidb
->
2075 (A.Typedef
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
2076 (({B.v_namei
= Some
(nameidb
, None
);
2078 B.v_storage
= (B.StoTypedef
,inline
);
2081 B.v_type_bis
= typbbis
;
2089 | _
, ({B.v_namei
= None
;}, _
) ->
2090 (* old: failwith "no variable in this declaration, weird" *)
2095 | A.DisjDecl declas
, declb
->
2096 declas
+> List.fold_left
(fun acc decla
->
2098 (* (declaration (mckstart, allminus, decla) declb) *)
2099 (onedecl allminus decla
(declb
,iiptvirgb
, iistob
))
2104 (* only in struct type decls *)
2105 | A.Ddots
(dots
,whencode
), _
->
2108 | A.OptDecl _
, _
| A.UniqueDecl _
, _
->
2109 failwith
"not handling Opt/Unique Decl"
2111 | _
, ({B.v_namei
=Some _
}, _
) ->
2117 (* ------------------------------------------------------------------------- *)
2119 and (initialiser
: (A.initialiser
, Ast_c.initialiser
) matcher
) = fun ia ib
->
2120 X.all_bound
(A.get_inherited ia
) >&&>
2121 match (A.unwrap ia
,ib
) with
2123 | (A.MetaInit
(ida
,keep
,inherited
), ib
) ->
2125 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_ini ib
) in
2126 X.envf keep inherited
(ida
, Ast_c.MetaInitVal ib
, max_min)
2128 X.distrf_ini ida ib
>>= (fun ida ib
->
2130 A.MetaInit
(ida
,keep
,inherited
) +> A.rewrap ia
,
2135 | (A.InitExpr expa
, ib
) ->
2136 (match A.unwrap expa
, ib
with
2137 | A.Edots
(mcode, None
), ib
->
2138 X.distrf_ini
(dots2metavar mcode) ib
>>= (fun mcode ib
->
2141 (A.Edots
(metavar2dots mcode, None
) +> A.rewrap expa
)
2146 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
2148 | _
, (B.InitExpr expb
, ii
) ->
2150 expression expa expb
>>= (fun expa expb
->
2152 (A.InitExpr expa
) +> A.rewrap ia
,
2153 (B.InitExpr expb
, ii
)
2158 | (A.ArInitList
(ia1
, ias
, ia2
), (B.InitList ibs
, ii
)) ->
2160 | ib1::ib2
::iicommaopt
->
2161 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2162 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2163 ar_initialisers
(A.undots ias
) (ibs
, iicommaopt
) >>=
2164 (fun iasundots
(ibs
,iicommaopt
) ->
2166 (A.ArInitList
(ia1
, redots ias iasundots
, ia2
)) +> A.rewrap ia
,
2167 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2170 | _
-> raise Impossible
2173 | (A.StrInitList
(allminus
, ia1
, ias
, ia2
, []), (B.InitList ibs
, ii
)) ->
2175 | ib1::ib2
::iicommaopt
->
2176 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2177 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2178 str_initialisers allminus ias
(ibs
, iicommaopt
) >>=
2179 (fun ias
(ibs
,iicommaopt
) ->
2181 (A.StrInitList
(allminus
, ia1
, ias
, ia2
, [])) +> A.rewrap ia
,
2182 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2185 | _
-> raise Impossible
2188 | (A.StrInitList
(allminus
, i1
, ias
, i2
, whencode
),
2189 (B.InitList ibs
, _ii
)) ->
2190 failwith
"TODO: not handling whencode in initialisers"
2193 | (A.InitGccExt
(designatorsa
, ia2
, inia
),
2194 (B.InitDesignators
(designatorsb
, inib
), ii2
))->
2196 let iieq = tuple_of_list1 ii2
in
2198 tokenf ia2
iieq >>= (fun ia2
iieq ->
2199 designators designatorsa designatorsb
>>=
2200 (fun designatorsa designatorsb
->
2201 initialiser inia inib
>>= (fun inia inib
->
2203 (A.InitGccExt
(designatorsa
, ia2
, inia
)) +> A.rewrap ia
,
2204 (B.InitDesignators
(designatorsb
, inib
), [iieq])
2210 | (A.InitGccName
(ida
, ia1
, inia
), (B.InitFieldOld
(idb
, inib
), ii
)) ->
2213 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2214 initialiser inia inib
>>= (fun inia inib
->
2215 tokenf ia1 iicolon
>>= (fun ia1 iicolon
->
2217 (A.InitGccName
(ida
, ia1
, inia
)) +> A.rewrap ia
,
2218 (B.InitFieldOld
(idb
, inib
), [iidb
;iicolon
])
2225 | A.IComma
(comma
), _
->
2228 | A.UniqueIni _
,_
| A.OptIni _
,_
->
2229 failwith
"not handling Opt/Unique on initialisers"
2231 | _
, (B.InitIndexOld
(_
, _
), _
) -> fail
2232 | _
, (B.InitFieldOld
(_
, _
), _
) -> fail
2234 | _
, ((B.InitDesignators
(_
, _
)|B.InitList _
|B.InitExpr _
), _
)
2237 and designators dla dlb
=
2238 match (dla
,dlb
) with
2239 ([],[]) -> return ([], [])
2240 | ([],_
) | (_
,[]) -> fail
2241 | (da
::dla
,db
::dlb
) ->
2242 designator da db
>>= (fun da db
->
2243 designators dla dlb
>>= (fun dla dlb
->
2244 return (da
::dla
, db
::dlb
)))
2246 and designator da db
=
2248 (A.DesignatorField
(ia1
, ida
), (B.DesignatorField idb
,ii1
)) ->
2250 let (iidot
, iidb
) = tuple_of_list2 ii1
in
2251 tokenf ia1 iidot
>>= (fun ia1 iidot
->
2252 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2254 A.DesignatorField
(ia1
, ida
),
2255 (B.DesignatorField idb
, [iidot
;iidb
])
2258 | (A.DesignatorIndex
(ia1
,ea
,ia2
), (B.DesignatorIndex eb
, ii1
)) ->
2260 let (ib1, ib2
) = tuple_of_list2 ii1
in
2261 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2262 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2263 expression ea eb
>>= (fun ea eb
->
2265 A.DesignatorIndex
(ia1
,ea
,ia2
),
2266 (B.DesignatorIndex eb
, [ib1;ib2
])
2269 | (A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2270 (B.DesignatorRange
(e1b
, e2b
), ii1
)) ->
2272 let (ib1, ib2
, ib3
) = tuple_of_list3 ii1
in
2273 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2274 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2275 tokenf ia3 ib3
>>= (fun ia3 ib3
->
2276 expression e1a e1b
>>= (fun e1a e1b
->
2277 expression e2a e2b
>>= (fun e2a e2b
->
2279 A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2280 (B.DesignatorRange
(e1b
, e2b
), [ib1;ib2
;ib3
])
2282 | (_
, ((B.DesignatorField _
|B.DesignatorIndex _
|B.DesignatorRange _
), _
)) ->
2285 and str_initialisers
= fun allminus ias
(ibs
, iicomma
) ->
2286 let ias_unsplit = unsplit_icomma ias
in
2287 let ibs_split = resplit_initialiser ibs iicomma
in
2289 if need_unordered_initialisers ibs
2290 then initialisers_unordered2 allminus
ias_unsplit ibs_split >>=
2291 (fun ias_unsplit ibs_split ->
2293 split_icomma ias_unsplit,
2294 unsplit_initialiser ibs_split))
2297 and ar_initialisers
= fun ias
(ibs
, iicomma
) ->
2298 (* this doesn't check need_unordered_initialisers because ... can be
2299 implemented as ordered, even if it matches unordered initializers *)
2300 let ibs = resplit_initialiser ibs iicomma
in
2303 (List.map
(function (elem
,comma
) -> [Left elem
; Right
[comma
]]) ibs) in
2304 initialisers_ordered2 ias
ibs >>=
2305 (fun ias
ibs_split ->
2307 match List.rev
ibs_split with
2308 (Right comma
)::rest
-> (Ast_c.unsplit_comma
(List.rev rest
),comma
)
2309 | (Left _
)::_
-> (Ast_c.unsplit_comma
ibs_split,[]) (* possible *)
2311 return (ias
, (ibs,iicomma
)))
2313 and initialisers_ordered2
= fun ias
ibs ->
2315 match A.unwrap ea
with
2316 A.Idots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2318 let build_dots (mcode, optexpr
) = A.Idots
(mcode, optexpr
) in
2319 let match_comma ea
=
2320 match A.unwrap ea
with
2321 A.IComma ia1
-> Some ia1
2323 let build_comma ia1
= A.IComma ia1
in
2324 let match_metalist ea
= None
in
2325 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
2326 let mktermval v
= failwith
"not possible" in
2327 let special_cases ea
eas ebs
= None
in
2328 let no_ii x
= failwith
"not possible" in
2329 list_matcher match_dots build_dots match_comma build_comma
2330 match_metalist build_metalist mktermval
2331 special_cases initialiser
X.distrf_inis
no_ii ias
ibs
2334 and initialisers_unordered2
= fun allminus ias
ibs ->
2339 let rec loop = function
2340 [] -> return ([],[])
2341 | (ib
,comma
)::ibs ->
2342 X.distrf_ini
minusizer ib
>>= (fun _ ib
->
2343 tokenf minusizer comma
>>= (fun _ comma
->
2344 loop ibs >>= (fun l
ibs ->
2345 return(l
,(ib
,comma
)::ibs)))) in
2347 else return ([], ys
)
2349 let permut = Common.uncons_permut_lazy ys
in
2350 permut +> List.fold_left
(fun acc
((e
, pos
), rest
) ->
2352 (initialiser_comma x e
2354 let rest = Lazy.force
rest in
2355 initialisers_unordered2 allminus xs
rest >>= (fun xs
rest ->
2358 Common.insert_elem_pos
(e
, pos
) rest
2362 and initialiser_comma
(x
,xcomma
) (y
, commay
) =
2363 match A.unwrap xcomma
with
2365 tokenf commax commay
>>= (fun commax commay
->
2366 initialiser x y
>>= (fun x y
->
2368 (x
, (A.IComma commax
) +> A.rewrap xcomma
),
2370 | _
-> raise Impossible
(* unsplit_iicomma wrong *)
2372 (* ------------------------------------------------------------------------- *)
2373 and (struct_fields
: (A.declaration list
, B.field list
) matcher
) =
2376 match A.unwrap ea
with
2377 A.Ddots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2379 let build_dots (mcode, optexpr
) = A.Ddots
(mcode, optexpr
) in
2380 let match_comma ea
= None
in
2381 let build_comma ia1
= failwith
"not possible" in
2382 let match_metalist ea
= None
in
2383 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
2384 let mktermval v
= failwith
"not possible" in
2385 let special_cases ea
eas ebs
= None
in
2386 let no_ii x
= failwith
"not possible" in
2387 let make_ebs ebs
= List.map
(function x
-> Left x
) ebs
in
2388 let unmake_ebs ebs
=
2389 List.map
(function Left x
-> x
| Right x
-> failwith
"no right") ebs
in
2390 let distrf mcode startxs =
2391 let startxs = unmake_ebs startxs in
2392 X.distrf_struct_fields
mcode startxs >>=
2393 (fun mcode startxs -> return (mcode,make_ebs startxs)) in
2394 list_matcher match_dots build_dots match_comma build_comma
2395 match_metalist build_metalist mktermval
2396 special_cases struct_field
distrf no_ii eas (make_ebs ebs
) >>=
2397 (fun eas ebs
-> return (eas,unmake_ebs ebs
))
2399 and (struct_field
: (A.declaration
, B.field
) matcher
) = fun fa fb
->
2401 match A.unwrap fa
,fb
with
2402 | A.MetaField
(ida
,keep
,inherited
), _
->
2404 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_field fb
) in
2405 X.envf keep inherited
(ida
, Ast_c.MetaFieldVal fb
, max_min) (fun () ->
2406 X.distrf_field ida fb
2407 ) >>= (fun ida fb
->
2408 return ((A.MetaField
(ida
, keep
, inherited
))+> A.rewrap fa
,
2410 | _
,B.DeclarationField
(B.FieldDeclList
(onefield_multivars
,iiptvirg
)) ->
2412 let iiptvirgb = tuple_of_list1 iiptvirg
in
2414 (match onefield_multivars
with
2415 | [] -> raise Impossible
2416 | [onevar
,iivirg
] ->
2417 assert (null iivirg
);
2419 | B.BitField
(sopt
, typb
, _
, expr
) ->
2420 pr2_once
"warning: bitfield not handled by ast_cocci";
2422 | B.Simple
(None
, typb
) ->
2423 pr2_once
"warning: unamed struct field not handled by ast_cocci";
2425 | B.Simple
(Some nameidb
, typb
) ->
2427 (* build a declaration from a struct field *)
2428 let allminus = false in
2430 let stob = B.NoSto
, false in
2432 ({B.v_namei
= Some
(nameidb
, None
);
2435 B.v_local
= Ast_c.NotLocalDecl
;
2436 B.v_attr
= Ast_c.noattr
;
2437 B.v_type_bis
= ref None
;
2438 (* the struct field should also get expanded ? no it's not
2439 * important here, we will rematch very soon *)
2443 onedecl
allminus fa
(fake_var,iiptvirgb,iisto) >>=
2444 (fun fa
(var
,iiptvirgb,iisto) ->
2447 | ({B.v_namei
= Some
(nameidb
, None
);
2452 let onevar = B.Simple
(Some nameidb
, typb
) in
2456 ((B.DeclarationField
2457 (B.FieldDeclList
([onevar, iivirg
], [iiptvirgb])))
2460 | _
-> raise Impossible
2465 pr2_once
"PB: More that one variable in decl. Have to split";
2468 | _
,B.EmptyField _iifield
->
2471 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
),B.MacroDeclField
((sb
,ebs
),ii
) ->
2473 | _
,B.MacroDeclField
((sb
,ebs
),ii
) -> fail
2475 | _
,B.CppDirectiveStruct directive
-> fail
2476 | _
,B.IfdefStruct directive
-> fail
2479 and enum_fields
= fun eas ebs
->
2481 match A.unwrap ea
with
2482 A.Edots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2484 let build_dots (mcode, optexpr
) = A.Edots
(mcode, optexpr
) in
2485 let match_comma ea
=
2486 match A.unwrap ea
with
2487 A.EComma ia1
-> Some ia1
2489 let build_comma ia1
= A.EComma ia1
in
2490 let match_metalist ea
= None
in
2491 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
2492 let mktermval v
= failwith
"not possible" in
2493 let special_cases ea
eas ebs
= None
in
2494 list_matcher match_dots build_dots match_comma build_comma
2495 match_metalist build_metalist mktermval
2496 special_cases enum_field
X.distrf_enum_fields
2497 Lib_parsing_c.ii_of_enum_fields
eas ebs
2499 and enum_field ida idb
=
2500 X.all_bound
(A.get_inherited ida
) >&&>
2501 match A.unwrap ida
, idb
with
2502 A.Ident
(id
),(nameidb
,None
) ->
2503 ident_cpp DontKnow id nameidb
>>= (fun id nameidb
->
2504 return ((A.Ident id
) +> A.rewrap ida
, (nameidb
,None
)))
2505 | A.Assignment
(ea1
,opa
,ea2
,init
),(nameidb
,Some
(opbi,eb2
)) ->
2506 (match A.unwrap ea1
with
2508 ident_cpp DontKnow id nameidb
>>= (fun id nameidb
->
2509 expression ea2 eb2
>>= (fun ea2 eb2
->
2510 tokenf opa
opbi >>= (fun opa
opbi -> (* only one kind of assignop *)
2512 (A.Assignment
((A.Ident
(id
))+>A.rewrap ea1
,opa
,ea2
,init
)) +>
2514 (nameidb
,Some
(opbi,eb2
))))))
2515 | _
-> failwith
"not possible")
2516 | _
-> failwith
"not possible"
2518 (* ------------------------------------------------------------------------- *)
2519 and (fullType
: (A.fullType
, Ast_c.fullType
) matcher
) =
2521 X.optional_qualifier_flag
(fun optional_qualifier
->
2522 X.all_bound
(A.get_inherited typa
) >&&>
2523 match A.unwrap typa
, typb
with
2524 | A.Type
(cv
,ty1
), ((qu
,il
),ty2
) ->
2526 if qu
.B.const
&& qu
.B.volatile
2529 ("warning: the type is both const & volatile but cocci " ^
2530 "does not handle that");
2532 (* Drop out the const/volatile part that has been matched.
2533 * This is because a SP can contain const T v; in which case
2534 * later in match_t_t when we encounter a T, we must not add in
2535 * the environment the whole type.
2540 (* "iso-by-absence" *)
2543 fullTypebis ty1
((qu
,il
), ty2
) >>= (fun ty1 fullty2
->
2545 (A.Type
(None
, ty1
)) +> A.rewrap typa
,
2549 (match optional_qualifier
, qu
.B.const
|| qu
.B.volatile
with
2550 | false, false -> do_stuff ()
2551 | false, true -> fail
2552 | true, false -> do_stuff ()
2555 then pr2_once
"USING optional_qualifier builtin isomorphism";
2561 (* todo: can be __const__ ? can be const & volatile so
2562 * should filter instead ?
2564 (match term x
, il
with
2565 | A.Const
, [i1
] when qu
.B.const
->
2567 tokenf x i1
>>= (fun x i1
->
2568 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2570 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2574 | A.Volatile
, [i1
] when qu
.B.volatile
->
2575 tokenf x i1
>>= (fun x i1
->
2576 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2578 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2586 | A.DisjType typas
, typb
->
2588 List.fold_left
(fun acc typa
-> acc
>|+|> (fullType typa typb
)) fail
2590 | A.OptType
(_
), _
| A.UniqueType
(_
), _
2591 -> failwith
"not handling Opt/Unique on type"
2596 * Why not (A.typeC, Ast_c.typeC) matcher ?
2597 * because when there is MetaType, we want that T record the whole type,
2598 * including the qualifier, and so this type (and the new_il function in
2599 * preceding function).
2602 and (fullTypebis
: (A.typeC
, Ast_c.fullType
) matcher
) =
2604 X.all_bound
(A.get_inherited ta
) >&&>
2605 match A.unwrap ta
, tb
with
2608 | A.MetaType
(ida
,keep
, inherited
), typb
->
2610 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
2611 X.envf keep inherited
(ida
, B.MetaTypeVal typb
, max_min) (fun () ->
2612 X.distrf_type ida typb
>>= (fun ida typb
->
2614 A.MetaType
(ida
,keep
, inherited
) +> A.rewrap ta
,
2618 | unwrap
, (qub
, typb
) ->
2619 typeC ta typb
>>= (fun ta typb
->
2620 return (ta
, (qub
, typb
))
2623 and simulate_signed ta basea stringsa signaopt tb baseb ii rebuilda
=
2624 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2625 * And even if in baseb we have a Signed Int, that does not mean
2626 * that ii is of length 2, cos Signed is the default, so if in signa
2627 * we have Signed explicitely ? we cant "accrocher" this mcode to
2628 * something :( So for the moment when there is signed in cocci,
2629 * we force that there is a signed in c too (done in pattern.ml).
2631 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2634 (* handle some iso on type ? (cf complex C rule for possible implicit
2636 match basea
, baseb
with
2637 | A.VoidType
, B.Void
2638 | A.FloatType
, B.FloatType
(B.CFloat
)
2639 | A.DoubleType
, B.FloatType
(B.CDouble
)
2640 | A.SizeType
, B.SizeType
2641 | A.SSizeType
, B.SSizeType
2642 | A.PtrDiffType
,B.PtrDiffType
->
2643 assert (signaopt
=*= None
);
2644 let stringa = tuple_of_list1 stringsa
in
2645 let (ibaseb
) = tuple_of_list1 ii
in
2646 tokenf stringa ibaseb
>>= (fun stringa ibaseb
->
2648 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2649 (B.BaseType baseb
, [ibaseb
])
2652 | A.CharType
, B.IntType
B.CChar
when signaopt
=*= None
->
2653 let stringa = tuple_of_list1 stringsa
in
2654 let ibaseb = tuple_of_list1 ii
in
2655 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2657 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2658 (B.BaseType
(B.IntType
B.CChar
), [ibaseb])
2661 | A.CharType
,B.IntType
(B.Si
(_sign
, B.CChar2
)) when signaopt
<> None
->
2662 let stringa = tuple_of_list1 stringsa
in
2663 let ibaseb = tuple_of_list1 iibaseb
in
2664 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2665 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2667 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2668 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2671 | A.ShortType
, B.IntType
(B.Si
(_
, B.CShort
))
2672 | A.IntType
, B.IntType
(B.Si
(_
, B.CInt
))
2673 | A.LongType
, B.IntType
(B.Si
(_
, B.CLong
)) ->
2674 let stringa = tuple_of_list1 stringsa
in
2677 (* iso-by-presence ? *)
2678 (* when unsigned int in SP, allow have just unsigned in C ? *)
2679 if mcode_contain_plus (mcodekind stringa)
2683 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2685 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2686 (B.BaseType
(baseb
), iisignbopt
++ [])
2692 "warning: long int or short int not handled by ast_cocci";
2696 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2697 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2699 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2700 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2702 | _
-> raise Impossible
2707 | A.LongLongType
, B.IntType
(B.Si
(_
, B.CLongLong
)) ->
2708 let (string1a
,string2a
) = tuple_of_list2 stringsa
in
2710 [ibase1b
;ibase2b
] ->
2711 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2712 tokenf string1a ibase1b
>>= (fun base1a ibase1b
->
2713 tokenf string2a ibase2b
>>= (fun base2a ibase2b
->
2715 (rebuilda
([base1a
;base2a
], signaopt
)) +> A.rewrap ta
,
2716 (B.BaseType
(baseb
), iisignbopt
++ [ibase1b
;ibase2b
])
2718 | [] -> fail (* should something be done in this case? *)
2719 | _
-> raise Impossible
)
2722 | _
, B.FloatType
B.CLongDouble
2725 "warning: long double not handled by ast_cocci";
2728 | _
, (B.Void
|B.FloatType _
|B.IntType _
2729 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
2731 and simulate_signed_meta ta basea signaopt tb baseb ii rebuilda
=
2732 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2733 * And even if in baseb we have a Signed Int, that does not mean
2734 * that ii is of length 2, cos Signed is the default, so if in signa
2735 * we have Signed explicitely ? we cant "accrocher" this mcode to
2736 * something :( So for the moment when there is signed in cocci,
2737 * we force that there is a signed in c too (done in pattern.ml).
2739 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2741 let match_to_type rebaseb
=
2742 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2743 let fta = A.rewrap basea
(A.Type
(None
,basea
)) in
2744 let ftb = Ast_c.nQ
,(B.BaseType
(rebaseb
), iibaseb
) in
2745 fullType
fta ftb >>= (fun fta (_
,tb
) ->
2746 (match A.unwrap
fta,tb
with
2747 A.Type
(_
,basea
), (B.BaseType baseb
, ii
) ->
2749 (rebuilda
(basea
, signaopt
)) +> A.rewrap ta
,
2750 (B.BaseType
(baseb
), iisignbopt
++ ii
)
2752 | _
-> failwith
"not possible"))) in
2754 (* handle some iso on type ? (cf complex C rule for possible implicit
2757 | B.IntType
(B.Si
(_sign
, B.CChar2
)) ->
2758 match_to_type (B.IntType
B.CChar
)
2760 | B.IntType
(B.Si
(_
, ty
)) ->
2762 | [] -> fail (* metavariable has to match something *)
2764 | _
-> match_to_type (B.IntType
(B.Si
(B.Signed
, ty
)))
2768 | (B.Void
|B.FloatType _
|B.IntType _
2769 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
2771 and (typeC
: (A.typeC
, Ast_c.typeC
) matcher
) =
2773 match A.unwrap ta
, tb
with
2774 | A.BaseType
(basea
,stringsa
), (B.BaseType baseb
, ii
) ->
2775 simulate_signed ta basea stringsa None tb baseb ii
2776 (function (stringsa
, signaopt
) -> A.BaseType
(basea
,stringsa
))
2777 | A.SignedT
(signaopt
, Some basea
), (B.BaseType baseb
, ii
) ->
2778 (match A.unwrap basea
with
2779 A.BaseType
(basea1
,strings1
) ->
2780 simulate_signed ta basea1 strings1
(Some signaopt
) tb baseb ii
2781 (function (strings1
, Some signaopt
) ->
2784 Some
(A.rewrap basea
(A.BaseType
(basea1
,strings1
))))
2785 | _
-> failwith
"not possible")
2786 | A.MetaType
(ida
,keep
,inherited
) ->
2787 simulate_signed_meta ta basea
(Some signaopt
) tb baseb ii
2788 (function (basea
, Some signaopt
) ->
2789 A.SignedT
(signaopt
,Some basea
)
2790 | _
-> failwith
"not possible")
2791 | _
-> failwith
"not possible")
2792 | A.SignedT
(signa
,None
), (B.BaseType baseb
, ii
) ->
2793 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2794 (match iibaseb
, baseb
with
2795 | [], B.IntType
(B.Si
(_sign
, B.CInt
)) ->
2796 sign
(Some signa
) signbopt >>= (fun signaopt iisignbopt
->
2798 | None
-> raise Impossible
2801 (A.SignedT
(signa
,None
)) +> A.rewrap ta
,
2802 (B.BaseType baseb
, iisignbopt
)
2810 (* todo? iso with array *)
2811 | A.Pointer
(typa
, iamult
), (B.Pointer typb
, ii
) ->
2812 let (ibmult
) = tuple_of_list1 ii
in
2813 fullType typa typb
>>= (fun typa typb
->
2814 tokenf iamult ibmult
>>= (fun iamult ibmult
->
2816 (A.Pointer
(typa
, iamult
)) +> A.rewrap ta
,
2817 (B.Pointer typb
, [ibmult
])
2820 | A.FunctionType
(allminus,tyaopt
,lpa
,paramsa
,rpa
),
2821 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
) ->
2823 let (lpb
, rpb
) = tuple_of_list2 ii
in
2827 ("Not handling well variable length arguments func. "^
2828 "You have been warned");
2829 tokenf lpa lpb
>>= (fun lpa lpb
->
2830 tokenf rpa rpb
>>= (fun rpa rpb
->
2831 fullType_optional_allminus
allminus tyaopt tyb
>>= (fun tyaopt tyb
->
2832 parameters
(seqstyle paramsa
) (A.undots paramsa
) paramsb
>>=
2833 (fun paramsaundots paramsb
->
2834 let paramsa = redots
paramsa paramsaundots
in
2836 (A.FunctionType
(allminus,tyaopt
,lpa
,paramsa,rpa
) +> A.rewrap ta
,
2837 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), [lpb
;rpb
])
2845 | A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
),
2846 (B.ParenType t1
, ii
) ->
2847 let (lp1b
, rp1b
) = tuple_of_list2 ii
in
2848 let (qu1b
, t1b
) = t1
in
2850 | B.Pointer t2
, ii
->
2851 let (starb
) = tuple_of_list1 ii
in
2852 let (qu2b
, t2b
) = t2
in
2854 | B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
->
2855 let (lp2b
, rp2b
) = tuple_of_list2 ii
in
2860 ("Not handling well variable length arguments func. "^
2861 "You have been warned");
2863 fullType tya tyb
>>= (fun tya tyb
->
2864 tokenf lp1a lp1b
>>= (fun lp1a lp1b
->
2865 tokenf rp1a rp1b
>>= (fun rp1a rp1b
->
2866 tokenf lp2a lp2b
>>= (fun lp2a lp2b
->
2867 tokenf rp2a rp2b
>>= (fun rp2a rp2b
->
2868 tokenf stara starb
>>= (fun stara starb
->
2869 parameters
(seqstyle paramsa) (A.undots
paramsa) paramsb
>>=
2870 (fun paramsaundots paramsb
->
2871 let paramsa = redots
paramsa paramsaundots
in
2875 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))),
2880 (B.Pointer
t2, [starb
]))
2884 (A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
))
2886 (B.ParenType
t1, [lp1b
;rp1b
])
2899 (* todo: handle the iso on optionnal size specifification ? *)
2900 | A.Array
(typa
, ia1
, eaopt
, ia2
), (B.Array
(ebopt
, typb
), ii
) ->
2901 let (ib1, ib2
) = tuple_of_list2 ii
in
2902 fullType typa typb
>>= (fun typa typb
->
2903 option expression eaopt ebopt
>>= (fun eaopt ebopt
->
2904 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2905 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2907 (A.Array
(typa
, ia1
, eaopt
, ia2
)) +> A.rewrap ta
,
2908 (B.Array
(ebopt
, typb
), [ib1;ib2
])
2912 (* todo: could also match a Struct that has provided a name *)
2913 (* This is for the case where the SmPL code contains "struct x", without
2914 a definition. In this case, the name field is always present.
2915 This case is also called from the case for A.StructUnionDef when
2916 a name is present in the C code. *)
2917 | A.StructUnionName
(sua
, Some sa
), (B.StructUnionName
(sub
, sb
), ii
) ->
2918 (* sa is now an ident, not an mcode, old: ... && (term sa) =$= sb *)
2919 let (ib1, ib2
) = tuple_of_list2 ii
in
2920 if equal_structUnion (term sua
) sub
2922 ident DontKnow sa
(sb
, ib2
) >>= (fun sa
(sb
, ib2
) ->
2923 tokenf sua
ib1 >>= (fun sua
ib1 ->
2925 (A.StructUnionName
(sua
, Some sa
)) +> A.rewrap ta
,
2926 (B.StructUnionName
(sub
, sb
), [ib1;ib2
])
2931 | A.StructUnionDef
(ty
, lba
, declsa, rba
),
2932 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
2934 let (ii_sub_sb
, lbb
, rbb
) =
2936 [iisub
; lbb
; rbb
] -> (Common.Left iisub
,lbb
,rbb
)
2937 | [iisub
; iisb
; lbb
; rbb
] -> (Common.Right
(iisub
,iisb
),lbb
,rbb
)
2938 | _
-> failwith
"list of length 3 or 4 expected" in
2941 match (sbopt
,ii_sub_sb
) with
2942 (None
,Common.Left iisub
) ->
2943 (* the following doesn't reconstruct the complete SP code, just
2944 the part that matched *)
2946 match A.unwrap
s with
2948 (match A.unwrap ty
with
2949 A.StructUnionName
(sua
, None
) ->
2950 (match (term sua
, sub
) with
2952 | (A.Union
,B.Union
) -> return ((),())
2955 tokenf sua iisub
>>= (fun sua iisub
->
2958 A.StructUnionName
(sua
, None
) +> A.rewrap
ty)
2960 return (ty,[iisub
])))
2962 | A.DisjType
(disjs
) ->
2964 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
2968 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
2970 (* build a StructUnionName from a StructUnion *)
2971 let fake_su = B.nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) in
2973 fullType
ty fake_su >>= (fun ty fake_su ->
2975 | _nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) ->
2976 return (ty, [iisub
; iisb
])
2977 | _
-> raise Impossible
)
2981 >>= (fun ty ii_sub_sb
->
2983 tokenf lba lbb
>>= (fun lba lbb
->
2984 tokenf rba rbb
>>= (fun rba rbb
->
2985 struct_fields
(A.undots
declsa) declsb
>>=(fun undeclsa declsb
->
2986 let declsa = redots
declsa undeclsa
in
2989 (A.StructUnionDef
(ty, lba
, declsa, rba
)) +> A.rewrap ta
,
2990 (B.StructUnion
(sub
, sbopt
, declsb
),ii_sub_sb
@[lbb
;rbb
])
2994 (* todo? handle isomorphisms ? because Unsigned Int can be match on a
2995 * uint in the C code. But some CEs consists in renaming some types,
2996 * so we don't want apply isomorphisms every time.
2998 | A.TypeName sa
, (B.TypeName
(nameb
, typb
), noii
) ->
3002 | B.RegularName
(sb
, iidb
) ->
3003 let iidb1 = tuple_of_list1 iidb
in
3007 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
3009 (A.TypeName sa
) +> A.rewrap ta
,
3010 (B.TypeName
(B.RegularName
(sb
, [iidb1]), typb
), noii
)
3014 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
3019 | _
, (B.TypeOfExpr e
, ii
) -> fail
3020 | _
, (B.TypeOfType e
, ii
) -> fail
3022 | _
, (B.ParenType e
, ii
) -> fail (* todo ?*)
3023 | A.EnumName
(en
,Some namea
), (B.EnumName nameb
, ii
) ->
3024 let (ib1,ib2
) = tuple_of_list2 ii
in
3025 ident DontKnow namea
(nameb
, ib2
) >>= (fun namea
(nameb
, ib2
) ->
3026 tokenf en
ib1 >>= (fun en
ib1 ->
3028 (A.EnumName
(en
, Some namea
)) +> A.rewrap ta
,
3029 (B.EnumName nameb
, [ib1;ib2
])
3032 | A.EnumDef
(ty, lba
, idsa
, rba
),
3033 (B.Enum
(sbopt
, idsb
), ii
) ->
3035 let (ii_sub_sb
, lbb
, rbb
, comma_opt
) =
3037 [iisub
; lbb
; rbb
; comma_opt
] ->
3038 (Common.Left iisub
,lbb
,rbb
,comma_opt
)
3039 | [iisub
; iisb
; lbb
; rbb
; comma_opt
] ->
3040 (Common.Right
(iisub
,iisb
),lbb
,rbb
,comma_opt
)
3041 | _
-> failwith
"list of length 4 or 5 expected" in
3044 match (sbopt
,ii_sub_sb
) with
3045 (None
,Common.Left iisub
) ->
3046 (* the following doesn't reconstruct the complete SP code, just
3047 the part that matched *)
3049 match A.unwrap
s with
3051 (match A.unwrap
ty with
3052 A.EnumName
(sua
, None
) ->
3053 tokenf sua iisub
>>= (fun sua iisub
->
3055 A.Type
(None
,A.EnumName
(sua
, None
) +> A.rewrap
ty)
3057 return (ty,[iisub
]))
3059 | A.DisjType
(disjs
) ->
3061 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
3065 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
3067 (* build an EnumName from an Enum *)
3068 let fake_su = B.nQ
, (B.EnumName sb
, [iisub
;iisb
]) in
3070 fullType
ty fake_su >>= (fun ty fake_su ->
3072 | _nQ
, (B.EnumName sb
, [iisub
;iisb
]) ->
3073 return (ty, [iisub
; iisb
])
3074 | _
-> raise Impossible
)
3078 >>= (fun ty ii_sub_sb
->
3080 tokenf lba lbb
>>= (fun lba lbb
->
3081 tokenf rba rbb
>>= (fun rba rbb
->
3082 let idsb = resplit_initialiser idsb [comma_opt
] in
3086 (function (elem
,comma
) -> [Left elem
; Right
[comma
]])
3088 enum_fields
(A.undots idsa
) idsb >>= (fun unidsa
idsb ->
3089 let idsa = redots
idsa unidsa
in
3091 match List.rev
idsb with
3092 (Right comma
)::rest ->
3093 (Ast_c.unsplit_comma
(List.rev
rest),comma
)
3094 | (Left _
)::_
-> (Ast_c.unsplit_comma
idsb,[]) (* possible *)
3097 (A.EnumDef
(ty, lba
, idsa, rba
)) +> A.rewrap ta
,
3098 (B.Enum
(sbopt
, idsb),ii_sub_sb
@[lbb
;rbb
]@iicomma
)
3102 | _
, (B.Enum _
, _
) -> fail (* todo cocci ?*)
3105 ((B.TypeName _
| B.StructUnionName
(_
, _
) | B.EnumName _
|
3106 B.StructUnion
(_
, _
, _
) |
3107 B.FunctionType _
| B.Array
(_
, _
) | B.Pointer _
|
3113 (* todo: iso on sign, if not mentioned then free. tochange?
3114 * but that require to know if signed int because explicit
3115 * signed int, or because implicit signed int.
3118 and sign signa signb
=
3119 match signa
, signb
with
3120 | None
, None
-> return (None
, [])
3121 | Some signa
, Some
(signb
, ib
) ->
3122 if equal_sign (term signa
) signb
3123 then tokenf signa ib
>>= (fun signa ib
->
3124 return (Some signa
, [ib
])
3130 and minusize_list iixs
=
3131 iixs
+> List.fold_left
(fun acc ii
->
3132 acc
>>= (fun xs ys
->
3133 tokenf minusizer ii
>>= (fun minus ii
->
3134 return (minus
::xs
, ii
::ys
)
3135 ))) (return ([],[]))
3136 >>= (fun _xsminys ys
->
3137 return ((), List.rev ys
)
3140 and storage_optional_allminus
allminus stoa
(stob, iistob
) =
3141 (* "iso-by-absence" for storage, and return type. *)
3142 X.optional_storage_flag
(fun optional_storage
->
3143 match stoa
, stob with
3144 | None
, (stobis
, inline
) ->
3148 minusize_list iistob
>>= (fun () iistob
->
3149 return (None
, (stob, iistob
))
3151 else return (None
, (stob, iistob
))
3154 (match optional_storage
, stobis
with
3155 | false, B.NoSto
-> do_minus ()
3157 | true, B.NoSto
-> do_minus ()
3160 then pr2_once
"USING optional_storage builtin isomorphism";
3164 | Some x
, ((stobis
, inline
)) ->
3165 if equal_storage (term x
) stobis
3167 let rec loop acc
= function
3170 let str = B.str_of_info i1
in
3172 "static" | "extern" | "auto" | "register" ->
3173 (* not very elegant, but tokenf doesn't know what token to
3175 tokenf x i1
>>= (fun x i1
->
3176 let rebuilt = (List.rev acc
) @ i1
:: iistob
in
3177 return (Some x
, ((stobis
, inline
), rebuilt)))
3178 | _
-> loop (i1
::acc
) iistob
) in
3183 and inline_optional_allminus
allminus inla
(stob, iistob
) =
3184 (* "iso-by-absence" for storage, and return type. *)
3185 X.optional_storage_flag
(fun optional_storage
->
3186 match inla
, stob with
3187 | None
, (stobis
, inline
) ->
3191 minusize_list iistob
>>= (fun () iistob
->
3192 return (None
, (stob, iistob
))
3194 else return (None
, (stob, iistob
))
3203 then pr2_once
"USING optional_storage builtin isomorphism";
3206 else fail (* inline not in SP and present in C code *)
3209 | Some x
, ((stobis
, inline
)) ->
3212 let rec loop acc
= function
3215 let str = B.str_of_info i1
in
3218 (* not very elegant, but tokenf doesn't know what token to
3220 tokenf x i1
>>= (fun x i1
->
3221 let rebuilt = (List.rev acc
) @ i1
:: iistob
in
3222 return (Some x
, ((stobis
, inline
), rebuilt)))
3223 | _
-> loop (i1
::acc
) iistob
) in
3225 else fail (* SP has inline, but the C code does not *)
3228 and fullType_optional_allminus
allminus tya retb
=
3233 X.distrf_type
minusizer retb
>>= (fun _x retb
->
3237 else return (None
, retb
)
3239 fullType tya retb
>>= (fun tya retb
->
3240 return (Some tya
, retb
)
3245 (*---------------------------------------------------------------------------*)
3247 and compatible_base_type a signa b
=
3248 let ok = return ((),()) in
3251 | Type_cocci.VoidType
, B.Void
3252 | Type_cocci.SizeType
, B.SizeType
3253 | Type_cocci.SSizeType
, B.SSizeType
3254 | Type_cocci.PtrDiffType
, B.PtrDiffType
->
3255 assert (signa
=*= None
);
3257 | Type_cocci.CharType
, B.IntType
B.CChar
when signa
=*= None
->
3259 | Type_cocci.CharType
, B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3260 compatible_sign signa signb
3261 | Type_cocci.ShortType
, B.IntType
(B.Si
(signb
, B.CShort
)) ->
3262 compatible_sign signa signb
3263 | Type_cocci.IntType
, B.IntType
(B.Si
(signb
, B.CInt
)) ->
3264 compatible_sign signa signb
3265 | Type_cocci.LongType
, B.IntType
(B.Si
(signb
, B.CLong
)) ->
3266 compatible_sign signa signb
3267 | _
, B.IntType
(B.Si
(signb
, B.CLongLong
)) ->
3268 pr2_once
"no longlong in cocci";
3270 | Type_cocci.FloatType
, B.FloatType
B.CFloat
->
3271 assert (signa
=*= None
);
3273 | Type_cocci.DoubleType
, B.FloatType
B.CDouble
->
3274 assert (signa
=*= None
);
3276 | _
, B.FloatType
B.CLongDouble
->
3277 pr2_once
"no longdouble in cocci";
3279 | Type_cocci.BoolType
, _
-> failwith
"no booltype in C"
3281 | _
, (B.Void
|B.FloatType _
|B.IntType _
3282 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
3284 and compatible_base_type_meta a signa qua b ii
local =
3286 | Type_cocci.MetaType
(ida
,keep
,inherited
),
3287 B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3288 compatible_sign signa signb
>>= fun _ _
->
3289 let newb = ((qua
, (B.BaseType
(B.IntType
B.CChar
),ii
)),local) in
3290 compatible_type a
newb
3291 | Type_cocci.MetaType
(ida
,keep
,inherited
), B.IntType
(B.Si
(signb
, ty)) ->
3292 compatible_sign signa signb
>>= fun _ _
->
3294 ((qua
, (B.BaseType
(B.IntType
(B.Si
(B.Signed
, ty))),ii
)),local) in
3295 compatible_type a
newb
3296 | _
, B.FloatType
B.CLongDouble
->
3297 pr2_once
"no longdouble in cocci";
3300 | _
, (B.Void
|B.FloatType _
|B.IntType _
3301 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
3304 and compatible_type a
(b
,local) =
3305 let ok = return ((),()) in
3307 let rec loop = function
3308 | Type_cocci.BaseType a
, (qua
, (B.BaseType b
,ii
)) ->
3309 compatible_base_type a None b
3311 | Type_cocci.SignedT
(signa
,None
), (qua
, (B.BaseType b
,ii
)) ->
3312 compatible_base_type
Type_cocci.IntType
(Some signa
) b
3314 | Type_cocci.SignedT
(signa
,Some
ty), (qua
, (B.BaseType b
,ii
)) ->
3316 Type_cocci.BaseType
ty ->
3317 compatible_base_type
ty (Some signa
) b
3318 | Type_cocci.MetaType
(ida
,keep
,inherited
) ->
3319 compatible_base_type_meta
ty (Some signa
) qua b ii
local
3320 | _
-> failwith
"not possible")
3322 | Type_cocci.Pointer a
, (qub
, (B.Pointer b
, ii
)) ->
3324 | Type_cocci.FunctionPointer a
, _
->
3326 "TODO: function pointer type doesn't store enough information to determine compatability"
3327 | Type_cocci.Array a
, (qub
, (B.Array
(eopt
, b
),ii
)) ->
3328 (* no size info for cocci *)
3330 | Type_cocci.StructUnionName
(sua
, name
),
3331 (qub
, (B.StructUnionName
(sub
, sb
),ii
)) ->
3332 if equal_structUnion_type_cocci sua sub
3333 then structure_type_name name sb ii
3335 | Type_cocci.EnumName
(name
),
3336 (qub
, (B.EnumName
(sb
),ii
)) -> structure_type_name name sb ii
3337 | Type_cocci.TypeName sa
, (qub
, (B.TypeName
(namesb
, _typb
),noii
)) ->
3338 let sb = Ast_c.str_of_name namesb
in
3343 | Type_cocci.ConstVol
(qua
, a
), (qub
, b
) ->
3344 if (fst qub
).B.const
&& (fst qub
).B.volatile
3347 pr2_once
("warning: the type is both const & volatile but cocci " ^
3348 "does not handle that");
3354 | Type_cocci.Const
-> (fst qub
).B.const
3355 | Type_cocci.Volatile
-> (fst qub
).B.volatile
3357 then loop (a
,(Ast_c.nQ
, b
))
3360 | Type_cocci.MetaType
(ida
,keep
,inherited
), typb
->
3362 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
3363 X.envf keep inherited
(A.make_mcode ida
, B.MetaTypeVal typb
, max_min)
3367 (* subtil: must be after the MetaType case *)
3368 | a
, (qub
, (B.TypeName
(_namesb
, Some b
), noii
)) ->
3369 (* kind of typedef iso *)
3372 (* for metavariables of type expression *^* *)
3373 | Type_cocci.Unknown
, _
-> ok
3378 B.TypeOfType _
|B.TypeOfExpr _
|B.ParenType _
|
3379 B.EnumName _
|B.StructUnion
(_
, _
, _
)|B.Enum
(_
, _
)
3386 B.StructUnionName
(_
, _
)|
3388 B.Array
(_
, _
)|B.Pointer _
|B.TypeName _
|
3393 and structure_type_name nm
sb ii
=
3395 Type_cocci.NoName
-> ok
3396 | Type_cocci.Name sa
->
3400 | Type_cocci.MV
(ida
,keep
,inherited
) ->
3401 (* degenerate version of MetaId, no transformation possible *)
3402 let (ib1, ib2
) = tuple_of_list2 ii
in
3403 let max_min _
= Lib_parsing_c.lin_col_by_pos
[ib2
] in
3404 let mida = A.make_mcode ida
in
3405 X.envf keep inherited
(mida, B.MetaIdVal
(sb,[]), max_min)
3411 and compatible_sign signa signb
=
3412 let ok = return ((),()) in
3413 match signa
, signb
with
3415 | Some
Type_cocci.Signed
, B.Signed
3416 | Some
Type_cocci.Unsigned
, B.UnSigned
3421 and equal_structUnion_type_cocci a b
=
3423 | Type_cocci.Struct
, B.Struct
-> true
3424 | Type_cocci.Union
, B.Union
-> true
3425 | _
, (B.Struct
| B.Union
) -> false
3429 (*---------------------------------------------------------------------------*)
3430 and inc_file
(a
, before_after
) (b
, h_rel_pos
) =
3432 let rec aux_inc (ass
, bss
) passed
=
3436 let passed = List.rev
passed in
3438 (match before_after
, !h_rel_pos
with
3439 | IncludeNothing
, _
-> true
3440 | IncludeMcodeBefore
, Some x
->
3441 List.mem
passed (x
.Ast_c.first_of
)
3443 | IncludeMcodeAfter
, Some x
->
3444 List.mem
passed (x
.Ast_c.last_of
)
3446 (* no info, maybe cos of a #include <xx.h> that was already in a .h *)
3450 | (A.IncPath x
)::xs
, y
::ys
-> x
=$
= y
&& aux_inc (xs
, ys
) (x
::passed)
3451 | _
-> failwith
"IncDots not in last place or other pb"
3456 | A.Local ass
, B.Local bss
->
3457 aux_inc (ass
, bss
) []
3458 | A.NonLocal ass
, B.NonLocal bss
->
3459 aux_inc (ass
, bss
) []
3464 (*---------------------------------------------------------------------------*)
3466 and (define_params
: sequence
->
3467 (A.define_param list
, (string B.wrap
) B.wrap2 list
) matcher
) =
3468 fun seqstyle eas ebs
->
3470 | Unordered
-> failwith
"not handling ooo"
3472 define_paramsbis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
3473 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
3476 (* todo? facto code with argument and parameters ? *)
3477 and define_paramsbis
= fun eas ebs
->
3479 match A.unwrap ea
with
3480 A.DPdots
(mcode) -> Some
(mcode, None
)
3482 let build_dots (mcode, _optexpr
) = A.DPdots
(mcode) in
3483 let match_comma ea
=
3484 match A.unwrap ea
with
3485 A.DPComma ia1
-> Some ia1
3487 let build_comma ia1
= A.DPComma ia1
in
3488 let match_metalist ea
= None
in
3489 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
3490 let mktermval v
= failwith
"not possible" in
3491 let special_cases ea
eas ebs
= None
in
3492 let no_ii x
= failwith
"not possible" in
3493 list_matcher match_dots build_dots match_comma build_comma
3494 match_metalist build_metalist mktermval
3495 special_cases define_parameter
X.distrf_define_params
no_ii eas ebs
3497 and define_parameter
= fun parama paramb
->
3498 match A.unwrap parama
, paramb
with
3499 A.DParam ida
, (idb
, ii
) ->
3500 let ib1 = tuple_of_list1 ii
in
3501 ident DontKnow ida
(idb
, ib1) >>= (fun ida
(idb
, ib1) ->
3502 return ((A.DParam ida
)+> A.rewrap parama
,(idb
, [ib1])))
3503 | (A.OptDParam _
| A.UniqueDParam _
), _
->
3504 failwith
"handling Opt/Unique for define parameters"
3505 | A.DPcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
3508 (*****************************************************************************)
3510 (*****************************************************************************)
3512 (* no global solution for positions here, because for a statement metavariable
3513 we want a MetaStmtVal, and for the others, it's not clear what we want *)
3515 let rec (rule_elem_node
: (A.rule_elem
, Control_flow_c.node
) matcher
) =
3518 x
>>= (fun a b
-> return (A.rewrap re a
, F.rewrap node b
))
3520 X.all_bound
(A.get_inherited re
) >&&>
3523 match A.unwrap re
, F.unwrap node
with
3525 (* note: the order of the clauses is important. *)
3527 | _
, F.Enter
| _
, F.Exit
| _
, F.ErrorExit
-> fail2()
3529 (* the metaRuleElem contains just '-' information. We dont need to add
3530 * stuff in the environment. If we need stuff in environment, because
3531 * there is a + S somewhere, then this will be done via MetaStmt, not
3533 * Can match TrueNode/FalseNode/... so must be placed before those cases.
3536 | A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
->
3537 let default = A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
in
3538 (match unwrap_node
with
3540 | F.TrueNode
| F.FalseNode
| F.AfterNode
3541 | F.LoopFallThroughNode
| F.FallThroughNode
3543 if X.mode
=*= PatternMode
3546 if mcode_contain_plus (mcodekind mcode)
3547 then failwith
"try add stuff on fake node"
3548 (* minusize or contextize a fake node is ok *)
3551 | F.EndStatement None
->
3552 if X.mode
=*= PatternMode
then return default
3554 (* DEAD CODE NOW ? only useful in -no_cocci_vs_c_3 ?
3555 if mcode_contain_plus (mcodekind mcode)
3557 let fake_info = Ast_c.fakeInfo() in
3558 distrf distrf_node (mcodekind mcode)
3559 (F.EndStatement (Some fake_info))
3560 else return unwrap_node
3564 | F.EndStatement
(Some i1
) ->
3565 tokenf mcode i1
>>= (fun mcode i1
->
3567 A.MetaRuleElem
(mcode,keep
, inherited
),
3568 F.EndStatement
(Some i1
)
3572 if X.mode
=*= PatternMode
then return default
3573 else failwith
"a MetaRuleElem can't transform a headfunc"
3575 if X.mode
=*= PatternMode
then return default
3577 X.distrf_node
(generalize_mcode mcode) node
>>= (fun mcode node
->
3579 A.MetaRuleElem
(mcode,keep
, inherited
),
3585 (* rene cant have found that a state containing a fake/exit/... should be
3587 * TODO: and F.Fake ?
3589 | _
, F.EndStatement _
| _
, F.CaseNode _
3590 | _
, F.TrueNode
| _
, F.FalseNode
| _
, F.AfterNode
3591 | _
, F.FallThroughNode
| _
, F.LoopFallThroughNode
3595 (* really ? diff between pattern.ml and transformation.ml *)
3596 | _
, F.Fake
-> fail2()
3599 (* cas general: a Meta can match everything. It matches only
3600 * "header"-statement. We transform only MetaRuleElem, not MetaStmt.
3601 * So can't have been called in transform.
3603 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), F.Decl
(_
) -> fail
3605 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), unwrap_node
->
3606 (* todo: should not happen in transform mode *)
3608 (match Control_flow_c.extract_fullstatement node
with
3611 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_stmt stb
) in
3612 X.envf keep inherited
(ida
, Ast_c.MetaStmtVal stb
, max_min)
3614 (* no need tag ida, we can't be called in transform-mode *)
3616 A.MetaStmt
(ida
, keep
, metainfoMaybeTodo
, inherited
),
3624 | A.MetaStmtList _
, _
->
3625 failwith
"not handling MetaStmtList"
3627 | A.TopExp ea
, F.DefineExpr eb
->
3628 expression ea eb
>>= (fun ea eb
->
3634 | A.TopExp ea
, F.DefineType eb
->
3635 (match A.unwrap ea
with
3637 fullType ft eb
>>= (fun ft eb
->
3639 A.TopExp
(A.rewrap ea
(A.TypeExp
(ft
))),
3646 (* It is important to put this case before the one that fails because
3647 * of the lack of the counter part of a C construct in SmPL (for instance
3648 * there is not yet a CaseRange in SmPL). Even if SmPL don't handle
3649 * yet certain constructs, those constructs may contain expression
3650 * that we still want and can transform.
3653 | A.Exp exp
, nodeb
->
3655 (* kind of iso, initialisation vs affectation *)
3657 match A.unwrap exp
, nodeb
with
3658 | A.Assignment
(ea
, op
, eb
, true), F.Decl decl
->
3659 initialisation_to_affectation decl
+> F.rewrap node
3664 (* Now keep fullstatement inside the control flow node,
3665 * so that can then get in a MetaStmtVar the fullstatement to later
3666 * pp back when the S is in a +. But that means that
3667 * Exp will match an Ifnode even if there is no such exp
3668 * inside the condition of the Ifnode (because the exp may
3669 * be deeper, in the then branch). So have to not visit
3670 * all inside a node anymore.
3672 * update: j'ai choisi d'accrocher au noeud du CFG Ã la
3673 * fois le fullstatement et le partialstatement et appeler le
3674 * visiteur que sur le partialstatement.
3677 match Ast_cocci.get_pos re
with
3678 | None
-> expression
3682 Lib_parsing_c.max_min_by_pos
(Lib_parsing_c.ii_of_expr eb
) in
3683 let keep = Type_cocci.Unitary
in
3684 let inherited = false in
3685 let max_min _
= failwith
"no pos" in
3686 X.envf
keep inherited (pos
, B.MetaPosVal
(min
,max
), max_min)
3692 X.cocciExp
expfn exp
node >>= (fun exp
node ->
3700 X.cocciTy fullType
ty node >>= (fun ty node ->
3707 | A.TopInit init
, nodeb
->
3708 X.cocciInit initialiser init
node >>= (fun init
node ->
3716 | A.FunHeader
(mckstart
, allminus, fninfoa
, ida
, oparen
, paramsa, cparen
),
3717 F.FunHeader
({B.f_name
= nameidb
;
3718 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3722 f_old_c_style
= oldstyle
;
3727 then pr2 "OLD STYLE DECL NOT WELL SUPPORTED";
3730 (* fninfoa records the order in which the SP specified the various
3731 information, but this isn't taken into account in the matching.
3732 Could this be a problem for transformation? *)
3735 List.filter
(function A.FStorage
(s) -> true | _
-> false) fninfoa
3736 with [A.FStorage
(s)] -> Some
s | _
-> None
in
3738 match List.filter
(function A.FType
(s) -> true | _
-> false) fninfoa
3739 with [A.FType
(t
)] -> Some t
| _
-> None
in
3742 match List.filter
(function A.FInline
(i
) -> true | _
-> false) fninfoa
3743 with [A.FInline
(i
)] -> Some i
| _
-> None
in
3745 (match List.filter
(function A.FAttr
(a
) -> true | _
-> false) fninfoa
3746 with [A.FAttr
(a
)] -> failwith
"not checking attributes" | _
-> ());
3749 | ioparenb
::icparenb
::iifakestart
::iistob
->
3751 (* maybe important to put ident as the first tokens to transform.
3752 * It's related to transform_proto. So don't change order
3755 ident_cpp LocalFunction ida nameidb
>>= (fun ida nameidb
->
3756 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
3757 tokenf oparen ioparenb
>>= (fun oparen ioparenb
->
3758 tokenf cparen icparenb
>>= (fun cparen icparenb
->
3759 parameters
(seqstyle paramsa)
3760 (A.undots
paramsa) paramsb
>>=
3761 (fun paramsaundots paramsb
->
3762 let paramsa = redots
paramsa paramsaundots
in
3763 inline_optional_allminus
allminus
3764 inla (stob, iistob
) >>= (fun inla (stob, iistob
) ->
3765 storage_optional_allminus
allminus
3766 stoa (stob, iistob
) >>= (fun stoa (stob, iistob
) ->
3771 ("Not handling well variable length arguments func. "^
3772 "You have been warned");
3774 then minusize_list iidotsb
3775 else return ((),iidotsb
)
3776 ) >>= (fun () iidotsb
->
3778 fullType_optional_allminus
allminus tya retb
>>= (fun tya retb
->
3781 (match stoa with Some st
-> [A.FStorage st
] | None
-> []) ++
3782 (match inla with Some i
-> [A.FInline i
] | None
-> []) ++
3783 (match tya with Some t
-> [A.FType t
] | None
-> [])
3788 A.FunHeader
(mckstart
,allminus,fninfoa,ida
,oparen
,
3790 F.FunHeader
({B.f_name
= nameidb
;
3791 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3795 f_old_c_style
= oldstyle
; (* TODO *)
3797 ioparenb
::icparenb
::iifakestart
::iistob
)
3800 | _
-> raise Impossible
3808 | A.Decl
(mckstart
,allminus,decla
), F.Decl declb
->
3809 declaration
(mckstart
,allminus,decla
) declb
>>=
3810 (fun (mckstart
,allminus,decla
) declb
->
3812 A.Decl
(mckstart
,allminus,decla
),
3817 | A.SeqStart
mcode, F.SeqStart
(st
, level
, i1
) ->
3818 tokenf mcode i1
>>= (fun mcode i1
->
3821 F.SeqStart
(st
, level
, i1
)
3824 | A.SeqEnd
mcode, F.SeqEnd
(level
, i1
) ->
3825 tokenf mcode i1
>>= (fun mcode i1
->
3828 F.SeqEnd
(level
, i1
)
3831 | A.ExprStatement
(ea
, ia1
), F.ExprStatement
(st
, (Some eb
, ii
)) ->
3832 let ib1 = tuple_of_list1 ii
in
3833 expression ea eb
>>= (fun ea eb
->
3834 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3836 A.ExprStatement
(ea
, ia1
),
3837 F.ExprStatement
(st
, (Some eb
, [ib1]))
3842 | A.IfHeader
(ia1
,ia2
, ea
, ia3
), F.IfHeader
(st
, (eb
,ii
)) ->
3843 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3844 expression ea eb
>>= (fun ea eb
->
3845 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3846 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3847 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3849 A.IfHeader
(ia1
, ia2
, ea
, ia3
),
3850 F.IfHeader
(st
, (eb
,[ib1;ib2
;ib3
]))
3853 | A.Else ia
, F.Else ib
->
3854 tokenf ia ib
>>= (fun ia ib
->
3855 return (A.Else ia
, F.Else ib
)
3858 | A.WhileHeader
(ia1
, ia2
, ea
, ia3
), F.WhileHeader
(st
, (eb
, ii
)) ->
3859 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3860 expression ea eb
>>= (fun ea eb
->
3861 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3862 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3863 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3865 A.WhileHeader
(ia1
, ia2
, ea
, ia3
),
3866 F.WhileHeader
(st
, (eb
, [ib1;ib2
;ib3
]))
3869 | A.DoHeader ia
, F.DoHeader
(st
, ib
) ->
3870 tokenf ia ib
>>= (fun ia ib
->
3875 | A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
), F.DoWhileTail
(eb
, ii
) ->
3876 let (ib1, ib2
, ib3
, ib4
) = tuple_of_list4 ii
in
3877 expression ea eb
>>= (fun ea eb
->
3878 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3879 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3880 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3881 tokenf ia4 ib4
>>= (fun ia4 ib4
->
3883 A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
),
3884 F.DoWhileTail
(eb
, [ib1;ib2
;ib3
;ib4
])
3886 | A.IteratorHeader
(ia1
, ia2
, eas, ia3
), F.MacroIterHeader
(st
, ((s,ebs
),ii
))
3888 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3890 ident DontKnow ia1
(s, ib1) >>= (fun ia1
(s, ib1) ->
3891 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3892 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3893 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
3894 let eas = redots
eas easundots
in
3896 A.IteratorHeader
(ia1
, ia2
, eas, ia3
),
3897 F.MacroIterHeader
(st
, ((s,ebs
), [ib1;ib2
;ib3
]))
3902 | A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3903 F.ForHeader
(st
, (((eb1opt
,ib3s
), (eb2opt
,ib4s
), (eb3opt
,ib4vide
)), ii
))
3905 assert (null ib4vide
);
3906 let (ib1, ib2
, ib5
) = tuple_of_list3 ii
in
3907 let ib3 = tuple_of_list1 ib3s
in
3908 let ib4 = tuple_of_list1 ib4s
in
3910 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3911 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3912 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3913 tokenf ia4
ib4 >>= (fun ia4
ib4 ->
3914 tokenf ia5 ib5
>>= (fun ia5 ib5
->
3915 option expression ea1opt eb1opt
>>= (fun ea1opt eb1opt
->
3916 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
3917 option expression ea3opt eb3opt
>>= (fun ea3opt eb3opt
->
3919 A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3920 F.ForHeader
(st
, (((eb1opt
,[ib3]), (eb2opt
,[ib4]), (eb3opt
,[])),
3926 | A.SwitchHeader
(ia1
,ia2
,ea
,ia3
), F.SwitchHeader
(st
, (eb
,ii
)) ->
3927 let (ib1, ib2
, ib3) = tuple_of_list3 ii
in
3928 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3929 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3930 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3931 expression ea eb
>>= (fun ea eb
->
3933 A.SwitchHeader
(ia1
,ia2
,ea
,ia3
),
3934 F.SwitchHeader
(st
, (eb
,[ib1;ib2
;ib3]))
3937 | A.Break
(ia1
, ia2
), F.Break
(st
, ((),ii
)) ->
3938 let (ib1, ib2
) = tuple_of_list2 ii
in
3939 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3940 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3943 F.Break
(st
, ((),[ib1;ib2
]))
3946 | A.Continue
(ia1
, ia2
), F.Continue
(st
, ((),ii
)) ->
3947 let (ib1, ib2
) = tuple_of_list2 ii
in
3948 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3949 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3951 A.Continue
(ia1
, ia2
),
3952 F.Continue
(st
, ((),[ib1;ib2
]))
3955 | A.Return
(ia1
, ia2
), F.Return
(st
, ((),ii
)) ->
3956 let (ib1, ib2
) = tuple_of_list2 ii
in
3957 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3958 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3960 A.Return
(ia1
, ia2
),
3961 F.Return
(st
, ((),[ib1;ib2
]))
3964 | A.ReturnExpr
(ia1
, ea
, ia2
), F.ReturnExpr
(st
, (eb
, ii
)) ->
3965 let (ib1, ib2
) = tuple_of_list2 ii
in
3966 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3967 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3968 expression ea eb
>>= (fun ea eb
->
3970 A.ReturnExpr
(ia1
, ea
, ia2
),
3971 F.ReturnExpr
(st
, (eb
, [ib1;ib2
]))
3976 | A.Include
(incla
,filea
),
3977 F.Include
{B.i_include
= (fileb
, ii
);
3978 B.i_rel_pos
= h_rel_pos
;
3979 B.i_is_in_ifdef
= inifdef
;
3982 assert (copt
=*= None
);
3984 let include_requirment =
3985 match mcodekind incla
, mcodekind filea
with
3986 | A.CONTEXT
(_
, A.BEFORE _
), _
->
3988 | _
, A.CONTEXT
(_
, A.AFTER _
) ->
3994 let (inclb
, iifileb
) = tuple_of_list2 ii
in
3995 if inc_file
(term filea
, include_requirment) (fileb
, h_rel_pos
)
3997 tokenf incla inclb
>>= (fun incla inclb
->
3998 tokenf filea iifileb
>>= (fun filea iifileb
->
4000 A.Include
(incla
, filea
),
4001 F.Include
{B.i_include
= (fileb
, [inclb
;iifileb
]);
4002 B.i_rel_pos
= h_rel_pos
;
4003 B.i_is_in_ifdef
= inifdef
;
4011 | A.DefineHeader
(definea
,ida
,params
), F.DefineHeader
((idb
, ii
), defkind
) ->
4012 let (defineb
, iidb
, ieol
) = tuple_of_list3 ii
in
4013 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
4014 tokenf definea defineb
>>= (fun definea defineb
->
4015 (match A.unwrap params
, defkind
with
4016 | A.NoParams
, B.DefineVar
->
4018 A.NoParams
+> A.rewrap params
,
4021 | A.DParams
(lpa
,eas,rpa
), (B.DefineFunc
(ebs
, ii
)) ->
4022 let (lpb
, rpb
) = tuple_of_list2 ii
in
4023 tokenf lpa lpb
>>= (fun lpa lpb
->
4024 tokenf rpa rpb
>>= (fun rpa rpb
->
4026 define_params
(seqstyle eas) (A.undots
eas) ebs
>>=
4027 (fun easundots ebs
->
4028 let eas = redots
eas easundots
in
4030 A.DParams
(lpa
,eas,rpa
) +> A.rewrap params
,
4031 B.DefineFunc
(ebs
,[lpb
;rpb
])
4035 ) >>= (fun params defkind
->
4037 A.DefineHeader
(definea
, ida
, params
),
4038 F.DefineHeader
((idb
,[defineb
;iidb
;ieol
]),defkind
)
4043 | A.Default
(def
,colon
), F.Default
(st
, ((),ii
)) ->
4044 let (ib1, ib2
) = tuple_of_list2 ii
in
4045 tokenf def
ib1 >>= (fun def
ib1 ->
4046 tokenf colon ib2
>>= (fun colon ib2
->
4048 A.Default
(def
,colon
),
4049 F.Default
(st
, ((),[ib1;ib2
]))
4054 | A.Case
(case
,ea
,colon
), F.Case
(st
, (eb
,ii
)) ->
4055 let (ib1, ib2
) = tuple_of_list2 ii
in
4056 tokenf case
ib1 >>= (fun case
ib1 ->
4057 expression ea eb
>>= (fun ea eb
->
4058 tokenf colon ib2
>>= (fun colon ib2
->
4060 A.Case
(case
,ea
,colon
),
4061 F.Case
(st
, (eb
,[ib1;ib2
]))
4064 (* only occurs in the predicates generated by asttomember *)
4065 | A.DisjRuleElem
eas, _
->
4067 List.fold_left
(fun acc ea
-> acc
>|+|> (rule_elem_node ea
node)) fail)
4068 >>= (fun ea eb
-> return (A.unwrap ea
,F.unwrap eb
))
4070 | _
, F.ExprStatement
(_
, (None
, ii
)) -> fail (* happen ? *)
4072 | A.Label
(id
,dd
), F.Label
(st
, nameb
, ((),ii
)) ->
4073 let (ib2
) = tuple_of_list1 ii
in
4074 ident_cpp DontKnow id nameb
>>= (fun ida nameb
->
4075 tokenf dd ib2
>>= (fun dd ib2
->
4078 F.Label
(st
,nameb
, ((),[ib2
]))
4081 | A.Goto
(goto
,id
,sem
), F.Goto
(st
,nameb
, ((),ii
)) ->
4082 let (ib1,ib3) = tuple_of_list2 ii
in
4083 tokenf goto
ib1 >>= (fun goto
ib1 ->
4084 ident_cpp DontKnow id nameb
>>= (fun id nameb
->
4085 tokenf sem
ib3 >>= (fun sem
ib3 ->
4087 A.Goto
(goto
,id
,sem
),
4088 F.Goto
(st
,nameb
, ((),[ib1;ib3]))
4091 (* have not a counter part in coccinelle, for the moment *)
4092 (* todo?: print a warning at least ? *)
4098 | _
, (F.IfdefEndif _
|F.IfdefElse _
|F.IfdefHeader _
)
4102 (F.MacroStmt
(_
, _
)| F.DefineDoWhileZeroHeader _
| F.EndNode
|F.TopNode
)
4105 (F.Label
(_
, _
, _
)|F.Break
(_
, _
)|F.Continue
(_
, _
)|F.Default
(_
, _
)|
4106 F.Case
(_
, _
)|F.Include _
|F.Goto _
|F.ExprStatement _
|
4107 F.DefineType _
|F.DefineExpr _
|F.DefineTodo
|
4108 F.DefineHeader
(_
, _
)|F.ReturnExpr
(_
, _
)|F.Return
(_
, _
)|F.MacroIterHeader
(_
, _
)|
4109 F.SwitchHeader
(_
, _
)|F.ForHeader
(_
, _
)|F.DoWhileTail _
|F.DoHeader
(_
, _
)|
4110 F.WhileHeader
(_
, _
)|F.Else _
|F.IfHeader
(_
, _
)|
4111 F.SeqEnd
(_
, _
)|F.SeqStart
(_
, _
, _
)|
4112 F.Decl _
|F.FunHeader _
)