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.
25 (* Yoann Padioleau, Julia Lawall
27 * Copyright (C) 2006, 2007, 2008 Ecole des Mines de Nantes
28 * Copyright (C) 2009, 2010 DIKU, INRIA, LIP6
30 * This program is free software; you can redistribute it and/or
31 * modify it under the terms of the GNU General Public License (GPL)
32 * version 2 as published by the Free Software Foundation.
34 * This program is distributed in the hope that it will be useful,
35 * but WITHOUT ANY WARRANTY; without even the implied warranty of
36 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
37 * file license.txt for more details.
39 * This file was part of Coccinelle.
47 module F
= Control_flow_c
49 module Flag
= Flag_matcher
51 (*****************************************************************************)
53 (*****************************************************************************)
54 let pr2, pr2_once
= Common.mk_pr2_wrappers
Flag_matcher.verbose_matcher
56 let (+++) a b
= match a
with Some x
-> Some x
| None
-> b
58 (*****************************************************************************)
60 (*****************************************************************************)
62 type sequence
= Ordered
| Unordered
65 match A.unwrap eas
with
67 | A.CIRCLES _
-> Unordered
68 | A.STARS _
-> failwith
"not handling stars"
70 let (redots
: 'a
A.dots
-> 'a list
-> 'a
A.dots
)=fun eas easundots
->
72 match A.unwrap eas
with
73 | A.DOTS _
-> A.DOTS easundots
74 | A.CIRCLES _
-> A.CIRCLES easundots
75 | A.STARS _
-> A.STARS easundots
79 let (need_unordered_initialisers
: B.initialiser
B.wrap2 list
-> bool) =
81 ibs
+> List.exists
(fun (ib
, icomma
) ->
82 match B.unwrap ib
with
91 (* For the #include <linux/...> in the .cocci, need to find where is
92 * the '+' attached to this element, to later find the first concrete
93 * #include <linux/xxx.h> or last one in the series of #includes in the
96 type include_requirement
=
103 (* todo? put in semantic_c.ml *)
106 | LocalFunction
(* entails Function *)
110 let term mc
= A.unwrap_mcode mc
111 let mcodekind mc
= A.get_mcodekind mc
114 let mcode_contain_plus = function
115 | A.CONTEXT
(_
,A.NOTHING
) -> false
116 | A.CONTEXT _
-> true
117 | A.MINUS
(_
,_
,_
,[]) -> false
118 | A.MINUS
(_
,_
,_
,x
::xs
) -> true
119 | A.PLUS _
-> raise Impossible
121 let mcode_simple_minus = function
122 | A.MINUS
(_
,_
,_
,[]) -> true
126 (* In transformation.ml sometime I build some mcodekind myself and
127 * julia has put None for the pos. But there is no possible raise
128 * NoMatch in those cases because it is for the minusall trick or for
129 * the distribute, so either have to build those pos, in fact a range,
130 * because for the distribute have to erase a fullType with one
131 * mcodekind, or add an argument to tag_with_mck such as "safe" that
132 * don't do the check_pos. Hence this DontCarePos constructor. *)
136 {A.line
= 0; A.column
=0; A.strbef
=[]; A.straft
=[];},
137 (A.MINUS
(A.DontCarePos
,[],-1,[])),
140 let generalize_mcode ia
=
141 let (s1
, i
, mck
, pos
) = ia
in
144 | A.PLUS _
-> raise Impossible
145 | A.CONTEXT
(A.NoPos
,x
) ->
146 A.CONTEXT
(A.DontCarePos
,x
)
147 | A.MINUS
(A.NoPos
,inst
,adj
,x
) ->
148 A.MINUS
(A.DontCarePos
,inst
,adj
,x
)
150 | A.CONTEXT
((A.FixPos _
|A.DontCarePos
), _
)
151 | A.MINUS
((A.FixPos _
|A.DontCarePos
), _
, _
, _
)
155 (s1
, i
, new_mck, pos
)
159 (*---------------------------------------------------------------------------*)
161 (* 0x0 is equivalent to 0, value format isomorphism *)
162 let equal_c_int s1 s2
=
164 int_of_string s1
=|= int_of_string s2
165 with Failure
("int_of_string") ->
170 (*---------------------------------------------------------------------------*)
171 (* Normally A should reuse some types of Ast_c, so those
172 * functions should not exist.
174 * update: but now Ast_c depends on A, so can't make too
175 * A depends on Ast_c, so have to stay with those equal_xxx
179 let equal_unaryOp a b
=
181 | A.GetRef
, B.GetRef
-> true
182 | A.DeRef
, B.DeRef
-> true
183 | A.UnPlus
, B.UnPlus
-> true
184 | A.UnMinus
, B.UnMinus
-> true
185 | A.Tilde
, B.Tilde
-> true
186 | A.Not
, B.Not
-> true
187 | _
, B.GetRefLabel
-> false (* todo cocci? *)
188 | _
, (B.Not
|B.Tilde
|B.UnMinus
|B.UnPlus
|B.DeRef
|B.GetRef
) -> false
192 let equal_arithOp a b
=
194 | A.Plus
, B.Plus
-> true
195 | A.Minus
, B.Minus
-> true
196 | A.Mul
, B.Mul
-> true
197 | A.Div
, B.Div
-> true
198 | A.Mod
, B.Mod
-> true
199 | A.DecLeft
, B.DecLeft
-> true
200 | A.DecRight
, B.DecRight
-> true
201 | A.And
, B.And
-> true
202 | A.Or
, B.Or
-> true
203 | A.Xor
, B.Xor
-> true
204 | _
, (B.Xor
|B.Or
|B.And
|B.DecRight
|B.DecLeft
|B.Mod
|B.Div
|B.Mul
|B.Minus
|B.Plus
)
207 let equal_logicalOp a b
=
209 | A.Inf
, B.Inf
-> true
210 | A.Sup
, B.Sup
-> true
211 | A.InfEq
, B.InfEq
-> true
212 | A.SupEq
, B.SupEq
-> true
213 | A.Eq
, B.Eq
-> true
214 | A.NotEq
, B.NotEq
-> true
215 | A.AndLog
, B.AndLog
-> true
216 | A.OrLog
, B.OrLog
-> true
217 | _
, (B.OrLog
|B.AndLog
|B.NotEq
|B.Eq
|B.SupEq
|B.InfEq
|B.Sup
|B.Inf
)
220 let equal_assignOp a b
=
222 | A.SimpleAssign
, B.SimpleAssign
-> true
223 | A.OpAssign a
, B.OpAssign b
-> equal_arithOp a b
224 | _
, (B.OpAssign _
|B.SimpleAssign
) -> false
226 let equal_fixOp a b
=
228 | A.Dec
, B.Dec
-> true
229 | A.Inc
, B.Inc
-> true
230 | _
, (B.Inc
|B.Dec
) -> false
232 let equal_binaryOp a b
=
234 | A.Arith a
, B.Arith b
-> equal_arithOp a b
235 | A.Logical a
, B.Logical b
-> equal_logicalOp a b
236 | _
, (B.Logical _
| B.Arith _
) -> false
238 let equal_structUnion a b
=
240 | A.Struct
, B.Struct
-> true
241 | A.Union
, B.Union
-> true
242 | _
, (B.Struct
|B.Union
) -> false
246 | A.Signed
, B.Signed
-> true
247 | A.Unsigned
, B.UnSigned
-> true
248 | _
, (B.UnSigned
|B.Signed
) -> false
250 let equal_storage a b
=
252 | A.Static
, B.Sto
B.Static
253 | A.Auto
, B.Sto
B.Auto
254 | A.Register
, B.Sto
B.Register
255 | A.Extern
, B.Sto
B.Extern
257 | _
, (B.NoSto
| B.StoTypedef
) -> false
258 | _
, (B.Sto
(B.Register
|B.Static
|B.Auto
|B.Extern
)) -> false
261 (*---------------------------------------------------------------------------*)
263 let equal_metavarval valu valu'
=
264 match valu
, valu'
with
265 | Ast_c.MetaIdVal
(a
,_
), Ast_c.MetaIdVal
(b
,_
) -> a
=$
= b
266 | Ast_c.MetaFuncVal a
, Ast_c.MetaFuncVal b
-> a
=$
= b
267 | Ast_c.MetaLocalFuncVal a
, Ast_c.MetaLocalFuncVal b
->
268 (* do something more ? *)
271 (* al_expr before comparing !!! and accept when they match.
272 * Note that here we have Astc._expression, so it is a match
273 * modulo isomorphism (there is no metavariable involved here,
274 * just isomorphisms). => TODO call isomorphism_c_c instead of
275 * =*=. Maybe would be easier to transform ast_c in ast_cocci
276 * and call the iso engine of julia. *)
277 | Ast_c.MetaExprVal
(a
,_
), Ast_c.MetaExprVal
(b
,_
) ->
278 Lib_parsing_c.al_expr a
=*= Lib_parsing_c.al_expr b
279 | Ast_c.MetaExprListVal a
, Ast_c.MetaExprListVal b
->
280 Lib_parsing_c.al_arguments a
=*= Lib_parsing_c.al_arguments b
282 | Ast_c.MetaDeclVal a
, Ast_c.MetaDeclVal b
->
283 Lib_parsing_c.al_declaration a
=*= Lib_parsing_c.al_declaration b
284 | Ast_c.MetaFieldVal a
, Ast_c.MetaFieldVal b
->
285 Lib_parsing_c.al_field a
=*= Lib_parsing_c.al_field b
286 | Ast_c.MetaStmtVal a
, Ast_c.MetaStmtVal b
->
287 Lib_parsing_c.al_statement a
=*= Lib_parsing_c.al_statement b
288 | Ast_c.MetaInitVal a
, Ast_c.MetaInitVal b
->
289 Lib_parsing_c.al_init a
=*= Lib_parsing_c.al_init b
290 | Ast_c.MetaTypeVal a
, Ast_c.MetaTypeVal b
->
291 (* old: Lib_parsing_c.al_type a =*= Lib_parsing_c.al_type b *)
294 | Ast_c.MetaListlenVal a
, Ast_c.MetaListlenVal b
-> a
=|= b
296 | Ast_c.MetaParamVal a
, Ast_c.MetaParamVal b
->
297 Lib_parsing_c.al_param a
=*= Lib_parsing_c.al_param b
298 | Ast_c.MetaParamListVal a
, Ast_c.MetaParamListVal b
->
299 Lib_parsing_c.al_params a
=*= Lib_parsing_c.al_params b
301 | Ast_c.MetaPosVal
(posa1
,posa2
), Ast_c.MetaPosVal
(posb1
,posb2
) ->
302 Ast_cocci.equal_pos posa1 posb1
&& Ast_cocci.equal_pos posa2 posb2
304 | Ast_c.MetaPosValList l1
, Ast_c.MetaPosValList l2
->
306 (function (fla
,cea
,posa1
,posa2
) ->
308 (function (flb
,ceb
,posb1
,posb2
) ->
309 fla
=$
= flb
&& cea
=$
= ceb
&&
310 Ast_c.equal_posl posa1 posb1
&& Ast_c.equal_posl posa2 posb2
)
314 | (B.MetaPosValList _
|B.MetaListlenVal _
|B.MetaPosVal _
|B.MetaStmtVal _
315 |B.MetaDeclVal _
|B.MetaFieldVal _
|B.MetaTypeVal _
|B.MetaInitVal _
316 |B.MetaParamListVal _
|B.MetaParamVal _
|B.MetaExprListVal _
317 |B.MetaExprVal _
|B.MetaLocalFuncVal _
|B.MetaFuncVal _
|B.MetaIdVal _
321 (* probably only one argument needs to be stripped, because inherited
322 metavariables containing expressions are stripped in advance. But don't
323 know which one is which... *)
324 let equal_inh_metavarval valu valu'
=
325 match valu
, valu'
with
326 | Ast_c.MetaIdVal
(a
,_
), Ast_c.MetaIdVal
(b
,_
) -> a
=$
= b
327 | Ast_c.MetaFuncVal a
, Ast_c.MetaFuncVal b
-> a
=$
= b
328 | Ast_c.MetaLocalFuncVal a
, Ast_c.MetaLocalFuncVal b
->
329 (* do something more ? *)
332 (* al_expr before comparing !!! and accept when they match.
333 * Note that here we have Astc._expression, so it is a match
334 * modulo isomorphism (there is no metavariable involved here,
335 * just isomorphisms). => TODO call isomorphism_c_c instead of
336 * =*=. Maybe would be easier to transform ast_c in ast_cocci
337 * and call the iso engine of julia. *)
338 | Ast_c.MetaExprVal
(a
,_
), Ast_c.MetaExprVal
(b
,_
) ->
339 Lib_parsing_c.al_inh_expr a
=*= Lib_parsing_c.al_inh_expr b
340 | Ast_c.MetaExprListVal a
, Ast_c.MetaExprListVal b
->
341 Lib_parsing_c.al_inh_arguments a
=*= Lib_parsing_c.al_inh_arguments b
343 | Ast_c.MetaDeclVal a
, Ast_c.MetaDeclVal b
->
344 Lib_parsing_c.al_inh_declaration a
=*= Lib_parsing_c.al_inh_declaration b
345 | Ast_c.MetaFieldVal a
, Ast_c.MetaFieldVal b
->
346 Lib_parsing_c.al_inh_field a
=*= Lib_parsing_c.al_inh_field b
347 | Ast_c.MetaStmtVal a
, Ast_c.MetaStmtVal b
->
348 Lib_parsing_c.al_inh_statement a
=*= Lib_parsing_c.al_inh_statement b
349 | Ast_c.MetaInitVal a
, Ast_c.MetaInitVal b
->
350 Lib_parsing_c.al_inh_init a
=*= Lib_parsing_c.al_inh_init b
351 | Ast_c.MetaTypeVal a
, Ast_c.MetaTypeVal b
->
352 (* old: Lib_parsing_c.al_inh_type a =*= Lib_parsing_c.al_inh_type b *)
355 | Ast_c.MetaListlenVal a
, Ast_c.MetaListlenVal b
-> a
=|= b
357 | Ast_c.MetaParamVal a
, Ast_c.MetaParamVal b
->
358 Lib_parsing_c.al_param a
=*= Lib_parsing_c.al_param b
359 | Ast_c.MetaParamListVal a
, Ast_c.MetaParamListVal b
->
360 Lib_parsing_c.al_params a
=*= Lib_parsing_c.al_params b
362 | Ast_c.MetaPosVal
(posa1
,posa2
), Ast_c.MetaPosVal
(posb1
,posb2
) ->
363 Ast_cocci.equal_pos posa1 posb1
&& Ast_cocci.equal_pos posa2 posb2
365 | Ast_c.MetaPosValList l1
, Ast_c.MetaPosValList l2
->
367 (function (fla
,cea
,posa1
,posa2
) ->
369 (function (flb
,ceb
,posb1
,posb2
) ->
370 fla
=$
= flb
&& cea
=$
= ceb
&&
371 Ast_c.equal_posl posa1 posb1
&& Ast_c.equal_posl posa2 posb2
)
375 | (B.MetaPosValList _
|B.MetaListlenVal _
|B.MetaPosVal _
|B.MetaStmtVal _
376 |B.MetaDeclVal _
|B.MetaFieldVal _
|B.MetaTypeVal _
|B.MetaInitVal _
377 |B.MetaParamListVal _
|B.MetaParamVal _
|B.MetaExprListVal _
378 |B.MetaExprVal _
|B.MetaLocalFuncVal _
|B.MetaFuncVal _
|B.MetaIdVal _
383 (*---------------------------------------------------------------------------*)
384 (* could put in ast_c.ml, next to the split/unsplit_comma *)
385 let split_signb_baseb_ii (baseb
, ii
) =
386 let iis = ii
+> List.map
(fun info
-> (B.str_of_info info
), info
) in
387 match baseb
, iis with
389 | B.Void
, ["void",i1
] -> None
, [i1
]
391 | B.FloatType
(B.CFloat
),["float",i1
] -> None
, [i1
]
392 | B.FloatType
(B.CDouble
),["double",i1
] -> None
, [i1
]
393 | B.FloatType
(B.CLongDouble
),["long",i1
;"double",i2
] -> None
,[i1
;i2
]
395 | B.IntType
(B.CChar
), ["char",i1
] -> None
, [i1
]
398 | B.IntType
(B.Si
(sign
, base
)), xs
->
402 | (B.Signed
,(("signed",i1
)::rest
)) -> (Some
(B.Signed
,i1
),rest
)
403 | (B.Signed
,rest
) -> (None
,rest
)
404 | (B.UnSigned
,(("unsigned",i1
)::rest
)) -> (Some
(B.UnSigned
,i1
),rest
)
405 | (B.UnSigned
,rest
) -> (* is this case possible? *) (None
,rest
) in
406 (* The original code only allowed explicit signed and unsigned for char,
407 while this code allows char by itself. Not sure that needs to be
408 checked for here. If it does, then add a special case. *)
410 match (base
,rest
) with
411 B.CInt
, ["int",i1
] -> [i1
]
414 | B.CInt
, ["",i1
] -> (* no type is specified at all *)
415 (match i1
.B.pinfo
with
417 | _
-> failwith
("unrecognized signed int: "^
418 (String.concat
" "(List.map fst
iis))))
420 | B.CChar2
, ["char",i2
] -> [i2
]
422 | B.CShort
, ["short",i1
] -> [i1
]
423 | B.CShort
, ["short",i1
;"int",i2
] -> [i1
;i2
]
425 | B.CLong
, ["long",i1
] -> [i1
]
426 | B.CLong
, ["long",i1
;"int",i2
] -> [i1
;i2
]
428 | B.CLongLong
, ["long",i1
;"long",i2
] -> [i1
;i2
]
429 | B.CLongLong
, ["long",i1
;"long",i2
;"int",i3
] -> [i1
;i2
;i3
]
432 failwith
("strange type1, maybe because of weird order: "^
433 (String.concat
" " (List.map fst
iis))) in
435 | _
-> failwith
("strange type2, maybe because of weird order: "^
436 (String.concat
" " (List.map fst
iis)))
438 (*---------------------------------------------------------------------------*)
440 let rec unsplit_icomma xs
=
444 (match A.unwrap y
with
446 (x
, y
)::unsplit_icomma xs
447 | _
-> failwith
"wrong ast_cocci in initializer"
450 failwith
("wrong ast_cocci in initializer, should have pair " ^
455 let resplit_initialiser ibs iicomma
=
456 match iicomma
, ibs
with
459 failwith
"should have a iicomma, do you generate fakeInfo in parser?"
461 failwith
"shouldn't have a iicomma"
462 | [iicomma
], x
::xs
->
463 let elems = List.map fst
(x
::xs
) in
464 let commas = List.map snd
(x
::xs
) +> List.flatten
in
465 let commas = commas @ [iicomma
] in
467 | _
-> raise Impossible
471 let rec split_icomma xs
=
474 | (x
,y
)::xs
-> x
::y
::split_icomma xs
476 let rec unsplit_initialiser ibs_unsplit
=
477 match ibs_unsplit
with
478 | [] -> [], [] (* empty iicomma *)
480 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
481 (x
, [])::xs
, lastcomma
483 and unsplit_initialiser_bis comma_before
= function
484 | [] -> [], [comma_before
]
486 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
487 (x
, [comma_before
])::xs
, lastcomma
492 (*---------------------------------------------------------------------------*)
493 (* coupling: same in type_annotater_c.ml *)
494 let structdef_to_struct_name ty
=
496 | qu
, (B.StructUnion
(su
, sopt
, fields
), iis) ->
498 | Some s
, [i1
;i2
;i3
;i4
] ->
499 qu
, (B.StructUnionName
(su
, s
), [i1
;i2
])
503 | x
-> raise Impossible
505 | _
-> raise Impossible
507 (*---------------------------------------------------------------------------*)
508 let initialisation_to_affectation decl
=
510 | B.MacroDecl _
-> F.Decl decl
511 | B.DeclList
(xs
, iis) ->
513 (* todo?: should not do that if the variable is an array cos
514 * will have x[] = , mais de toute facon ca sera pas un InitExp
517 | [] -> raise Impossible
519 let ({B.v_namei
= var
;
520 B.v_type
= returnType
;
521 B.v_type_bis
= tybis
;
522 B.v_storage
= storage
;
529 | Some
(name
, iniopt
) ->
531 | Some
(iini
, (B.InitExpr e
, ii_empty2
)) ->
535 Ast_c.NotLocalDecl
-> Ast_c.NotLocalVar
537 Ast_c.LocalVar
(Ast_c.info_of_type returnType
) in
540 (* old: Lib_parsing_c.al_type returnType
541 * but this type has not the typename completed so
542 * instead try to use tybis
545 | Some ty_with_typename_completed
->
546 ty_with_typename_completed
547 | None
-> raise Impossible
551 ref (Some
(typexp,local),
555 Ast_c.mk_e_bis
(B.Ident
(ident)) typ Ast_c.noii
559 (B.Assignment
(idexpr,B.SimpleAssign
, e
)) [iini
] in
567 pr2_once
"TODO: initialisation_to_affectation for multi vars";
568 (* todo? do a fold_left and generate 'x = a, y = b' etc, use
569 * the Sequence expression operator of C and make an
570 * ExprStatement from that.
579 (*****************************************************************************)
580 (* Functor parameter combinators *)
581 (*****************************************************************************)
583 * src: papers on parser combinators in haskell (cf a pearl by meijer in ICFP)
585 * version0: was not tagging the SP, so just tag the C
587 * (tin -> 'c tout) -> ('c -> (tin -> 'b tout)) -> (tin -> 'b tout)
588 * val return : 'b -> tin -> 'b tout
589 * val fail : tin -> 'b tout
591 * version1: now also tag the SP so return a ('a * 'b)
594 type mode
= PatternMode
| TransformMode
602 type ('a
, 'b
) matcher
= 'a
-> 'b
-> tin
-> ('a
* 'b
) tout
607 (tin
-> ('a
* 'b
) tout
) ->
608 ('a
-> 'b
-> (tin
-> ('c
* 'd
) tout
)) ->
609 (tin
-> ('c
* 'd
) tout
)
611 val return
: ('a
* 'b
) -> tin
-> ('a
*'b
) tout
612 val fail
: tin
-> ('a
* 'b
) tout
624 val (>&&>) : (tin
-> bool) -> (tin
-> 'x tout
) -> (tin
-> 'x tout
)
626 val tokenf
: ('a
A.mcode
, B.info
) matcher
627 val tokenf_mck
: (A.mcodekind, B.info
) matcher
630 (A.meta_name
A.mcode
, B.expression
) matcher
632 (A.meta_name
A.mcode
, (Ast_c.argument
, Ast_c.il
) either list
) matcher
634 (A.meta_name
A.mcode
, Ast_c.fullType
) matcher
636 (A.meta_name
A.mcode
,
637 (Ast_c.parameterType
, Ast_c.il
) either list
) matcher
639 (A.meta_name
A.mcode
, Ast_c.parameterType
) matcher
641 (A.meta_name
A.mcode
, Ast_c.initialiser
) matcher
643 (A.meta_name
A.mcode
, (Ast_c.initialiser
, Ast_c.il
) either list
) matcher
645 (A.meta_name
A.mcode
, Ast_c.declaration
) matcher
647 (A.meta_name
A.mcode
, Ast_c.field
) matcher
649 (A.meta_name
A.mcode
, Control_flow_c.node
) matcher
651 val distrf_define_params
:
652 (A.meta_name
A.mcode
, (string Ast_c.wrap
, Ast_c.il
) either list
) matcher
654 val distrf_enum_fields
:
655 (A.meta_name
A.mcode
, (B.oneEnumType
, B.il
) either list
) matcher
657 val distrf_struct_fields
:
658 (A.meta_name
A.mcode
, B.field list
) matcher
661 (A.meta_name
A.mcode
, (B.constant
, string) either
B.wrap
) matcher
664 (A.expression
, B.expression
) matcher
-> (A.expression
, F.node
) matcher
667 (A.expression
, B.expression
) matcher
->
668 (A.expression
, B.expression
) matcher
671 (A.fullType
, B.fullType
) matcher
-> (A.fullType
, F.node
) matcher
674 (A.initialiser
, B.initialiser
) matcher
-> (A.initialiser
, F.node
) matcher
677 A.keep_binding
-> A.inherited
->
678 A.meta_name
A.mcode
* Ast_c.metavar_binding_kind
*
679 (unit -> Common.filename
* string * Ast_c.posl
* Ast_c.posl
) ->
680 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
682 val check_idconstraint
:
683 ('a
-> 'b
-> bool) -> 'a
-> 'b
->
684 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
686 val check_constraints_ne
:
687 ('a
, 'b
) matcher
-> 'a list
-> 'b
->
688 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
690 val all_bound
: A.meta_name list
-> (tin
-> bool)
692 val optional_storage_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
693 val optional_qualifier_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
694 val value_format_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
699 (*****************************************************************************)
700 (* Functor code, "Cocci vs C" *)
701 (*****************************************************************************)
704 functor (X
: PARAM
) ->
707 type ('a
, 'b
) matcher
= 'a
-> 'b
-> X.tin
-> ('a
* 'b
) X.tout
710 let return = X.return
713 let (>||>) = X.(>||>)
714 let (>|+|>) = X.(>|+|>)
715 let (>&&>) = X.(>&&>)
717 let tokenf = X.tokenf
719 (* should be raise Impossible when called from transformation.ml *)
722 | PatternMode
-> fail
723 | TransformMode
-> raise Impossible
726 let (option: ('a
,'b
) matcher
-> ('a
option,'b
option) matcher
)= fun f t1 t2
->
728 | (Some t1
, Some t2
) ->
729 f t1 t2
>>= (fun t1 t2
->
730 return (Some t1
, Some t2
)
732 | (None
, None
) -> return (None
, None
)
735 (* Dots are sometimes used as metavariables, since like metavariables they
736 can match other things. But they no longer have the same type. Perhaps these
737 functions could be avoided by introducing an appropriate level of polymorphism,
738 but I don't know how to declare polymorphism across functors *)
739 let dots2metavar (_
,info
,mcodekind,pos
) =
740 (("","..."),info
,mcodekind,pos
)
741 let metavar2dots (_
,info
,mcodekind,pos
) = ("...",info
,mcodekind,pos
)
743 let satisfies_regexpconstraint c id
: bool =
745 A.IdRegExp
(_
,recompiled
) -> Str.string_match recompiled id
0
746 | A.IdNotRegExp
(_
,recompiled
) -> not
(Str.string_match recompiled id
0)
748 let satisfies_iconstraint c id
: bool =
751 let satisfies_econstraint c exp
: bool =
752 let warning s
= pr2_once
("WARNING: "^s
); false in
753 match Ast_c.unwrap_expr exp
with
754 Ast_c.Ident
(name
) ->
756 Ast_c.RegularName rname
->
757 satisfies_regexpconstraint c
(Ast_c.unwrap_st rname
)
758 | Ast_c.CppConcatenatedName _
->
760 "Unable to apply a constraint on a CppConcatenatedName identifier!"
761 | Ast_c.CppVariadicName _
->
763 "Unable to apply a constraint on a CppVariadicName identifier!"
764 | Ast_c.CppIdentBuilder _
->
766 "Unable to apply a constraint on a CppIdentBuilder identifier!")
767 | Ast_c.Constant cst
->
769 | Ast_c.String
(str
, _
) -> satisfies_regexpconstraint c str
770 | Ast_c.MultiString strlist
->
771 warning "Unable to apply a constraint on an multistring constant!"
772 | Ast_c.Char
(char
, _
) -> satisfies_regexpconstraint c char
773 | Ast_c.Int
(int , _
) -> satisfies_regexpconstraint c
int
774 | Ast_c.Float
(float, _
) -> satisfies_regexpconstraint c
float)
775 | _
-> warning "Unable to apply a constraint on an expression!"
778 (* ------------------------------------------------------------------------- *)
779 (* This has to be up here to allow adequate polymorphism *)
781 let list_matcher match_dots rebuild_dots match_comma rebuild_comma
782 match_metalist rebuild_metalist mktermval special_cases
783 element distrf get_iis
= fun eas ebs
->
784 let rec loop = function
785 [], [] -> return ([], [])
786 | [], eb
::ebs
-> fail
788 X.all_bound
(A.get_inherited ea
) >&&>
790 (match match_dots ea
, ebs
with
791 Some
(mcode
, optexpr
), ys
->
792 (* todo: if optexpr, then a WHEN and so may have to filter yys *)
793 if optexpr
<> None
then failwith
"not handling when in a list";
795 (* '...' can take more or less the beginnings of the arguments *)
797 Common.zip
(Common.inits ys
) (Common.tails ys
) in
799 (startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
802 (* allow '...', and maybe its associated ',' to match nothing.
803 * for the associated ',' see below how we handle the EComma
808 if mcode_contain_plus (mcodekind mcode
)
811 "I have no token that I could accroche myself on"*)
812 else return (dots2metavar mcode
, [])
814 (* subtil: we dont want the '...' to match until the
815 * comma. cf -test pb_params_iso. We would get at
816 * "already tagged" error.
817 * this is because both f (... x, ...) and f (..., x, ...)
818 * would match a f(x,3) with our "optional-comma" strategy.
820 (match Common.last startxs
with
822 | Left _
-> distrf
(dots2metavar mcode
) startxs
))
824 >>= (fun mcode startxs
->
825 let mcode = metavar2dots mcode in
826 loop (eas
, endxs
) >>= (fun eas endxs
->
828 (rebuild_dots
(mcode, optexpr
) +> A.rewrap ea
) ::eas
,
836 (match match_comma ea
, ebs
with
837 | Some ia1
, Right ii
::ebs
->
839 (let ib1 = tuple_of_list1 ii
in
840 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
841 loop (eas
, ebs
) >>= (fun eas ebs
->
843 (rebuild_comma ia1
+> A.rewrap ea
)::eas
,
848 (* allow ',' to maching nothing. optional comma trick *)
850 (if mcode_contain_plus (mcodekind ia1
)
852 else loop (eas
, ebs
))
855 (match match_metalist ea
, ebs
with
856 Some
(ida
,leninfo
,keep
,inherited
), ys
->
858 Common.zip
(Common.inits ys
) (Common.tails ys
) in
860 (startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
865 if mcode_contain_plus (mcodekind ida
)
867 (* failwith "no token that I could accroche myself on" *)
870 (match Common.last startxs
with
877 let startxs'
= Ast_c.unsplit_comma
startxs in
878 let len = List.length
startxs'
in
881 | A.MetaListLen
(lenname
,lenkeep
,leninherited
) ->
882 let max_min _
= failwith
"no pos" in
883 X.envf lenkeep leninherited
884 (lenname
, Ast_c.MetaListlenVal
(len), max_min)
887 then (function f
-> f
())
888 else (function f
-> fail)
889 | A.AnyListLen
-> function f
-> f
()
893 Lib_parsing_c.lin_col_by_pos
(get_iis
startxs) in
894 X.envf keep inherited
895 (ida
, mktermval
startxs'
, max_min)
898 then return (ida
, [])
899 else distrf ida
(Ast_c.split_comma
startxs'
))
900 >>= (fun ida
startxs ->
901 loop (eas
, endxs
) >>= (fun eas endxs
->
903 (rebuild_metalist
(ida
,leninfo
,keep
,inherited
))
912 special_cases ea eas ebs
in
913 match try_matches with
918 element ea eb
>>= (fun ea eb
->
919 loop (eas
, ebs
) >>= (fun eas ebs
->
920 return (ea
::eas
, Left eb
::ebs
)))
921 | (Right y
)::ys
-> raise Impossible
925 (*---------------------------------------------------------------------------*)
937 (*---------------------------------------------------------------------------*)
938 let rec (expression
: (A.expression
, Ast_c.expression
) matcher
) =
940 if A.get_test_exp ea
&& not
(Ast_c.is_test eb
) then fail
942 X.all_bound
(A.get_inherited ea
) >&&>
943 let wa x
= A.rewrap ea x
in
944 match A.unwrap ea
, eb
with
946 (* general case: a MetaExpr can match everything *)
947 | A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
),
948 (((expr
, opttypb
), ii
) as expb
) ->
950 (* old: before have a MetaConst. Now we factorize and use 'form' to
951 * differentiate between different cases *)
952 let rec matches_id = function
953 B.Ident
(name
) -> true
954 | B.Cast
(ty
,e
) -> matches_id (B.unwrap_expr e
)
957 match (form
,expr
) with
960 let rec matches = function
961 B.Constant
(c
) -> true
962 | B.Ident
(nameidb
) ->
963 let s = Ast_c.str_of_name nameidb
in
964 if s =~
"^[A-Z_][A-Z_0-9]*$"
966 pr2_once
("warning: " ^
s ^
" treated as a constant");
970 | B.Cast
(ty
,e
) -> matches (B.unwrap_expr e
)
971 | B.Unary
(e
,B.UnMinus
) -> matches (B.unwrap_expr e
)
972 | B.SizeOfExpr
(exp
) -> true
973 | B.SizeOfType
(ty
) -> true
979 (Some
(_
,Ast_c.LocalVar _
),_
) -> true
981 | (A.ID
,e
) -> matches_id e
in
985 (let (opttypb
,_testb
) = !opttypb
in
986 match opttypa
, opttypb
with
987 | None
, _
-> return ((),())
989 pr2_once
("Missing type information. Certainly a pb in " ^
990 "annotate_typer.ml");
993 | Some tas
, Some tb
->
994 tas
+> List.fold_left
(fun acc ta
->
995 acc
>|+|> compatible_type ta tb
) fail
998 let meta_expr_val l x
= Ast_c.MetaExprVal
(x
,l
) in
999 match constraints
with
1000 Ast_cocci.NoConstraint
-> return (meta_expr_val [],())
1001 | Ast_cocci.NotIdCstrt cstrt
->
1002 X.check_idconstraint
satisfies_econstraint cstrt eb
1003 (fun () -> return (meta_expr_val [],()))
1004 | Ast_cocci.NotExpCstrt cstrts
->
1005 X.check_constraints_ne expression cstrts eb
1006 (fun () -> return (meta_expr_val [],()))
1007 | Ast_cocci.SubExpCstrt cstrts
->
1008 return (meta_expr_val cstrts
,()))
1012 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_expr expb
) in
1013 X.envf keep inherited
(ida
, wrapper expb
, max_min)
1015 X.distrf_e ida expb
>>=
1018 A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
)+>
1026 * | A.MetaExpr(ida,false,opttypa,_inherited), expb ->
1027 * D.distribute_mck (mcodekind ida) D.distribute_mck_e expb binding
1029 * but bug! because if have not tagged SP, then transform without doing
1030 * any checks. Hopefully now have tagged SP technique.
1035 * | A.Edots _, _ -> raise Impossible.
1037 * In fact now can also have the Edots inside normal expression, not
1038 * just in arg lists. in 'x[...];' less: in if(<... x ... y ...>)
1040 | A.Edots
(mcode, None
), expb
->
1041 X.distrf_e
(dots2metavar mcode) expb
>>= (fun mcode expb
->
1043 A.Edots
(metavar2dots mcode, None
) +> A.rewrap ea
,
1048 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
1051 | A.Ident ida
, ((B.Ident
(nameidb
), typ),noii
) ->
1053 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1055 ((A.Ident ida
)) +> wa,
1056 ((B.Ident
(nameidb
), typ),Ast_c.noii
)
1062 | A.MetaErr _
, _
-> failwith
"not handling MetaErr"
1064 (* todo?: handle some isomorphisms in int/float ? can have different
1065 * format : 1l can match a 1.
1067 * todo: normally string can contain some metavar too, so should
1068 * recurse on the string
1070 | A.Constant
(ia1
), ((B.Constant
(ib
) , typ),ii
) ->
1071 (* for everything except the String case where can have multi elems *)
1073 let ib1 = tuple_of_list1 ii
in
1074 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1076 ((A.Constant ia1
)) +> wa,
1077 ((B.Constant
(ib
), typ),[ib1])
1080 (match term ia1
, ib
with
1081 | A.Int x
, B.Int
(y
,_
) ->
1082 X.value_format_flag
(fun use_value_equivalence
->
1083 if use_value_equivalence
1093 | A.Char x
, B.Char
(y
,_
) when x
=$
= y
(* todo: use kind ? *)
1095 | A.Float x
, B.Float
(y
,_
) when x
=$
= y
(* todo: use floatType ? *)
1098 | A.String sa
, B.String
(sb
,_kind
) when sa
=$
= sb
->
1101 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1103 ((A.Constant ia1
)) +> wa,
1104 ((B.Constant
(ib
), typ),[ib1])
1106 | _
-> fail (* multi string, not handled *)
1109 | _
, B.MultiString _
-> (* todo cocci? *) fail
1110 | _
, (B.String _
| B.Float _
| B.Char _
| B.Int _
) -> fail
1114 | A.FunCall
(ea
, ia1
, eas
, ia2
), ((B.FunCall
(eb
, ebs
), typ),ii
) ->
1115 (* todo: do special case to allow IdMetaFunc, cos doing the
1116 * recursive call will be too late, match_ident will not have the
1117 * info whether it was a function. todo: but how detect when do
1118 * x.field = f; how know that f is a Func ? By having computed
1119 * some information before the matching!
1121 * Allow match with FunCall containing types. Now ast_cocci allow
1122 * type in parameter, and morover ast_cocci allow f(...) and those
1123 * ... could match type.
1125 let (ib1, ib2
) = tuple_of_list2 ii
in
1126 expression ea eb
>>= (fun ea eb
->
1127 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1128 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1129 arguments
(seqstyle eas
) (A.undots eas
) ebs
>>= (fun easundots ebs
->
1130 let eas = redots
eas easundots
in
1132 ((A.FunCall
(ea
, ia1
, eas, ia2
)) +> wa,
1133 ((B.FunCall
(eb
, ebs
),typ), [ib1;ib2
])
1139 | A.Assignment
(ea1
, opa
, ea2
, simple
),
1140 ((B.Assignment
(eb1
, opb
, eb2
), typ),ii
) ->
1141 let (opbi
) = tuple_of_list1 ii
in
1142 if equal_assignOp (term opa
) opb
1144 expression ea1 eb1
>>= (fun ea1 eb1
->
1145 expression ea2 eb2
>>= (fun ea2 eb2
->
1146 tokenf opa opbi
>>= (fun opa opbi
->
1148 (A.Assignment
(ea1
, opa
, ea2
, simple
)) +> wa,
1149 ((B.Assignment
(eb1
, opb
, eb2
), typ), [opbi
])
1153 | A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
),((B.CondExpr
(eb1
,eb2opt
,eb3
),typ),ii
) ->
1154 let (ib1, ib2
) = tuple_of_list2 ii
in
1155 expression ea1 eb1
>>= (fun ea1 eb1
->
1156 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
1157 expression ea3 eb3
>>= (fun ea3 eb3
->
1158 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1159 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1161 ((A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
))) +> wa,
1162 ((B.CondExpr
(eb1
, eb2opt
, eb3
),typ), [ib1;ib2
])
1165 (* todo?: handle some isomorphisms here ? *)
1166 | A.Postfix
(ea
, opa
), ((B.Postfix
(eb
, opb
), typ),ii
) ->
1167 let opbi = tuple_of_list1 ii
in
1168 if equal_fixOp (term opa
) opb
1170 expression ea eb
>>= (fun ea eb
->
1171 tokenf opa
opbi >>= (fun opa
opbi ->
1173 ((A.Postfix
(ea
, opa
))) +> wa,
1174 ((B.Postfix
(eb
, opb
), typ),[opbi])
1179 | A.Infix
(ea
, opa
), ((B.Infix
(eb
, opb
), typ),ii
) ->
1180 let opbi = tuple_of_list1 ii
in
1181 if equal_fixOp (term opa
) opb
1183 expression ea eb
>>= (fun ea eb
->
1184 tokenf opa
opbi >>= (fun opa
opbi ->
1186 ((A.Infix
(ea
, opa
))) +> wa,
1187 ((B.Infix
(eb
, opb
), typ),[opbi])
1191 | A.Unary
(ea
, opa
), ((B.Unary
(eb
, opb
), typ),ii
) ->
1192 let opbi = tuple_of_list1 ii
in
1193 if equal_unaryOp (term opa
) opb
1195 expression ea eb
>>= (fun ea eb
->
1196 tokenf opa
opbi >>= (fun opa
opbi ->
1198 ((A.Unary
(ea
, opa
))) +> wa,
1199 ((B.Unary
(eb
, opb
), typ),[opbi])
1203 | A.Binary
(ea1
, opa
, ea2
), ((B.Binary
(eb1
, opb
, eb2
), typ),ii
) ->
1204 let opbi = tuple_of_list1 ii
in
1205 if equal_binaryOp (term opa
) opb
1207 expression ea1 eb1
>>= (fun ea1 eb1
->
1208 expression ea2 eb2
>>= (fun ea2 eb2
->
1209 tokenf opa
opbi >>= (fun opa
opbi ->
1211 ((A.Binary
(ea1
, opa
, ea2
))) +> wa,
1212 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1216 | A.Nested
(ea1
, opa
, ea2
), eb
->
1218 expression ea1 eb
>|+|>
1220 ((B.Binary
(eb1
, opb
, eb2
), typ),ii
)
1221 when equal_binaryOp (term opa
) opb
->
1222 let opbi = tuple_of_list1 ii
in
1224 (expression ea1 eb1
>>= (fun ea1 eb1
->
1225 expression ea2 eb2
>>= (fun ea2 eb2
->
1226 tokenf opa
opbi >>= (fun opa
opbi ->
1228 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1229 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1232 (expression ea2 eb1
>>= (fun ea2 eb1
->
1233 expression ea1 eb2
>>= (fun ea1 eb2
->
1234 tokenf opa
opbi >>= (fun opa
opbi ->
1236 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1237 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1240 (loop eb1
>>= (fun ea1 eb1
->
1241 expression ea2 eb2
>>= (fun ea2 eb2
->
1242 tokenf opa
opbi >>= (fun opa
opbi ->
1244 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1245 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1248 (expression ea2 eb1
>>= (fun ea2 eb1
->
1249 loop eb2
>>= (fun ea1 eb2
->
1250 tokenf opa
opbi >>= (fun opa
opbi ->
1252 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1253 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1255 left_to_right >|+|> right_to_left >|+|> in_left >|+|> in_right
1259 (* todo?: handle some isomorphisms here ? (with pointers = Unary Deref) *)
1260 | A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
),((B.ArrayAccess
(eb1
, eb2
), typ),ii
) ->
1261 let (ib1, ib2
) = tuple_of_list2 ii
in
1262 expression ea1 eb1
>>= (fun ea1 eb1
->
1263 expression ea2 eb2
>>= (fun ea2 eb2
->
1264 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1265 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1267 ((A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
))) +> wa,
1268 ((B.ArrayAccess
(eb1
, eb2
),typ), [ib1;ib2
])
1271 (* todo?: handle some isomorphisms here ? *)
1272 | A.RecordAccess
(ea
, ia1
, ida
), ((B.RecordAccess
(eb
, idb
), typ),ii
) ->
1273 let (ib1) = tuple_of_list1 ii
in
1274 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
1275 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1276 expression ea eb
>>= (fun ea eb
->
1278 ((A.RecordAccess
(ea
, ia1
, ida
))) +> wa,
1279 ((B.RecordAccess
(eb
, idb
), typ), [ib1])
1284 | A.RecordPtAccess
(ea
,ia1
,ida
),((B.RecordPtAccess
(eb
, idb
), typ), ii
) ->
1285 let (ib1) = tuple_of_list1 ii
in
1286 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
1287 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1288 expression ea eb
>>= (fun ea eb
->
1290 ((A.RecordPtAccess
(ea
, ia1
, ida
))) +> wa,
1291 ((B.RecordPtAccess
(eb
, idb
), typ), [ib1])
1295 (* todo?: handle some isomorphisms here ?
1296 * todo?: do some iso-by-absence on cast ?
1297 * by trying | ea, B.Case (typb, eb) -> match_e_e ea eb ?
1300 | A.Cast
(ia1
, typa
, ia2
, ea
), ((B.Cast
(typb
, eb
), typ),ii
) ->
1301 let (ib1, ib2
) = tuple_of_list2 ii
in
1302 fullType typa typb
>>= (fun typa typb
->
1303 expression ea eb
>>= (fun ea eb
->
1304 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1305 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1307 ((A.Cast
(ia1
, typa
, ia2
, ea
))) +> wa,
1308 ((B.Cast
(typb
, eb
),typ),[ib1;ib2
])
1311 | A.SizeOfExpr
(ia1
, ea
), ((B.SizeOfExpr
(eb
), typ),ii
) ->
1312 let ib1 = tuple_of_list1 ii
in
1313 expression ea eb
>>= (fun ea eb
->
1314 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1316 ((A.SizeOfExpr
(ia1
, ea
))) +> wa,
1317 ((B.SizeOfExpr
(eb
), typ),[ib1])
1320 | A.SizeOfType
(ia1
, ia2
, typa
, ia3
), ((B.SizeOfType typb
, typ),ii
) ->
1321 let (ib1,ib2
,ib3
) = tuple_of_list3 ii
in
1322 fullType typa typb
>>= (fun typa typb
->
1323 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1324 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1325 tokenf ia3 ib3
>>= (fun ia3 ib3
->
1327 ((A.SizeOfType
(ia1
, ia2
, typa
, ia3
))) +> wa,
1328 ((B.SizeOfType
(typb
),typ),[ib1;ib2
;ib3
])
1332 (* todo? iso ? allow all the combinations ? *)
1333 | A.Paren
(ia1
, ea
, ia2
), ((B.ParenExpr
(eb
), typ),ii
) ->
1334 let (ib1, ib2
) = tuple_of_list2 ii
in
1335 expression ea eb
>>= (fun ea eb
->
1336 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1337 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1339 ((A.Paren
(ia1
, ea
, ia2
))) +> wa,
1340 ((B.ParenExpr
(eb
), typ), [ib1;ib2
])
1343 | A.NestExpr
(starter
,exps
,ender
,None
,true), eb
->
1344 (match A.get_mcodekind starter
with
1345 A.MINUS _
-> failwith
"TODO: only context nests supported"
1347 (match A.unwrap exps
with
1349 X.cocciExpExp expression exp eb
>>= (fun exp eb
->
1352 (starter
,A.rewrap exps
(A.DOTS
[exp
]),ender
,None
,true)) +> wa,
1358 "for nestexpr, only handling the case with dots and only one exp")
1360 | A.NestExpr _
, _
->
1361 failwith
"only handling multi and no when code in a nest expr"
1363 (* only in arg lists or in define body *)
1364 | A.TypeExp _
, _
-> fail
1366 (* only in arg lists *)
1367 | A.MetaExprList _
, _
1374 | A.DisjExpr
eas, eb
->
1375 eas +> List.fold_left
(fun acc ea
-> acc
>|+|> (expression ea eb
)) fail
1377 | A.UniqueExp _
,_
| A.OptExp _
,_
->
1378 failwith
"not handling Opt/Unique/Multi on expr"
1380 (* Because of Exp cant put a raise Impossible; have to put a fail *)
1382 (* have not a counter part in coccinelle, for the moment *)
1383 | _
, ((B.Sequence _
,_
),_
)
1384 | _
, ((B.StatementExpr _
,_
),_
)
1385 | _
, ((B.Constructor _
,_
),_
)
1390 (((B.Cast
(_
, _
)|B.ParenExpr _
|B.SizeOfType _
|B.SizeOfExpr _
|
1391 B.RecordPtAccess
(_
, _
)|
1392 B.RecordAccess
(_
, _
)|B.ArrayAccess
(_
, _
)|
1393 B.Binary
(_
, _
, _
)|B.Unary
(_
, _
)|
1394 B.Infix
(_
, _
)|B.Postfix
(_
, _
)|
1395 B.Assignment
(_
, _
, _
)|B.CondExpr
(_
, _
, _
)|
1396 B.FunCall
(_
, _
)|B.Constant _
|B.Ident _
),
1404 (* ------------------------------------------------------------------------- *)
1405 and (ident_cpp
: info_ident
-> (A.ident, B.name
) matcher
) =
1406 fun infoidb ida idb
->
1408 | B.RegularName
(s, iis) ->
1409 let iis = tuple_of_list1
iis in
1410 ident infoidb ida
(s, iis) >>= (fun ida
(s,iis) ->
1413 (B.RegularName
(s, [iis]))
1415 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
1417 (* This should be moved to the Id case of ident. Metavariables
1418 should be allowed to be bound to such variables. But doing so
1419 would require implementing an appropriate distr function *)
1422 and (ident: info_ident
-> (A.ident, string * Ast_c.info
) matcher
) =
1423 fun infoidb ida
((idb
, iib
)) -> (* (idb, iib) as ib *)
1424 let check_constraints constraints idb
=
1425 let meta_id_val l x
= Ast_c.MetaIdVal
(x
,l
) in
1426 match constraints
with
1427 A.IdNoConstraint
-> return (meta_id_val [],())
1428 | A.IdNegIdSet
(str
,meta
) ->
1429 X.check_idconstraint
satisfies_iconstraint str idb
1430 (fun () -> return (meta_id_val meta
,()))
1431 | A.IdRegExpConstraint re
->
1432 X.check_idconstraint
satisfies_regexpconstraint re idb
1433 (fun () -> return (meta_id_val [],())) in
1434 X.all_bound
(A.get_inherited ida
) >&&>
1435 match A.unwrap ida
with
1437 if (term sa
) =$
= idb
then
1438 tokenf sa iib
>>= (fun sa iib
->
1440 ((A.Id sa
)) +> A.rewrap ida
,
1445 | A.MetaId
(mida
,constraints
,keep
,inherited
) ->
1446 check_constraints constraints idb
>>=
1448 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1449 (* use drop_pos for ids so that the pos is not added a second time in
1450 the call to tokenf *)
1451 X.envf keep inherited
(A.drop_pos mida
, wrapper idb
, max_min)
1453 tokenf mida iib
>>= (fun mida iib
->
1455 ((A.MetaId
(mida
, constraints
, keep
, inherited
)) +> A.rewrap ida
,
1460 | A.MetaFunc
(mida
,constraints
,keep
,inherited
) ->
1462 check_constraints constraints idb
>>=
1464 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1465 X.envf keep inherited
(A.drop_pos mida
,Ast_c.MetaFuncVal idb
,max_min)
1467 tokenf mida iib
>>= (fun mida iib
->
1469 ((A.MetaFunc
(mida
,constraints
,keep
,inherited
)))+>A.rewrap ida
,
1474 | LocalFunction
| Function
-> is_function()
1476 failwith
"MetaFunc, need more semantic info about id"
1477 (* the following implementation could possibly be useful, if one
1478 follows the convention that a macro is always in capital letters
1479 and that a macro is not a function.
1480 (if idb =~ "^[A-Z_][A-Z_0-9]*$" then fail else is_function())*)
1483 | A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
) ->
1486 check_constraints constraints idb
>>=
1488 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1489 X.envf keep inherited
1490 (A.drop_pos mida
,Ast_c.MetaLocalFuncVal idb
, max_min)
1492 tokenf mida iib
>>= (fun mida iib
->
1494 ((A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
)))
1500 | DontKnow
-> failwith
"MetaLocalFunc, need more semantic info about id"
1503 | A.OptIdent _
| A.UniqueIdent _
->
1504 failwith
"not handling Opt/Unique for ident"
1506 (* ------------------------------------------------------------------------- *)
1507 and (arguments
: sequence
->
1508 (A.expression list
, Ast_c.argument
Ast_c.wrap2 list
) matcher
) =
1509 fun seqstyle eas ebs
->
1511 | Unordered
-> failwith
"not handling ooo"
1513 arguments_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1514 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1516 (* because '...' can match nothing, need to take care when have
1517 * ', ...' or '...,' as in f(..., X, Y, ...). It must match
1518 * f(1,2) for instance.
1519 * So I have added special cases such as (if startxs = []) and code
1520 * in the Ecomma matching rule.
1522 * old: Must do some try, for instance when f(...,X,Y,...) have to
1523 * test the transfo for all the combinaitions and if multiple transfo
1524 * possible ? pb ? => the type is to return a expression option ? use
1525 * some combinators to help ?
1526 * update: with the tag-SP approach, no more a problem.
1529 and arguments_bis
= fun eas ebs
->
1531 match A.unwrap ea
with
1532 A.Edots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
1534 let build_dots (mcode, optexpr
) = A.Edots
(mcode, optexpr
) in
1535 let match_comma ea
=
1536 match A.unwrap ea
with
1537 A.EComma ia1
-> Some ia1
1539 let build_comma ia1
= A.EComma ia1
in
1540 let match_metalist ea
=
1541 match A.unwrap ea
with
1542 A.MetaExprList
(ida
,leninfo
,keep
,inherited
) ->
1543 Some
(ida
,leninfo
,keep
,inherited
)
1545 let build_metalist (ida
,leninfo
,keep
,inherited
) =
1546 A.MetaExprList
(ida
,leninfo
,keep
,inherited
) in
1547 let mktermval v
= Ast_c.MetaExprListVal v
in
1548 let special_cases ea
eas ebs
= None
in
1549 list_matcher match_dots build_dots match_comma build_comma
1550 match_metalist build_metalist mktermval
1551 special_cases argument
X.distrf_args
1552 Lib_parsing_c.ii_of_args
eas ebs
1554 and argument arga argb
=
1555 X.all_bound
(A.get_inherited arga
) >&&>
1556 match A.unwrap arga
, argb
with
1558 Right
(B.ArgType
{B.p_register
=b
,iib
; p_namei
=sopt
;p_type
=tyb
}) ->
1559 if b
|| sopt
<> None
1561 (* failwith "the argument have a storage and ast_cocci does not have"*)
1564 (* b = false and sopt = None *)
1565 fullType tya tyb
>>= (fun tya tyb
->
1567 (A.TypeExp tya
) +> A.rewrap arga
,
1568 (Right
(B.ArgType
{B.p_register
=(b
,iib
);
1573 | A.TypeExp tya
, _
-> fail
1574 | _
, Right
(B.ArgType _
) -> fail
1576 expression arga argb
>>= (fun arga argb
->
1577 return (arga
, Left argb
)
1579 | _
, Right
(B.ArgAction y
) -> fail
1582 (* ------------------------------------------------------------------------- *)
1583 (* todo? facto code with argument ? *)
1584 and (parameters
: sequence
->
1585 (A.parameterTypeDef list
, Ast_c.parameterType
Ast_c.wrap2 list
)
1587 fun seqstyle eas ebs
->
1589 | Unordered
-> failwith
"not handling ooo"
1591 parameters_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1592 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1596 and parameters_bis
eas ebs
=
1598 match A.unwrap ea
with
1599 A.Pdots
(mcode) -> Some
(mcode, None
)
1601 let build_dots (mcode, _optexpr
) = A.Pdots
(mcode) in
1602 let match_comma ea
=
1603 match A.unwrap ea
with
1604 A.PComma ia1
-> Some ia1
1606 let build_comma ia1
= A.PComma ia1
in
1607 let match_metalist ea
=
1608 match A.unwrap ea
with
1609 A.MetaParamList
(ida
,leninfo
,keep
,inherited
) ->
1610 Some
(ida
,leninfo
,keep
,inherited
)
1612 let build_metalist (ida
,leninfo
,keep
,inherited
) =
1613 A.MetaParamList
(ida
,leninfo
,keep
,inherited
) in
1614 let mktermval v
= Ast_c.MetaParamListVal v
in
1615 let special_cases ea
eas ebs
=
1616 (* a case where one smpl parameter matches a list of C parameters *)
1617 match A.unwrap ea
,ebs
with
1618 A.VoidParam ta
, ys
->
1620 (match eas, ebs
with
1622 let {B.p_register
=(hasreg
,iihasreg
);
1624 p_type
=tb
; } = eb
in
1626 if idbopt
=*= None
&& not hasreg
1629 | (qub
, (B.BaseType
B.Void
,_
)) ->
1630 fullType ta tb
>>= (fun ta tb
->
1632 [(A.VoidParam ta
) +> A.rewrap ea
],
1633 [Left
{B.p_register
=(hasreg
, iihasreg
);
1641 list_matcher match_dots build_dots match_comma build_comma
1642 match_metalist build_metalist mktermval
1643 special_cases parameter
X.distrf_params
1644 Lib_parsing_c.ii_of_params
eas ebs
1647 let split_register_param = fun (hasreg, idb, ii_b_s) ->
1648 match hasreg, idb, ii_b_s with
1649 | false, Some s, [i1] -> Left (s, [], i1)
1650 | true, Some s, [i1;i2] -> Left (s, [i1], i2)
1651 | _, None, ii -> Right ii
1652 | _ -> raise Impossible
1656 and parameter
= fun parama paramb
->
1657 match A.unwrap parama
, paramb
with
1658 A.MetaParam
(ida
,keep
,inherited
), eb
->
1659 (* todo: use quaopt, hasreg ? *)
1661 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_param eb
) in
1662 X.envf keep inherited
(ida
,Ast_c.MetaParamVal eb
,max_min) (fun () ->
1663 X.distrf_param ida eb
1664 ) >>= (fun ida eb
->
1665 return (A.MetaParam
(ida
,keep
,inherited
)+> A.rewrap parama
,eb
))
1666 | A.Param
(typa
, idaopt
), eb
->
1667 let {B.p_register
= (hasreg
,iihasreg
);
1668 p_namei
= nameidbopt
;
1669 p_type
= typb
;} = paramb
in
1671 fullType typa typb
>>= (fun typa typb
->
1672 match idaopt
, nameidbopt
with
1673 | Some ida
, Some nameidb
->
1674 (* todo: if minus on ida, should also minus the iihasreg ? *)
1675 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1677 A.Param
(typa
, Some ida
)+> A.rewrap parama
,
1678 {B.p_register
= (hasreg
, iihasreg
);
1679 p_namei
= Some
(nameidb
);
1685 A.Param
(typa
, None
)+> A.rewrap parama
,
1686 {B.p_register
=(hasreg
,iihasreg
);
1690 (* why handle this case ? because of transform_proto ? we may not
1691 * have an ident in the proto.
1692 * If have some plus on ida ? do nothing about ida ?
1694 (* not anymore !!! now that julia is handling the proto.
1695 | _, Right iihasreg ->
1698 ((hasreg, None, typb), iihasreg)
1702 | Some _
, None
-> fail
1703 | None
, Some _
-> fail)
1704 | (A.OptParam _
| A.UniqueParam _
), _
->
1705 failwith
"not handling Opt/Unique for Param"
1706 | A.Pcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
1709 (* ------------------------------------------------------------------------- *)
1710 and (declaration
: (A.mcodekind * bool * A.declaration
,B.declaration
) matcher
) =
1711 fun (mckstart
, allminus
, decla
) declb
->
1712 X.all_bound
(A.get_inherited decla
) >&&>
1713 match A.unwrap decla
, declb
with
1715 (* Un MetaDecl est introduit dans l'asttoctl pour sauter au dessus
1716 * de toutes les declarations qui sont au debut d'un fonction et
1717 * commencer le reste du match au premier statement. Alors, ca matche
1718 * n'importe quelle declaration. On n'a pas besoin d'ajouter
1719 * quoi que ce soit dans l'environnement. C'est une sorte de DDots.
1721 * When the SP want to remove the whole function, the minus is not
1722 * on the MetaDecl but on the MetaRuleElem. So there should
1723 * be no transform of MetaDecl, just matching are allowed.
1726 | A.MetaDecl
(ida
,keep
,inherited
), _
->
1728 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_decl declb
) in
1729 X.envf keep inherited
(ida
, Ast_c.MetaDeclVal declb
, max_min) (fun () ->
1730 X.distrf_decl ida declb
1731 ) >>= (fun ida declb
->
1732 return ((mckstart
, allminus
,
1733 (A.MetaDecl
(ida
, keep
, inherited
))+> A.rewrap decla
),
1735 | _
, (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
)) ->
1736 onedecl allminus decla
(var
,iiptvirgb
,iisto
) >>=
1737 (fun decla
(var
,iiptvirgb
,iisto
)->
1738 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1740 (mckstart
, allminus
, decla
),
1741 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1744 | _
, (B.DeclList
(xs
, iiptvirgb
::iifakestart
::iisto
)) ->
1745 if X.mode
=*= PatternMode
1747 xs
+> List.fold_left
(fun acc var
->
1749 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1750 onedecl allminus decla
(var
, iiptvirgb
, iisto
) >>=
1751 (fun decla
(var
, iiptvirgb
, iisto
) ->
1753 (mckstart
, allminus
, decla
),
1754 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1758 failwith
"More that one variable in decl. Have to split to transform."
1760 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
), B.MacroDecl
((sb
,ebs
),ii
) ->
1761 let (iisb
, lpb
, rpb
, iiendb
, iifakestart
, iistob
) =
1763 | iisb
::lpb
::rpb
::iiendb
::iifakestart
::iisto
->
1764 (iisb
,lpb
,rpb
,iiendb
, iifakestart
,iisto
)
1765 | _
-> raise Impossible
1768 then minusize_list iistob
1769 else return ((), iistob
)
1770 ) >>= (fun () iistob
->
1772 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1773 ident DontKnow sa
(sb
, iisb
) >>= (fun sa
(sb
, iisb
) ->
1774 tokenf lpa lpb
>>= (fun lpa lpb
->
1775 tokenf rpa rpb
>>= (fun rpa rpb
->
1776 tokenf enda iiendb
>>= (fun enda iiendb
->
1777 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
1778 let eas = redots
eas easundots
in
1781 (mckstart
, allminus
,
1782 (A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
)) +> A.rewrap decla
),
1783 (B.MacroDecl
((sb
,ebs
),
1784 [iisb
;lpb
;rpb
;iiendb
;iifakestart
] ++ iistob
))
1787 | _
, (B.MacroDecl _
|B.DeclList _
) -> fail
1790 and onedecl
= fun allminus decla
(declb
, iiptvirgb
, iistob
) ->
1791 X.all_bound
(A.get_inherited decla
) >&&>
1792 match A.unwrap decla
, declb
with
1794 (* kind of typedef iso, we must unfold, it's for the case
1795 * T { }; that we want to match against typedef struct { } xx_t;
1798 | A.TyDecl
(tya0
, ptvirga
),
1799 ({B.v_namei
= Some
(nameidb
, None
);
1801 B.v_storage
= (B.StoTypedef
, inl
);
1804 B.v_type_bis
= typb0bis
;
1807 (match A.unwrap tya0
, typb0
with
1808 | A.Type
(cv1
,tya1
), ((qu
,il
),typb1
) ->
1810 (match A.unwrap tya1
, typb1
with
1811 | A.StructUnionDef
(tya2
, lba
, declsa
, rba
),
1812 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
1814 let (iisub
, iisbopt
, lbb
, rbb
) =
1817 let (iisub
, lbb
, rbb
) = tuple_of_list3 ii
in
1818 (iisub
, [], lbb
, rbb
)
1821 "warning: both a typedef (%s) and struct name introduction (%s)"
1822 (Ast_c.str_of_name nameidb
) s
1824 pr2 "warning: I will consider only the typedef";
1825 let (iisub
, iisb
, lbb
, rbb
) = tuple_of_list4 ii
in
1826 (iisub
, [iisb
], lbb
, rbb
)
1829 structdef_to_struct_name
1830 (Ast_c.nQ
, (B.StructUnion
(sub
, sbopt
, declsb
), ii
))
1833 Ast_c.nQ
,((B.TypeName
(nameidb
, Some
1834 (Lib_parsing_c.al_type
structnameb))), [])
1837 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1838 tokenf lba lbb
>>= (fun lba lbb
->
1839 tokenf rba rbb
>>= (fun rba rbb
->
1840 struct_fields
(A.undots declsa
) declsb
>>=(fun undeclsa declsb
->
1841 let declsa = redots
declsa undeclsa
in
1843 (match A.unwrap tya2
with
1844 | A.Type
(cv3
, tya3
) ->
1845 (match A.unwrap tya3
with
1846 | A.MetaType
(ida
,keep
, inherited
) ->
1848 fullType tya2
fake_typeb >>= (fun tya2
fake_typeb ->
1850 A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1 in
1851 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1854 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1855 [iisub
] @ iisbopt
@ [lbb
;rbb
] in
1856 let typb0 = ((qu
, il
), typb1) in
1858 match fake_typeb with
1859 | _nQ
, ((B.TypeName
(nameidb
, _typ
)),[]) ->
1862 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1863 (({B.v_namei
= Some
(nameidb
, None
);
1865 B.v_storage
= (B.StoTypedef
, inl
);
1868 B.v_type_bis
= typb0bis
;
1870 iivirg
),iiptvirgb
,iistob
)
1872 | _
-> raise Impossible
1875 (* do we need EnumName here too? *)
1876 | A.StructUnionName
(sua
, sa
) ->
1877 fullType tya2
structnameb >>= (fun tya2
structnameb ->
1879 let tya1 = A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1
1881 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1883 match structnameb with
1884 | _nQ
, (B.StructUnionName
(sub
, s), [iisub
;iisbopt
]) ->
1886 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1887 [iisub
;iisbopt
;lbb
;rbb
] in
1888 let typb0 = ((qu
, il
), typb1) in
1891 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1892 (({B.v_namei
= Some
(nameidb
, None
);
1894 B.v_storage
= (B.StoTypedef
, inl
);
1897 B.v_type_bis
= typb0bis
;
1899 iivirg
),iiptvirgb
,iistob
)
1901 | _
-> raise Impossible
1903 | _
-> raise Impossible
1912 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1913 ({B.v_namei
= Some
(nameidb
, _
);B.v_storage
= (B.StoTypedef
,_
);}, iivirg
)
1916 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1917 ({B.v_namei
=Some
(nameidb
, _
);B.v_storage
=(B.StoTypedef
,_
);}, iivirg
)
1922 (* could handle iso here but handled in standard.iso *)
1923 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1924 ({B.v_namei
= Some
(nameidb
, None
);
1929 B.v_type_bis
= typbbis
;
1932 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1933 fullType typa typb
>>= (fun typa typb
->
1934 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1935 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1936 (fun stoa
(stob
, iistob
) ->
1938 (A.UnInit
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
1939 (({B.v_namei
= Some
(nameidb
, None
);
1944 B.v_type_bis
= typbbis
;
1949 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1950 ({B.v_namei
= Some
(nameidb
, Some
(iieqb
, inib
));
1955 B.v_type_bis
= typbbis
;
1958 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1959 tokenf eqa iieqb
>>= (fun eqa iieqb
->
1960 fullType typa typb
>>= (fun typa typb
->
1961 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1962 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1963 (fun stoa
(stob
, iistob
) ->
1964 initialiser inia inib
>>= (fun inia inib
->
1966 (A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
)) +> A.rewrap decla
,
1967 (({B.v_namei
= Some
(nameidb
, Some
(iieqb
, inib
));
1972 B.v_type_bis
= typbbis
;
1977 (* do iso-by-absence here ? allow typedecl and var ? *)
1978 | A.TyDecl
(typa
, ptvirga
),
1979 ({B.v_namei
= None
; B.v_type
= typb
;
1983 B.v_type_bis
= typbbis
;
1986 if stob
=*= (B.NoSto
, false)
1988 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1989 fullType typa typb
>>= (fun typa typb
->
1991 (A.TyDecl
(typa
, ptvirga
)) +> A.rewrap decla
,
1992 (({B.v_namei
= None
;
1997 B.v_type_bis
= typbbis
;
1998 }, iivirg
), iiptvirgb
, iistob
)
2003 | A.Typedef
(stoa
, typa
, ida
, ptvirga
),
2004 ({B.v_namei
= Some
(nameidb
, None
);
2006 B.v_storage
= (B.StoTypedef
,inline
);
2009 B.v_type_bis
= typbbis
;
2012 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2013 fullType typa typb
>>= (fun typa typb
->
2016 tokenf stoa iitypedef
>>= (fun stoa iitypedef
->
2017 return (stoa
, [iitypedef
])
2019 | _
-> failwith
"weird, have both typedef and inline or nothing";
2020 ) >>= (fun stoa iistob
->
2021 (match A.unwrap ida
with
2022 | A.MetaType
(_
,_
,_
) ->
2025 Ast_c.nQ
, ((B.TypeName
(nameidb
, Ast_c.noTypedefDef
())), [])
2027 fullTypebis ida
fake_typeb >>= (fun ida
fake_typeb ->
2028 match fake_typeb with
2029 | _nQ
, ((B.TypeName
(nameidb
, _typ
)), []) ->
2030 return (ida
, nameidb
)
2031 | _
-> raise Impossible
2036 | B.RegularName
(sb
, iidb
) ->
2037 let iidb1 = tuple_of_list1 iidb
in
2041 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
2043 (A.TypeName sa
) +> A.rewrap ida
,
2044 B.RegularName
(sb
, [iidb1])
2048 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
2052 | _
-> raise Impossible
2054 ) >>= (fun ida nameidb
->
2056 (A.Typedef
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
2057 (({B.v_namei
= Some
(nameidb
, None
);
2059 B.v_storage
= (B.StoTypedef
,inline
);
2062 B.v_type_bis
= typbbis
;
2070 | _
, ({B.v_namei
= None
;}, _
) ->
2071 (* old: failwith "no variable in this declaration, weird" *)
2076 | A.DisjDecl declas
, declb
->
2077 declas
+> List.fold_left
(fun acc decla
->
2079 (* (declaration (mckstart, allminus, decla) declb) *)
2080 (onedecl allminus decla
(declb
,iiptvirgb
, iistob
))
2085 (* only in struct type decls *)
2086 | A.Ddots
(dots
,whencode
), _
->
2089 | A.OptDecl _
, _
| A.UniqueDecl _
, _
->
2090 failwith
"not handling Opt/Unique Decl"
2092 | _
, ({B.v_namei
=Some _
}, _
) ->
2098 (* ------------------------------------------------------------------------- *)
2100 and (initialiser
: (A.initialiser
, Ast_c.initialiser
) matcher
) = fun ia ib
->
2101 X.all_bound
(A.get_inherited ia
) >&&>
2102 match (A.unwrap ia
,ib
) with
2104 | (A.MetaInit
(ida
,keep
,inherited
), ib
) ->
2106 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_ini ib
) in
2107 X.envf keep inherited
(ida
, Ast_c.MetaInitVal ib
, max_min)
2109 X.distrf_ini ida ib
>>= (fun ida ib
->
2111 A.MetaInit
(ida
,keep
,inherited
) +> A.rewrap ia
,
2116 | (A.InitExpr expa
, ib
) ->
2117 (match A.unwrap expa
, ib
with
2118 | A.Edots
(mcode, None
), ib
->
2119 X.distrf_ini
(dots2metavar mcode) ib
>>= (fun mcode ib
->
2122 (A.Edots
(metavar2dots mcode, None
) +> A.rewrap expa
)
2127 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
2129 | _
, (B.InitExpr expb
, ii
) ->
2131 expression expa expb
>>= (fun expa expb
->
2133 (A.InitExpr expa
) +> A.rewrap ia
,
2134 (B.InitExpr expb
, ii
)
2139 | (A.ArInitList
(ia1
, ias
, ia2
), (B.InitList ibs
, ii
)) ->
2141 | ib1::ib2
::iicommaopt
->
2142 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2143 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2144 ar_initialisers
(A.undots ias
) (ibs
, iicommaopt
) >>=
2145 (fun iasundots
(ibs
,iicommaopt
) ->
2147 (A.ArInitList
(ia1
, redots ias iasundots
, ia2
)) +> A.rewrap ia
,
2148 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2151 | _
-> raise Impossible
2154 | (A.StrInitList
(allminus
, ia1
, ias
, ia2
, []), (B.InitList ibs
, ii
)) ->
2156 | ib1::ib2
::iicommaopt
->
2157 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2158 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2159 str_initialisers allminus ias
(ibs
, iicommaopt
) >>=
2160 (fun ias
(ibs
,iicommaopt
) ->
2162 (A.StrInitList
(allminus
, ia1
, ias
, ia2
, [])) +> A.rewrap ia
,
2163 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2166 | _
-> raise Impossible
2169 | (A.StrInitList
(allminus
, i1
, ias
, i2
, whencode
),
2170 (B.InitList ibs
, _ii
)) ->
2171 failwith
"TODO: not handling whencode in initialisers"
2174 | (A.InitGccExt
(designatorsa
, ia2
, inia
),
2175 (B.InitDesignators
(designatorsb
, inib
), ii2
))->
2177 let iieq = tuple_of_list1 ii2
in
2179 tokenf ia2
iieq >>= (fun ia2
iieq ->
2180 designators designatorsa designatorsb
>>=
2181 (fun designatorsa designatorsb
->
2182 initialiser inia inib
>>= (fun inia inib
->
2184 (A.InitGccExt
(designatorsa
, ia2
, inia
)) +> A.rewrap ia
,
2185 (B.InitDesignators
(designatorsb
, inib
), [iieq])
2191 | (A.InitGccName
(ida
, ia1
, inia
), (B.InitFieldOld
(idb
, inib
), ii
)) ->
2194 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2195 initialiser inia inib
>>= (fun inia inib
->
2196 tokenf ia1 iicolon
>>= (fun ia1 iicolon
->
2198 (A.InitGccName
(ida
, ia1
, inia
)) +> A.rewrap ia
,
2199 (B.InitFieldOld
(idb
, inib
), [iidb
;iicolon
])
2206 | A.IComma
(comma
), _
->
2209 | A.UniqueIni _
,_
| A.OptIni _
,_
->
2210 failwith
"not handling Opt/Unique on initialisers"
2212 | _
, (B.InitIndexOld
(_
, _
), _
) -> fail
2213 | _
, (B.InitFieldOld
(_
, _
), _
) -> fail
2215 | _
, ((B.InitDesignators
(_
, _
)|B.InitList _
|B.InitExpr _
), _
)
2218 and designators dla dlb
=
2219 match (dla
,dlb
) with
2220 ([],[]) -> return ([], [])
2221 | ([],_
) | (_
,[]) -> fail
2222 | (da
::dla
,db
::dlb
) ->
2223 designator da db
>>= (fun da db
->
2224 designators dla dlb
>>= (fun dla dlb
->
2225 return (da
::dla
, db
::dlb
)))
2227 and designator da db
=
2229 (A.DesignatorField
(ia1
, ida
), (B.DesignatorField idb
,ii1
)) ->
2231 let (iidot
, iidb
) = tuple_of_list2 ii1
in
2232 tokenf ia1 iidot
>>= (fun ia1 iidot
->
2233 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2235 A.DesignatorField
(ia1
, ida
),
2236 (B.DesignatorField idb
, [iidot
;iidb
])
2239 | (A.DesignatorIndex
(ia1
,ea
,ia2
), (B.DesignatorIndex eb
, ii1
)) ->
2241 let (ib1, ib2
) = tuple_of_list2 ii1
in
2242 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2243 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2244 expression ea eb
>>= (fun ea eb
->
2246 A.DesignatorIndex
(ia1
,ea
,ia2
),
2247 (B.DesignatorIndex eb
, [ib1;ib2
])
2250 | (A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2251 (B.DesignatorRange
(e1b
, e2b
), ii1
)) ->
2253 let (ib1, ib2
, ib3
) = tuple_of_list3 ii1
in
2254 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2255 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2256 tokenf ia3 ib3
>>= (fun ia3 ib3
->
2257 expression e1a e1b
>>= (fun e1a e1b
->
2258 expression e2a e2b
>>= (fun e2a e2b
->
2260 A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2261 (B.DesignatorRange
(e1b
, e2b
), [ib1;ib2
;ib3
])
2263 | (_
, ((B.DesignatorField _
|B.DesignatorIndex _
|B.DesignatorRange _
), _
)) ->
2266 and str_initialisers
= fun allminus ias
(ibs
, iicomma
) ->
2267 let ias_unsplit = unsplit_icomma ias
in
2268 let ibs_split = resplit_initialiser ibs iicomma
in
2270 if need_unordered_initialisers ibs
2271 then initialisers_unordered2 allminus
ias_unsplit ibs_split >>=
2272 (fun ias_unsplit ibs_split ->
2274 split_icomma ias_unsplit,
2275 unsplit_initialiser ibs_split))
2278 and ar_initialisers
= fun ias
(ibs
, iicomma
) ->
2279 (* this doesn't check need_unordered_initialisers because ... can be
2280 implemented as ordered, even if it matches unordered initializers *)
2281 let ibs = resplit_initialiser ibs iicomma
in
2284 (List.map
(function (elem
,comma
) -> [Left elem
; Right
[comma
]]) ibs) in
2285 initialisers_ordered2 ias
ibs >>=
2286 (fun ias
ibs_split ->
2288 match List.rev
ibs_split with
2289 (Right comma
)::rest
-> (Ast_c.unsplit_comma
(List.rev rest
),comma
)
2290 | (Left _
)::_
-> (Ast_c.unsplit_comma
ibs_split,[]) (* possible *)
2292 return (ias
, (ibs,iicomma
)))
2294 and initialisers_ordered2
= fun ias
ibs ->
2296 match A.unwrap ea
with
2297 A.Idots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2299 let build_dots (mcode, optexpr
) = A.Idots
(mcode, optexpr
) in
2300 let match_comma ea
=
2301 match A.unwrap ea
with
2302 A.IComma ia1
-> Some ia1
2304 let build_comma ia1
= A.IComma ia1
in
2305 let match_metalist ea
= None
in
2306 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
2307 let mktermval v
= failwith
"not possible" in
2308 let special_cases ea
eas ebs
= None
in
2309 let no_ii x
= failwith
"not possible" in
2310 list_matcher match_dots build_dots match_comma build_comma
2311 match_metalist build_metalist mktermval
2312 special_cases initialiser
X.distrf_inis
no_ii ias
ibs
2315 and initialisers_unordered2
= fun allminus ias
ibs ->
2320 let rec loop = function
2321 [] -> return ([],[])
2322 | (ib
,comma
)::ibs ->
2323 X.distrf_ini
minusizer ib
>>= (fun _ ib
->
2324 tokenf minusizer comma
>>= (fun _ comma
->
2325 loop ibs >>= (fun l
ibs ->
2326 return(l
,(ib
,comma
)::ibs)))) in
2328 else return ([], ys
)
2330 let permut = Common.uncons_permut_lazy ys
in
2331 permut +> List.fold_left
(fun acc
((e
, pos
), rest
) ->
2333 (initialiser_comma x e
2335 let rest = Lazy.force
rest in
2336 initialisers_unordered2 allminus xs
rest >>= (fun xs
rest ->
2339 Common.insert_elem_pos
(e
, pos
) rest
2343 and initialiser_comma
(x
,xcomma
) (y
, commay
) =
2344 match A.unwrap xcomma
with
2346 tokenf commax commay
>>= (fun commax commay
->
2347 initialiser x y
>>= (fun x y
->
2349 (x
, (A.IComma commax
) +> A.rewrap xcomma
),
2351 | _
-> raise Impossible
(* unsplit_iicomma wrong *)
2353 (* ------------------------------------------------------------------------- *)
2354 and (struct_fields
: (A.declaration list
, B.field list
) matcher
) =
2357 match A.unwrap ea
with
2358 A.Ddots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2360 let build_dots (mcode, optexpr
) = A.Ddots
(mcode, optexpr
) in
2361 let match_comma ea
= None
in
2362 let build_comma ia1
= failwith
"not possible" in
2363 let match_metalist ea
= None
in
2364 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
2365 let mktermval v
= failwith
"not possible" in
2366 let special_cases ea
eas ebs
= None
in
2367 let no_ii x
= failwith
"not possible" in
2368 let make_ebs ebs
= List.map
(function x
-> Left x
) ebs
in
2369 let unmake_ebs ebs
=
2370 List.map
(function Left x
-> x
| Right x
-> failwith
"no right") ebs
in
2371 let distrf mcode startxs =
2372 let startxs = unmake_ebs startxs in
2373 X.distrf_struct_fields
mcode startxs >>=
2374 (fun mcode startxs -> return (mcode,make_ebs startxs)) in
2375 list_matcher match_dots build_dots match_comma build_comma
2376 match_metalist build_metalist mktermval
2377 special_cases struct_field
distrf no_ii eas (make_ebs ebs
) >>=
2378 (fun eas ebs
-> return (eas,unmake_ebs ebs
))
2380 and (struct_field
: (A.declaration
, B.field
) matcher
) = fun fa fb
->
2382 match A.unwrap fa
,fb
with
2383 | A.MetaField
(ida
,keep
,inherited
), _
->
2385 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_field fb
) in
2386 X.envf keep inherited
(ida
, Ast_c.MetaFieldVal fb
, max_min) (fun () ->
2387 X.distrf_field ida fb
2388 ) >>= (fun ida fb
->
2389 return ((A.MetaField
(ida
, keep
, inherited
))+> A.rewrap fa
,
2391 | _
,B.DeclarationField
(B.FieldDeclList
(onefield_multivars
,iiptvirg
)) ->
2393 let iiptvirgb = tuple_of_list1 iiptvirg
in
2395 (match onefield_multivars
with
2396 | [] -> raise Impossible
2397 | [onevar
,iivirg
] ->
2398 assert (null iivirg
);
2400 | B.BitField
(sopt
, typb
, _
, expr
) ->
2401 pr2_once
"warning: bitfield not handled by ast_cocci";
2403 | B.Simple
(None
, typb
) ->
2404 pr2_once
"warning: unamed struct field not handled by ast_cocci";
2406 | B.Simple
(Some nameidb
, typb
) ->
2408 (* build a declaration from a struct field *)
2409 let allminus = false in
2411 let stob = B.NoSto
, false in
2413 ({B.v_namei
= Some
(nameidb
, None
);
2416 B.v_local
= Ast_c.NotLocalDecl
;
2417 B.v_attr
= Ast_c.noattr
;
2418 B.v_type_bis
= ref None
;
2419 (* the struct field should also get expanded ? no it's not
2420 * important here, we will rematch very soon *)
2424 onedecl
allminus fa
(fake_var,iiptvirgb,iisto) >>=
2425 (fun fa
(var
,iiptvirgb,iisto) ->
2428 | ({B.v_namei
= Some
(nameidb
, None
);
2433 let onevar = B.Simple
(Some nameidb
, typb
) in
2437 ((B.DeclarationField
2438 (B.FieldDeclList
([onevar, iivirg
], [iiptvirgb])))
2441 | _
-> raise Impossible
2446 pr2_once
"PB: More that one variable in decl. Have to split";
2449 | _
,B.EmptyField _iifield
->
2452 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
),B.MacroDeclField
((sb
,ebs
),ii
) ->
2454 | _
,B.MacroDeclField
((sb
,ebs
),ii
) -> fail
2456 | _
,B.CppDirectiveStruct directive
-> fail
2457 | _
,B.IfdefStruct directive
-> fail
2460 and enum_fields
= fun eas ebs
->
2462 match A.unwrap ea
with
2463 A.Edots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2465 let build_dots (mcode, optexpr
) = A.Edots
(mcode, optexpr
) in
2466 let match_comma ea
=
2467 match A.unwrap ea
with
2468 A.EComma ia1
-> Some ia1
2470 let build_comma ia1
= A.EComma ia1
in
2471 let match_metalist ea
= None
in
2472 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
2473 let mktermval v
= failwith
"not possible" in
2474 let special_cases ea
eas ebs
= None
in
2475 list_matcher match_dots build_dots match_comma build_comma
2476 match_metalist build_metalist mktermval
2477 special_cases enum_field
X.distrf_enum_fields
2478 Lib_parsing_c.ii_of_enum_fields
eas ebs
2480 and enum_field ida idb
=
2481 X.all_bound
(A.get_inherited ida
) >&&>
2482 match A.unwrap ida
, idb
with
2483 A.Ident
(id
),(nameidb
,None
) ->
2484 ident_cpp DontKnow id nameidb
>>= (fun id nameidb
->
2485 return ((A.Ident id
) +> A.rewrap ida
, (nameidb
,None
)))
2486 | A.Assignment
(ea1
,opa
,ea2
,init
),(nameidb
,Some
(opbi,eb2
)) ->
2487 (match A.unwrap ea1
with
2489 ident_cpp DontKnow id nameidb
>>= (fun id nameidb
->
2490 expression ea2 eb2
>>= (fun ea2 eb2
->
2491 tokenf opa
opbi >>= (fun opa
opbi -> (* only one kind of assignop *)
2493 (A.Assignment
((A.Ident
(id
))+>A.rewrap ea1
,opa
,ea2
,init
)) +>
2495 (nameidb
,Some
(opbi,eb2
))))))
2496 | _
-> failwith
"not possible")
2497 | _
-> failwith
"not possible"
2499 (* ------------------------------------------------------------------------- *)
2500 and (fullType
: (A.fullType
, Ast_c.fullType
) matcher
) =
2502 X.optional_qualifier_flag
(fun optional_qualifier
->
2503 X.all_bound
(A.get_inherited typa
) >&&>
2504 match A.unwrap typa
, typb
with
2505 | A.Type
(cv
,ty1
), ((qu
,il
),ty2
) ->
2507 if qu
.B.const
&& qu
.B.volatile
2510 ("warning: the type is both const & volatile but cocci " ^
2511 "does not handle that");
2513 (* Drop out the const/volatile part that has been matched.
2514 * This is because a SP can contain const T v; in which case
2515 * later in match_t_t when we encounter a T, we must not add in
2516 * the environment the whole type.
2521 (* "iso-by-absence" *)
2524 fullTypebis ty1
((qu
,il
), ty2
) >>= (fun ty1 fullty2
->
2526 (A.Type
(None
, ty1
)) +> A.rewrap typa
,
2530 (match optional_qualifier
, qu
.B.const
|| qu
.B.volatile
with
2531 | false, false -> do_stuff ()
2532 | false, true -> fail
2533 | true, false -> do_stuff ()
2536 then pr2_once
"USING optional_qualifier builtin isomorphism";
2542 (* todo: can be __const__ ? can be const & volatile so
2543 * should filter instead ?
2545 (match term x
, il
with
2546 | A.Const
, [i1
] when qu
.B.const
->
2548 tokenf x i1
>>= (fun x i1
->
2549 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2551 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2555 | A.Volatile
, [i1
] when qu
.B.volatile
->
2556 tokenf x i1
>>= (fun x i1
->
2557 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2559 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2567 | A.DisjType typas
, typb
->
2569 List.fold_left
(fun acc typa
-> acc
>|+|> (fullType typa typb
)) fail
2571 | A.OptType
(_
), _
| A.UniqueType
(_
), _
2572 -> failwith
"not handling Opt/Unique on type"
2577 * Why not (A.typeC, Ast_c.typeC) matcher ?
2578 * because when there is MetaType, we want that T record the whole type,
2579 * including the qualifier, and so this type (and the new_il function in
2580 * preceding function).
2583 and (fullTypebis
: (A.typeC
, Ast_c.fullType
) matcher
) =
2585 X.all_bound
(A.get_inherited ta
) >&&>
2586 match A.unwrap ta
, tb
with
2589 | A.MetaType
(ida
,keep
, inherited
), typb
->
2591 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
2592 X.envf keep inherited
(ida
, B.MetaTypeVal typb
, max_min) (fun () ->
2593 X.distrf_type ida typb
>>= (fun ida typb
->
2595 A.MetaType
(ida
,keep
, inherited
) +> A.rewrap ta
,
2599 | unwrap
, (qub
, typb
) ->
2600 typeC ta typb
>>= (fun ta typb
->
2601 return (ta
, (qub
, typb
))
2604 and simulate_signed ta basea stringsa signaopt tb baseb ii rebuilda
=
2605 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2606 * And even if in baseb we have a Signed Int, that does not mean
2607 * that ii is of length 2, cos Signed is the default, so if in signa
2608 * we have Signed explicitely ? we cant "accrocher" this mcode to
2609 * something :( So for the moment when there is signed in cocci,
2610 * we force that there is a signed in c too (done in pattern.ml).
2612 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2615 (* handle some iso on type ? (cf complex C rule for possible implicit
2617 match basea
, baseb
with
2618 | A.VoidType
, B.Void
2619 | A.FloatType
, B.FloatType
(B.CFloat
)
2620 | A.DoubleType
, B.FloatType
(B.CDouble
) ->
2621 assert (signaopt
=*= None
);
2622 let stringa = tuple_of_list1 stringsa
in
2623 let (ibaseb
) = tuple_of_list1 ii
in
2624 tokenf stringa ibaseb
>>= (fun stringa ibaseb
->
2626 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2627 (B.BaseType baseb
, [ibaseb
])
2630 | A.CharType
, B.IntType
B.CChar
when signaopt
=*= None
->
2631 let stringa = tuple_of_list1 stringsa
in
2632 let ibaseb = tuple_of_list1 ii
in
2633 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2635 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2636 (B.BaseType
(B.IntType
B.CChar
), [ibaseb])
2639 | A.CharType
,B.IntType
(B.Si
(_sign
, B.CChar2
)) when signaopt
<> None
->
2640 let stringa = tuple_of_list1 stringsa
in
2641 let ibaseb = tuple_of_list1 iibaseb
in
2642 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2643 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2645 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2646 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2649 | A.ShortType
, B.IntType
(B.Si
(_
, B.CShort
))
2650 | A.IntType
, B.IntType
(B.Si
(_
, B.CInt
))
2651 | A.LongType
, B.IntType
(B.Si
(_
, B.CLong
)) ->
2652 let stringa = tuple_of_list1 stringsa
in
2655 (* iso-by-presence ? *)
2656 (* when unsigned int in SP, allow have just unsigned in C ? *)
2657 if mcode_contain_plus (mcodekind stringa)
2661 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2663 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2664 (B.BaseType
(baseb
), iisignbopt
++ [])
2670 "warning: long int or short int not handled by ast_cocci";
2674 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2675 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2677 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2678 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2680 | _
-> raise Impossible
2685 | A.LongLongType
, B.IntType
(B.Si
(_
, B.CLongLong
)) ->
2686 let (string1a
,string2a
) = tuple_of_list2 stringsa
in
2688 [ibase1b
;ibase2b
] ->
2689 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2690 tokenf string1a ibase1b
>>= (fun base1a ibase1b
->
2691 tokenf string2a ibase2b
>>= (fun base2a ibase2b
->
2693 (rebuilda
([base1a
;base2a
], signaopt
)) +> A.rewrap ta
,
2694 (B.BaseType
(baseb
), iisignbopt
++ [ibase1b
;ibase2b
])
2696 | [] -> fail (* should something be done in this case? *)
2697 | _
-> raise Impossible
)
2700 | _
, B.FloatType
B.CLongDouble
2703 "warning: long double not handled by ast_cocci";
2706 | _
, (B.Void
|B.FloatType _
|B.IntType _
) -> fail
2708 and simulate_signed_meta ta basea signaopt tb baseb ii rebuilda
=
2709 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2710 * And even if in baseb we have a Signed Int, that does not mean
2711 * that ii is of length 2, cos Signed is the default, so if in signa
2712 * we have Signed explicitely ? we cant "accrocher" this mcode to
2713 * something :( So for the moment when there is signed in cocci,
2714 * we force that there is a signed in c too (done in pattern.ml).
2716 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2718 let match_to_type rebaseb
=
2719 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2720 let fta = A.rewrap basea
(A.Type
(None
,basea
)) in
2721 let ftb = Ast_c.nQ
,(B.BaseType
(rebaseb
), iibaseb
) in
2722 fullType
fta ftb >>= (fun fta (_
,tb
) ->
2723 (match A.unwrap
fta,tb
with
2724 A.Type
(_
,basea
), (B.BaseType baseb
, ii
) ->
2726 (rebuilda
(basea
, signaopt
)) +> A.rewrap ta
,
2727 (B.BaseType
(baseb
), iisignbopt
++ ii
)
2729 | _
-> failwith
"not possible"))) in
2731 (* handle some iso on type ? (cf complex C rule for possible implicit
2734 | B.IntType
(B.Si
(_sign
, B.CChar2
)) ->
2735 match_to_type (B.IntType
B.CChar
)
2737 | B.IntType
(B.Si
(_
, ty
)) ->
2739 | [] -> fail (* metavariable has to match something *)
2741 | _
-> match_to_type (B.IntType
(B.Si
(B.Signed
, ty
)))
2745 | (B.Void
|B.FloatType _
|B.IntType _
) -> fail
2747 and (typeC
: (A.typeC
, Ast_c.typeC
) matcher
) =
2749 match A.unwrap ta
, tb
with
2750 | A.BaseType
(basea
,stringsa
), (B.BaseType baseb
, ii
) ->
2751 simulate_signed ta basea stringsa None tb baseb ii
2752 (function (stringsa
, signaopt
) -> A.BaseType
(basea
,stringsa
))
2753 | A.SignedT
(signaopt
, Some basea
), (B.BaseType baseb
, ii
) ->
2754 (match A.unwrap basea
with
2755 A.BaseType
(basea1
,strings1
) ->
2756 simulate_signed ta basea1 strings1
(Some signaopt
) tb baseb ii
2757 (function (strings1
, Some signaopt
) ->
2760 Some
(A.rewrap basea
(A.BaseType
(basea1
,strings1
))))
2761 | _
-> failwith
"not possible")
2762 | A.MetaType
(ida
,keep
,inherited
) ->
2763 simulate_signed_meta ta basea
(Some signaopt
) tb baseb ii
2764 (function (basea
, Some signaopt
) ->
2765 A.SignedT
(signaopt
,Some basea
)
2766 | _
-> failwith
"not possible")
2767 | _
-> failwith
"not possible")
2768 | A.SignedT
(signa
,None
), (B.BaseType baseb
, ii
) ->
2769 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2770 (match iibaseb
, baseb
with
2771 | [], B.IntType
(B.Si
(_sign
, B.CInt
)) ->
2772 sign
(Some signa
) signbopt >>= (fun signaopt iisignbopt
->
2774 | None
-> raise Impossible
2777 (A.SignedT
(signa
,None
)) +> A.rewrap ta
,
2778 (B.BaseType baseb
, iisignbopt
)
2786 (* todo? iso with array *)
2787 | A.Pointer
(typa
, iamult
), (B.Pointer typb
, ii
) ->
2788 let (ibmult
) = tuple_of_list1 ii
in
2789 fullType typa typb
>>= (fun typa typb
->
2790 tokenf iamult ibmult
>>= (fun iamult ibmult
->
2792 (A.Pointer
(typa
, iamult
)) +> A.rewrap ta
,
2793 (B.Pointer typb
, [ibmult
])
2796 | A.FunctionType
(allminus,tyaopt
,lpa
,paramsa
,rpa
),
2797 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
) ->
2799 let (lpb
, rpb
) = tuple_of_list2 ii
in
2803 ("Not handling well variable length arguments func. "^
2804 "You have been warned");
2805 tokenf lpa lpb
>>= (fun lpa lpb
->
2806 tokenf rpa rpb
>>= (fun rpa rpb
->
2807 fullType_optional_allminus
allminus tyaopt tyb
>>= (fun tyaopt tyb
->
2808 parameters
(seqstyle paramsa
) (A.undots paramsa
) paramsb
>>=
2809 (fun paramsaundots paramsb
->
2810 let paramsa = redots
paramsa paramsaundots
in
2812 (A.FunctionType
(allminus,tyaopt
,lpa
,paramsa,rpa
) +> A.rewrap ta
,
2813 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), [lpb
;rpb
])
2821 | A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
),
2822 (B.ParenType t1
, ii
) ->
2823 let (lp1b
, rp1b
) = tuple_of_list2 ii
in
2824 let (qu1b
, t1b
) = t1
in
2826 | B.Pointer t2
, ii
->
2827 let (starb
) = tuple_of_list1 ii
in
2828 let (qu2b
, t2b
) = t2
in
2830 | B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
->
2831 let (lp2b
, rp2b
) = tuple_of_list2 ii
in
2836 ("Not handling well variable length arguments func. "^
2837 "You have been warned");
2839 fullType tya tyb
>>= (fun tya tyb
->
2840 tokenf lp1a lp1b
>>= (fun lp1a lp1b
->
2841 tokenf rp1a rp1b
>>= (fun rp1a rp1b
->
2842 tokenf lp2a lp2b
>>= (fun lp2a lp2b
->
2843 tokenf rp2a rp2b
>>= (fun rp2a rp2b
->
2844 tokenf stara starb
>>= (fun stara starb
->
2845 parameters
(seqstyle paramsa) (A.undots
paramsa) paramsb
>>=
2846 (fun paramsaundots paramsb
->
2847 let paramsa = redots
paramsa paramsaundots
in
2851 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))),
2856 (B.Pointer
t2, [starb
]))
2860 (A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
))
2862 (B.ParenType
t1, [lp1b
;rp1b
])
2875 (* todo: handle the iso on optionnal size specifification ? *)
2876 | A.Array
(typa
, ia1
, eaopt
, ia2
), (B.Array
(ebopt
, typb
), ii
) ->
2877 let (ib1, ib2
) = tuple_of_list2 ii
in
2878 fullType typa typb
>>= (fun typa typb
->
2879 option expression eaopt ebopt
>>= (fun eaopt ebopt
->
2880 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2881 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2883 (A.Array
(typa
, ia1
, eaopt
, ia2
)) +> A.rewrap ta
,
2884 (B.Array
(ebopt
, typb
), [ib1;ib2
])
2888 (* todo: could also match a Struct that has provided a name *)
2889 (* This is for the case where the SmPL code contains "struct x", without
2890 a definition. In this case, the name field is always present.
2891 This case is also called from the case for A.StructUnionDef when
2892 a name is present in the C code. *)
2893 | A.StructUnionName
(sua
, Some sa
), (B.StructUnionName
(sub
, sb
), ii
) ->
2894 (* sa is now an ident, not an mcode, old: ... && (term sa) =$= sb *)
2895 let (ib1, ib2
) = tuple_of_list2 ii
in
2896 if equal_structUnion (term sua
) sub
2898 ident DontKnow sa
(sb
, ib2
) >>= (fun sa
(sb
, ib2
) ->
2899 tokenf sua
ib1 >>= (fun sua
ib1 ->
2901 (A.StructUnionName
(sua
, Some sa
)) +> A.rewrap ta
,
2902 (B.StructUnionName
(sub
, sb
), [ib1;ib2
])
2907 | A.StructUnionDef
(ty
, lba
, declsa, rba
),
2908 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
2910 let (ii_sub_sb
, lbb
, rbb
) =
2912 [iisub
; lbb
; rbb
] -> (Common.Left iisub
,lbb
,rbb
)
2913 | [iisub
; iisb
; lbb
; rbb
] -> (Common.Right
(iisub
,iisb
),lbb
,rbb
)
2914 | _
-> failwith
"list of length 3 or 4 expected" in
2917 match (sbopt
,ii_sub_sb
) with
2918 (None
,Common.Left iisub
) ->
2919 (* the following doesn't reconstruct the complete SP code, just
2920 the part that matched *)
2922 match A.unwrap
s with
2924 (match A.unwrap ty
with
2925 A.StructUnionName
(sua
, None
) ->
2926 (match (term sua
, sub
) with
2928 | (A.Union
,B.Union
) -> return ((),())
2931 tokenf sua iisub
>>= (fun sua iisub
->
2934 A.StructUnionName
(sua
, None
) +> A.rewrap
ty)
2936 return (ty,[iisub
])))
2938 | A.DisjType
(disjs
) ->
2940 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
2944 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
2946 (* build a StructUnionName from a StructUnion *)
2947 let fake_su = B.nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) in
2949 fullType
ty fake_su >>= (fun ty fake_su ->
2951 | _nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) ->
2952 return (ty, [iisub
; iisb
])
2953 | _
-> raise Impossible
)
2957 >>= (fun ty ii_sub_sb
->
2959 tokenf lba lbb
>>= (fun lba lbb
->
2960 tokenf rba rbb
>>= (fun rba rbb
->
2961 struct_fields
(A.undots
declsa) declsb
>>=(fun undeclsa declsb
->
2962 let declsa = redots
declsa undeclsa
in
2965 (A.StructUnionDef
(ty, lba
, declsa, rba
)) +> A.rewrap ta
,
2966 (B.StructUnion
(sub
, sbopt
, declsb
),ii_sub_sb
@[lbb
;rbb
])
2970 (* todo? handle isomorphisms ? because Unsigned Int can be match on a
2971 * uint in the C code. But some CEs consists in renaming some types,
2972 * so we don't want apply isomorphisms every time.
2974 | A.TypeName sa
, (B.TypeName
(nameb
, typb
), noii
) ->
2978 | B.RegularName
(sb
, iidb
) ->
2979 let iidb1 = tuple_of_list1 iidb
in
2983 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
2985 (A.TypeName sa
) +> A.rewrap ta
,
2986 (B.TypeName
(B.RegularName
(sb
, [iidb1]), typb
), noii
)
2990 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
2995 | _
, (B.TypeOfExpr e
, ii
) -> fail
2996 | _
, (B.TypeOfType e
, ii
) -> fail
2998 | _
, (B.ParenType e
, ii
) -> fail (* todo ?*)
2999 | A.EnumName
(en
,Some namea
), (B.EnumName nameb
, ii
) ->
3000 let (ib1,ib2
) = tuple_of_list2 ii
in
3001 ident DontKnow namea
(nameb
, ib2
) >>= (fun namea
(nameb
, ib2
) ->
3002 tokenf en
ib1 >>= (fun en
ib1 ->
3004 (A.EnumName
(en
, Some namea
)) +> A.rewrap ta
,
3005 (B.EnumName nameb
, [ib1;ib2
])
3008 | A.EnumDef
(ty, lba
, idsa
, rba
),
3009 (B.Enum
(sbopt
, idsb
), ii
) ->
3011 let (ii_sub_sb
, lbb
, rbb
, comma_opt
) =
3013 [iisub
; lbb
; rbb
; comma_opt
] ->
3014 (Common.Left iisub
,lbb
,rbb
,comma_opt
)
3015 | [iisub
; iisb
; lbb
; rbb
; comma_opt
] ->
3016 (Common.Right
(iisub
,iisb
),lbb
,rbb
,comma_opt
)
3017 | _
-> failwith
"list of length 4 or 5 expected" in
3020 match (sbopt
,ii_sub_sb
) with
3021 (None
,Common.Left iisub
) ->
3022 (* the following doesn't reconstruct the complete SP code, just
3023 the part that matched *)
3025 match A.unwrap
s with
3027 (match A.unwrap
ty with
3028 A.EnumName
(sua
, None
) ->
3029 tokenf sua iisub
>>= (fun sua iisub
->
3031 A.Type
(None
,A.EnumName
(sua
, None
) +> A.rewrap
ty)
3033 return (ty,[iisub
]))
3035 | A.DisjType
(disjs
) ->
3037 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
3041 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
3043 (* build an EnumName from an Enum *)
3044 let fake_su = B.nQ
, (B.EnumName sb
, [iisub
;iisb
]) in
3046 fullType
ty fake_su >>= (fun ty fake_su ->
3048 | _nQ
, (B.EnumName sb
, [iisub
;iisb
]) ->
3049 return (ty, [iisub
; iisb
])
3050 | _
-> raise Impossible
)
3054 >>= (fun ty ii_sub_sb
->
3056 tokenf lba lbb
>>= (fun lba lbb
->
3057 tokenf rba rbb
>>= (fun rba rbb
->
3058 let idsb = resplit_initialiser idsb [comma_opt
] in
3062 (function (elem
,comma
) -> [Left elem
; Right
[comma
]])
3064 enum_fields
(A.undots idsa
) idsb >>= (fun unidsa
idsb ->
3065 let idsa = redots
idsa unidsa
in
3067 match List.rev
idsb with
3068 (Right comma
)::rest ->
3069 (Ast_c.unsplit_comma
(List.rev
rest),comma
)
3070 | (Left _
)::_
-> (Ast_c.unsplit_comma
idsb,[]) (* possible *)
3073 (A.EnumDef
(ty, lba
, idsa, rba
)) +> A.rewrap ta
,
3074 (B.Enum
(sbopt
, idsb),ii_sub_sb
@[lbb
;rbb
]@iicomma
)
3078 | _
, (B.Enum _
, _
) -> fail (* todo cocci ?*)
3081 ((B.TypeName _
| B.StructUnionName
(_
, _
) | B.EnumName _
|
3082 B.StructUnion
(_
, _
, _
) |
3083 B.FunctionType _
| B.Array
(_
, _
) | B.Pointer _
|
3089 (* todo: iso on sign, if not mentioned then free. tochange?
3090 * but that require to know if signed int because explicit
3091 * signed int, or because implicit signed int.
3094 and sign signa signb
=
3095 match signa
, signb
with
3096 | None
, None
-> return (None
, [])
3097 | Some signa
, Some
(signb
, ib
) ->
3098 if equal_sign (term signa
) signb
3099 then tokenf signa ib
>>= (fun signa ib
->
3100 return (Some signa
, [ib
])
3106 and minusize_list iixs
=
3107 iixs
+> List.fold_left
(fun acc ii
->
3108 acc
>>= (fun xs ys
->
3109 tokenf minusizer ii
>>= (fun minus ii
->
3110 return (minus
::xs
, ii
::ys
)
3111 ))) (return ([],[]))
3112 >>= (fun _xsminys ys
->
3113 return ((), List.rev ys
)
3116 and storage_optional_allminus
allminus stoa
(stob, iistob
) =
3117 (* "iso-by-absence" for storage, and return type. *)
3118 X.optional_storage_flag
(fun optional_storage
->
3119 match stoa
, stob with
3120 | None
, (stobis
, inline
) ->
3124 minusize_list iistob
>>= (fun () iistob
->
3125 return (None
, (stob, iistob
))
3127 else return (None
, (stob, iistob
))
3130 (match optional_storage
, stobis
with
3131 | false, B.NoSto
-> do_minus ()
3133 | true, B.NoSto
-> do_minus ()
3136 then pr2_once
"USING optional_storage builtin isomorphism";
3140 | Some x
, ((stobis
, inline
)) ->
3141 if equal_storage (term x
) stobis
3143 let rec loop acc
= function
3146 let str = B.str_of_info i1
in
3148 "static" | "extern" | "auto" | "register" ->
3149 (* not very elegant, but tokenf doesn't know what token to
3151 tokenf x i1
>>= (fun x i1
->
3152 let rebuilt = (List.rev acc
) @ i1
:: iistob
in
3153 return (Some x
, ((stobis
, inline
), rebuilt)))
3154 | _
-> loop (i1
::acc
) iistob
) in
3159 and inline_optional_allminus
allminus inla
(stob, iistob
) =
3160 (* "iso-by-absence" for storage, and return type. *)
3161 X.optional_storage_flag
(fun optional_storage
->
3162 match inla
, stob with
3163 | None
, (stobis
, inline
) ->
3167 minusize_list iistob
>>= (fun () iistob
->
3168 return (None
, (stob, iistob
))
3170 else return (None
, (stob, iistob
))
3179 then pr2_once
"USING optional_storage builtin isomorphism";
3182 else fail (* inline not in SP and present in C code *)
3185 | Some x
, ((stobis
, inline
)) ->
3188 let rec loop acc
= function
3191 let str = B.str_of_info i1
in
3194 (* not very elegant, but tokenf doesn't know what token to
3196 tokenf x i1
>>= (fun x i1
->
3197 let rebuilt = (List.rev acc
) @ i1
:: iistob
in
3198 return (Some x
, ((stobis
, inline
), rebuilt)))
3199 | _
-> loop (i1
::acc
) iistob
) in
3201 else fail (* SP has inline, but the C code does not *)
3204 and fullType_optional_allminus
allminus tya retb
=
3209 X.distrf_type
minusizer retb
>>= (fun _x retb
->
3213 else return (None
, retb
)
3215 fullType tya retb
>>= (fun tya retb
->
3216 return (Some tya
, retb
)
3221 (*---------------------------------------------------------------------------*)
3223 and compatible_base_type a signa b
=
3224 let ok = return ((),()) in
3227 | Type_cocci.VoidType
, B.Void
->
3228 assert (signa
=*= None
);
3230 | Type_cocci.CharType
, B.IntType
B.CChar
when signa
=*= None
->
3232 | Type_cocci.CharType
, B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3233 compatible_sign signa signb
3234 | Type_cocci.ShortType
, B.IntType
(B.Si
(signb
, B.CShort
)) ->
3235 compatible_sign signa signb
3236 | Type_cocci.IntType
, B.IntType
(B.Si
(signb
, B.CInt
)) ->
3237 compatible_sign signa signb
3238 | Type_cocci.LongType
, B.IntType
(B.Si
(signb
, B.CLong
)) ->
3239 compatible_sign signa signb
3240 | _
, B.IntType
(B.Si
(signb
, B.CLongLong
)) ->
3241 pr2_once
"no longlong in cocci";
3243 | Type_cocci.FloatType
, B.FloatType
B.CFloat
->
3244 assert (signa
=*= None
);
3246 | Type_cocci.DoubleType
, B.FloatType
B.CDouble
->
3247 assert (signa
=*= None
);
3249 | _
, B.FloatType
B.CLongDouble
->
3250 pr2_once
"no longdouble in cocci";
3252 | Type_cocci.BoolType
, _
-> failwith
"no booltype in C"
3254 | _
, (B.Void
|B.FloatType _
|B.IntType _
) -> fail
3256 and compatible_base_type_meta a signa qua b ii
local =
3258 | Type_cocci.MetaType
(ida
,keep
,inherited
),
3259 B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3260 compatible_sign signa signb
>>= fun _ _
->
3261 let newb = ((qua
, (B.BaseType
(B.IntType
B.CChar
),ii
)),local) in
3262 compatible_type a
newb
3263 | Type_cocci.MetaType
(ida
,keep
,inherited
), B.IntType
(B.Si
(signb
, ty)) ->
3264 compatible_sign signa signb
>>= fun _ _
->
3266 ((qua
, (B.BaseType
(B.IntType
(B.Si
(B.Signed
, ty))),ii
)),local) in
3267 compatible_type a
newb
3268 | _
, B.FloatType
B.CLongDouble
->
3269 pr2_once
"no longdouble in cocci";
3272 | _
, (B.Void
|B.FloatType _
|B.IntType _
) -> fail
3275 and compatible_type a
(b
,local) =
3276 let ok = return ((),()) in
3278 let rec loop = function
3279 | Type_cocci.BaseType a
, (qua
, (B.BaseType b
,ii
)) ->
3280 compatible_base_type a None b
3282 | Type_cocci.SignedT
(signa
,None
), (qua
, (B.BaseType b
,ii
)) ->
3283 compatible_base_type
Type_cocci.IntType
(Some signa
) b
3285 | Type_cocci.SignedT
(signa
,Some
ty), (qua
, (B.BaseType b
,ii
)) ->
3287 Type_cocci.BaseType
ty ->
3288 compatible_base_type
ty (Some signa
) b
3289 | Type_cocci.MetaType
(ida
,keep
,inherited
) ->
3290 compatible_base_type_meta
ty (Some signa
) qua b ii
local
3291 | _
-> failwith
"not possible")
3293 | Type_cocci.Pointer a
, (qub
, (B.Pointer b
, ii
)) ->
3295 | Type_cocci.FunctionPointer a
, _
->
3297 "TODO: function pointer type doesn't store enough information to determine compatability"
3298 | Type_cocci.Array a
, (qub
, (B.Array
(eopt
, b
),ii
)) ->
3299 (* no size info for cocci *)
3301 | Type_cocci.StructUnionName
(sua
, name
),
3302 (qub
, (B.StructUnionName
(sub
, sb
),ii
)) ->
3303 if equal_structUnion_type_cocci sua sub
3304 then structure_type_name name sb ii
3306 | Type_cocci.EnumName
(name
),
3307 (qub
, (B.EnumName
(sb
),ii
)) -> structure_type_name name sb ii
3308 | Type_cocci.TypeName sa
, (qub
, (B.TypeName
(namesb
, _typb
),noii
)) ->
3309 let sb = Ast_c.str_of_name namesb
in
3314 | Type_cocci.ConstVol
(qua
, a
), (qub
, b
) ->
3315 if (fst qub
).B.const
&& (fst qub
).B.volatile
3318 pr2_once
("warning: the type is both const & volatile but cocci " ^
3319 "does not handle that");
3325 | Type_cocci.Const
-> (fst qub
).B.const
3326 | Type_cocci.Volatile
-> (fst qub
).B.volatile
3328 then loop (a
,(Ast_c.nQ
, b
))
3331 | Type_cocci.MetaType
(ida
,keep
,inherited
), typb
->
3333 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
3334 X.envf keep inherited
(A.make_mcode ida
, B.MetaTypeVal typb
, max_min)
3338 (* subtil: must be after the MetaType case *)
3339 | a
, (qub
, (B.TypeName
(_namesb
, Some b
), noii
)) ->
3340 (* kind of typedef iso *)
3343 (* for metavariables of type expression *^* *)
3344 | Type_cocci.Unknown
, _
-> ok
3349 B.TypeOfType _
|B.TypeOfExpr _
|B.ParenType _
|
3350 B.EnumName _
|B.StructUnion
(_
, _
, _
)|B.Enum
(_
, _
)
3357 B.StructUnionName
(_
, _
)|
3359 B.Array
(_
, _
)|B.Pointer _
|B.TypeName _
|
3364 and structure_type_name nm
sb ii
=
3366 Type_cocci.NoName
-> ok
3367 | Type_cocci.Name sa
->
3371 | Type_cocci.MV
(ida
,keep
,inherited
) ->
3372 (* degenerate version of MetaId, no transformation possible *)
3373 let (ib1, ib2
) = tuple_of_list2 ii
in
3374 let max_min _
= Lib_parsing_c.lin_col_by_pos
[ib2
] in
3375 let mida = A.make_mcode ida
in
3376 X.envf keep inherited
(mida, B.MetaIdVal
(sb,[]), max_min)
3382 and compatible_sign signa signb
=
3383 let ok = return ((),()) in
3384 match signa
, signb
with
3386 | Some
Type_cocci.Signed
, B.Signed
3387 | Some
Type_cocci.Unsigned
, B.UnSigned
3392 and equal_structUnion_type_cocci a b
=
3394 | Type_cocci.Struct
, B.Struct
-> true
3395 | Type_cocci.Union
, B.Union
-> true
3396 | _
, (B.Struct
| B.Union
) -> false
3400 (*---------------------------------------------------------------------------*)
3401 and inc_file
(a
, before_after
) (b
, h_rel_pos
) =
3403 let rec aux_inc (ass
, bss
) passed
=
3407 let passed = List.rev
passed in
3409 (match before_after
, !h_rel_pos
with
3410 | IncludeNothing
, _
-> true
3411 | IncludeMcodeBefore
, Some x
->
3412 List.mem
passed (x
.Ast_c.first_of
)
3414 | IncludeMcodeAfter
, Some x
->
3415 List.mem
passed (x
.Ast_c.last_of
)
3417 (* no info, maybe cos of a #include <xx.h> that was already in a .h *)
3421 | (A.IncPath x
)::xs
, y
::ys
-> x
=$
= y
&& aux_inc (xs
, ys
) (x
::passed)
3422 | _
-> failwith
"IncDots not in last place or other pb"
3427 | A.Local ass
, B.Local bss
->
3428 aux_inc (ass
, bss
) []
3429 | A.NonLocal ass
, B.NonLocal bss
->
3430 aux_inc (ass
, bss
) []
3435 (*---------------------------------------------------------------------------*)
3437 and (define_params
: sequence
->
3438 (A.define_param list
, (string B.wrap
) B.wrap2 list
) matcher
) =
3439 fun seqstyle eas ebs
->
3441 | Unordered
-> failwith
"not handling ooo"
3443 define_paramsbis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
3444 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
3447 (* todo? facto code with argument and parameters ? *)
3448 and define_paramsbis
= fun eas ebs
->
3450 match A.unwrap ea
with
3451 A.DPdots
(mcode) -> Some
(mcode, None
)
3453 let build_dots (mcode, _optexpr
) = A.DPdots
(mcode) in
3454 let match_comma ea
=
3455 match A.unwrap ea
with
3456 A.DPComma ia1
-> Some ia1
3458 let build_comma ia1
= A.DPComma ia1
in
3459 let match_metalist ea
= None
in
3460 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
3461 let mktermval v
= failwith
"not possible" in
3462 let special_cases ea
eas ebs
= None
in
3463 let no_ii x
= failwith
"not possible" in
3464 list_matcher match_dots build_dots match_comma build_comma
3465 match_metalist build_metalist mktermval
3466 special_cases define_parameter
X.distrf_define_params
no_ii eas ebs
3468 and define_parameter
= fun parama paramb
->
3469 match A.unwrap parama
, paramb
with
3470 A.DParam ida
, (idb
, ii
) ->
3471 let ib1 = tuple_of_list1 ii
in
3472 ident DontKnow ida
(idb
, ib1) >>= (fun ida
(idb
, ib1) ->
3473 return ((A.DParam ida
)+> A.rewrap parama
,(idb
, [ib1])))
3474 | (A.OptDParam _
| A.UniqueDParam _
), _
->
3475 failwith
"handling Opt/Unique for define parameters"
3476 | A.DPcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
3479 (*****************************************************************************)
3481 (*****************************************************************************)
3483 (* no global solution for positions here, because for a statement metavariable
3484 we want a MetaStmtVal, and for the others, it's not clear what we want *)
3486 let rec (rule_elem_node
: (A.rule_elem
, Control_flow_c.node
) matcher
) =
3489 x
>>= (fun a b
-> return (A.rewrap re a
, F.rewrap node b
))
3491 X.all_bound
(A.get_inherited re
) >&&>
3494 match A.unwrap re
, F.unwrap node
with
3496 (* note: the order of the clauses is important. *)
3498 | _
, F.Enter
| _
, F.Exit
| _
, F.ErrorExit
-> fail2()
3500 (* the metaRuleElem contains just '-' information. We dont need to add
3501 * stuff in the environment. If we need stuff in environment, because
3502 * there is a + S somewhere, then this will be done via MetaStmt, not
3504 * Can match TrueNode/FalseNode/... so must be placed before those cases.
3507 | A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
->
3508 let default = A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
in
3509 (match unwrap_node
with
3511 | F.TrueNode
| F.FalseNode
| F.AfterNode
3512 | F.LoopFallThroughNode
| F.FallThroughNode
3514 if X.mode
=*= PatternMode
3517 if mcode_contain_plus (mcodekind mcode)
3518 then failwith
"try add stuff on fake node"
3519 (* minusize or contextize a fake node is ok *)
3522 | F.EndStatement None
->
3523 if X.mode
=*= PatternMode
then return default
3525 (* DEAD CODE NOW ? only useful in -no_cocci_vs_c_3 ?
3526 if mcode_contain_plus (mcodekind mcode)
3528 let fake_info = Ast_c.fakeInfo() in
3529 distrf distrf_node (mcodekind mcode)
3530 (F.EndStatement (Some fake_info))
3531 else return unwrap_node
3535 | F.EndStatement
(Some i1
) ->
3536 tokenf mcode i1
>>= (fun mcode i1
->
3538 A.MetaRuleElem
(mcode,keep
, inherited
),
3539 F.EndStatement
(Some i1
)
3543 if X.mode
=*= PatternMode
then return default
3544 else failwith
"a MetaRuleElem can't transform a headfunc"
3546 if X.mode
=*= PatternMode
then return default
3548 X.distrf_node
(generalize_mcode mcode) node
>>= (fun mcode node
->
3550 A.MetaRuleElem
(mcode,keep
, inherited
),
3556 (* rene cant have found that a state containing a fake/exit/... should be
3558 * TODO: and F.Fake ?
3560 | _
, F.EndStatement _
| _
, F.CaseNode _
3561 | _
, F.TrueNode
| _
, F.FalseNode
| _
, F.AfterNode
3562 | _
, F.FallThroughNode
| _
, F.LoopFallThroughNode
3566 (* really ? diff between pattern.ml and transformation.ml *)
3567 | _
, F.Fake
-> fail2()
3570 (* cas general: a Meta can match everything. It matches only
3571 * "header"-statement. We transform only MetaRuleElem, not MetaStmt.
3572 * So can't have been called in transform.
3574 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), F.Decl
(_
) -> fail
3576 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), unwrap_node
->
3577 (* todo: should not happen in transform mode *)
3579 (match Control_flow_c.extract_fullstatement node
with
3582 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_stmt stb
) in
3583 X.envf keep inherited
(ida
, Ast_c.MetaStmtVal stb
, max_min)
3585 (* no need tag ida, we can't be called in transform-mode *)
3587 A.MetaStmt
(ida
, keep
, metainfoMaybeTodo
, inherited
),
3595 | A.MetaStmtList _
, _
->
3596 failwith
"not handling MetaStmtList"
3598 | A.TopExp ea
, F.DefineExpr eb
->
3599 expression ea eb
>>= (fun ea eb
->
3605 | A.TopExp ea
, F.DefineType eb
->
3606 (match A.unwrap ea
with
3608 fullType ft eb
>>= (fun ft eb
->
3610 A.TopExp
(A.rewrap ea
(A.TypeExp
(ft
))),
3617 (* It is important to put this case before the one that fails because
3618 * of the lack of the counter part of a C construct in SmPL (for instance
3619 * there is not yet a CaseRange in SmPL). Even if SmPL don't handle
3620 * yet certain constructs, those constructs may contain expression
3621 * that we still want and can transform.
3624 | A.Exp exp
, nodeb
->
3626 (* kind of iso, initialisation vs affectation *)
3628 match A.unwrap exp
, nodeb
with
3629 | A.Assignment
(ea
, op
, eb
, true), F.Decl decl
->
3630 initialisation_to_affectation decl
+> F.rewrap node
3635 (* Now keep fullstatement inside the control flow node,
3636 * so that can then get in a MetaStmtVar the fullstatement to later
3637 * pp back when the S is in a +. But that means that
3638 * Exp will match an Ifnode even if there is no such exp
3639 * inside the condition of the Ifnode (because the exp may
3640 * be deeper, in the then branch). So have to not visit
3641 * all inside a node anymore.
3643 * update: j'ai choisi d'accrocher au noeud du CFG Ã la
3644 * fois le fullstatement et le partialstatement et appeler le
3645 * visiteur que sur le partialstatement.
3648 match Ast_cocci.get_pos re
with
3649 | None
-> expression
3653 Lib_parsing_c.max_min_by_pos
(Lib_parsing_c.ii_of_expr eb
) in
3654 let keep = Type_cocci.Unitary
in
3655 let inherited = false in
3656 let max_min _
= failwith
"no pos" in
3657 X.envf
keep inherited (pos
, B.MetaPosVal
(min
,max
), max_min)
3663 X.cocciExp
expfn exp
node >>= (fun exp
node ->
3671 X.cocciTy fullType
ty node >>= (fun ty node ->
3678 | A.TopInit init
, nodeb
->
3679 X.cocciInit initialiser init
node >>= (fun init
node ->
3687 | A.FunHeader
(mckstart
, allminus, fninfoa
, ida
, oparen
, paramsa, cparen
),
3688 F.FunHeader
({B.f_name
= nameidb
;
3689 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3693 f_old_c_style
= oldstyle
;
3698 then pr2 "OLD STYLE DECL NOT WELL SUPPORTED";
3701 (* fninfoa records the order in which the SP specified the various
3702 information, but this isn't taken into account in the matching.
3703 Could this be a problem for transformation? *)
3706 List.filter
(function A.FStorage
(s) -> true | _
-> false) fninfoa
3707 with [A.FStorage
(s)] -> Some
s | _
-> None
in
3709 match List.filter
(function A.FType
(s) -> true | _
-> false) fninfoa
3710 with [A.FType
(t
)] -> Some t
| _
-> None
in
3713 match List.filter
(function A.FInline
(i
) -> true | _
-> false) fninfoa
3714 with [A.FInline
(i
)] -> Some i
| _
-> None
in
3716 (match List.filter
(function A.FAttr
(a
) -> true | _
-> false) fninfoa
3717 with [A.FAttr
(a
)] -> failwith
"not checking attributes" | _
-> ());
3720 | ioparenb
::icparenb
::iifakestart
::iistob
->
3722 (* maybe important to put ident as the first tokens to transform.
3723 * It's related to transform_proto. So don't change order
3726 ident_cpp LocalFunction ida nameidb
>>= (fun ida nameidb
->
3727 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
3728 tokenf oparen ioparenb
>>= (fun oparen ioparenb
->
3729 tokenf cparen icparenb
>>= (fun cparen icparenb
->
3730 parameters
(seqstyle paramsa)
3731 (A.undots
paramsa) paramsb
>>=
3732 (fun paramsaundots paramsb
->
3733 let paramsa = redots
paramsa paramsaundots
in
3734 inline_optional_allminus
allminus
3735 inla (stob, iistob
) >>= (fun inla (stob, iistob
) ->
3736 storage_optional_allminus
allminus
3737 stoa (stob, iistob
) >>= (fun stoa (stob, iistob
) ->
3742 ("Not handling well variable length arguments func. "^
3743 "You have been warned");
3745 then minusize_list iidotsb
3746 else return ((),iidotsb
)
3747 ) >>= (fun () iidotsb
->
3749 fullType_optional_allminus
allminus tya retb
>>= (fun tya retb
->
3752 (match stoa with Some st
-> [A.FStorage st
] | None
-> []) ++
3753 (match inla with Some i
-> [A.FInline i
] | None
-> []) ++
3754 (match tya with Some t
-> [A.FType t
] | None
-> [])
3759 A.FunHeader
(mckstart
,allminus,fninfoa,ida
,oparen
,
3761 F.FunHeader
({B.f_name
= nameidb
;
3762 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3766 f_old_c_style
= oldstyle
; (* TODO *)
3768 ioparenb
::icparenb
::iifakestart
::iistob
)
3771 | _
-> raise Impossible
3779 | A.Decl
(mckstart
,allminus,decla
), F.Decl declb
->
3780 declaration
(mckstart
,allminus,decla
) declb
>>=
3781 (fun (mckstart
,allminus,decla
) declb
->
3783 A.Decl
(mckstart
,allminus,decla
),
3788 | A.SeqStart
mcode, F.SeqStart
(st
, level
, i1
) ->
3789 tokenf mcode i1
>>= (fun mcode i1
->
3792 F.SeqStart
(st
, level
, i1
)
3795 | A.SeqEnd
mcode, F.SeqEnd
(level
, i1
) ->
3796 tokenf mcode i1
>>= (fun mcode i1
->
3799 F.SeqEnd
(level
, i1
)
3802 | A.ExprStatement
(ea
, ia1
), F.ExprStatement
(st
, (Some eb
, ii
)) ->
3803 let ib1 = tuple_of_list1 ii
in
3804 expression ea eb
>>= (fun ea eb
->
3805 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3807 A.ExprStatement
(ea
, ia1
),
3808 F.ExprStatement
(st
, (Some eb
, [ib1]))
3813 | A.IfHeader
(ia1
,ia2
, ea
, ia3
), F.IfHeader
(st
, (eb
,ii
)) ->
3814 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3815 expression ea eb
>>= (fun ea eb
->
3816 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3817 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3818 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3820 A.IfHeader
(ia1
, ia2
, ea
, ia3
),
3821 F.IfHeader
(st
, (eb
,[ib1;ib2
;ib3
]))
3824 | A.Else ia
, F.Else ib
->
3825 tokenf ia ib
>>= (fun ia ib
->
3826 return (A.Else ia
, F.Else ib
)
3829 | A.WhileHeader
(ia1
, ia2
, ea
, ia3
), F.WhileHeader
(st
, (eb
, ii
)) ->
3830 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3831 expression ea eb
>>= (fun ea eb
->
3832 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3833 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3834 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3836 A.WhileHeader
(ia1
, ia2
, ea
, ia3
),
3837 F.WhileHeader
(st
, (eb
, [ib1;ib2
;ib3
]))
3840 | A.DoHeader ia
, F.DoHeader
(st
, ib
) ->
3841 tokenf ia ib
>>= (fun ia ib
->
3846 | A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
), F.DoWhileTail
(eb
, ii
) ->
3847 let (ib1, ib2
, ib3
, ib4
) = tuple_of_list4 ii
in
3848 expression ea eb
>>= (fun ea eb
->
3849 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3850 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3851 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3852 tokenf ia4 ib4
>>= (fun ia4 ib4
->
3854 A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
),
3855 F.DoWhileTail
(eb
, [ib1;ib2
;ib3
;ib4
])
3857 | A.IteratorHeader
(ia1
, ia2
, eas, ia3
), F.MacroIterHeader
(st
, ((s,ebs
),ii
))
3859 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3861 ident DontKnow ia1
(s, ib1) >>= (fun ia1
(s, ib1) ->
3862 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3863 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3864 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
3865 let eas = redots
eas easundots
in
3867 A.IteratorHeader
(ia1
, ia2
, eas, ia3
),
3868 F.MacroIterHeader
(st
, ((s,ebs
), [ib1;ib2
;ib3
]))
3873 | A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3874 F.ForHeader
(st
, (((eb1opt
,ib3s
), (eb2opt
,ib4s
), (eb3opt
,ib4vide
)), ii
))
3876 assert (null ib4vide
);
3877 let (ib1, ib2
, ib5
) = tuple_of_list3 ii
in
3878 let ib3 = tuple_of_list1 ib3s
in
3879 let ib4 = tuple_of_list1 ib4s
in
3881 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3882 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3883 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3884 tokenf ia4
ib4 >>= (fun ia4
ib4 ->
3885 tokenf ia5 ib5
>>= (fun ia5 ib5
->
3886 option expression ea1opt eb1opt
>>= (fun ea1opt eb1opt
->
3887 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
3888 option expression ea3opt eb3opt
>>= (fun ea3opt eb3opt
->
3890 A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3891 F.ForHeader
(st
, (((eb1opt
,[ib3]), (eb2opt
,[ib4]), (eb3opt
,[])),
3897 | A.SwitchHeader
(ia1
,ia2
,ea
,ia3
), F.SwitchHeader
(st
, (eb
,ii
)) ->
3898 let (ib1, ib2
, ib3) = tuple_of_list3 ii
in
3899 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3900 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3901 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3902 expression ea eb
>>= (fun ea eb
->
3904 A.SwitchHeader
(ia1
,ia2
,ea
,ia3
),
3905 F.SwitchHeader
(st
, (eb
,[ib1;ib2
;ib3]))
3908 | A.Break
(ia1
, ia2
), F.Break
(st
, ((),ii
)) ->
3909 let (ib1, ib2
) = tuple_of_list2 ii
in
3910 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3911 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3914 F.Break
(st
, ((),[ib1;ib2
]))
3917 | A.Continue
(ia1
, ia2
), F.Continue
(st
, ((),ii
)) ->
3918 let (ib1, ib2
) = tuple_of_list2 ii
in
3919 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3920 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3922 A.Continue
(ia1
, ia2
),
3923 F.Continue
(st
, ((),[ib1;ib2
]))
3926 | A.Return
(ia1
, ia2
), F.Return
(st
, ((),ii
)) ->
3927 let (ib1, ib2
) = tuple_of_list2 ii
in
3928 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3929 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3931 A.Return
(ia1
, ia2
),
3932 F.Return
(st
, ((),[ib1;ib2
]))
3935 | A.ReturnExpr
(ia1
, ea
, ia2
), F.ReturnExpr
(st
, (eb
, ii
)) ->
3936 let (ib1, ib2
) = tuple_of_list2 ii
in
3937 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3938 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3939 expression ea eb
>>= (fun ea eb
->
3941 A.ReturnExpr
(ia1
, ea
, ia2
),
3942 F.ReturnExpr
(st
, (eb
, [ib1;ib2
]))
3947 | A.Include
(incla
,filea
),
3948 F.Include
{B.i_include
= (fileb
, ii
);
3949 B.i_rel_pos
= h_rel_pos
;
3950 B.i_is_in_ifdef
= inifdef
;
3953 assert (copt
=*= None
);
3955 let include_requirment =
3956 match mcodekind incla
, mcodekind filea
with
3957 | A.CONTEXT
(_
, A.BEFORE _
), _
->
3959 | _
, A.CONTEXT
(_
, A.AFTER _
) ->
3965 let (inclb
, iifileb
) = tuple_of_list2 ii
in
3966 if inc_file
(term filea
, include_requirment) (fileb
, h_rel_pos
)
3968 tokenf incla inclb
>>= (fun incla inclb
->
3969 tokenf filea iifileb
>>= (fun filea iifileb
->
3971 A.Include
(incla
, filea
),
3972 F.Include
{B.i_include
= (fileb
, [inclb
;iifileb
]);
3973 B.i_rel_pos
= h_rel_pos
;
3974 B.i_is_in_ifdef
= inifdef
;
3982 | A.DefineHeader
(definea
,ida
,params
), F.DefineHeader
((idb
, ii
), defkind
) ->
3983 let (defineb
, iidb
, ieol
) = tuple_of_list3 ii
in
3984 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
3985 tokenf definea defineb
>>= (fun definea defineb
->
3986 (match A.unwrap params
, defkind
with
3987 | A.NoParams
, B.DefineVar
->
3989 A.NoParams
+> A.rewrap params
,
3992 | A.DParams
(lpa
,eas,rpa
), (B.DefineFunc
(ebs
, ii
)) ->
3993 let (lpb
, rpb
) = tuple_of_list2 ii
in
3994 tokenf lpa lpb
>>= (fun lpa lpb
->
3995 tokenf rpa rpb
>>= (fun rpa rpb
->
3997 define_params
(seqstyle eas) (A.undots
eas) ebs
>>=
3998 (fun easundots ebs
->
3999 let eas = redots
eas easundots
in
4001 A.DParams
(lpa
,eas,rpa
) +> A.rewrap params
,
4002 B.DefineFunc
(ebs
,[lpb
;rpb
])
4006 ) >>= (fun params defkind
->
4008 A.DefineHeader
(definea
, ida
, params
),
4009 F.DefineHeader
((idb
,[defineb
;iidb
;ieol
]),defkind
)
4014 | A.Default
(def
,colon
), F.Default
(st
, ((),ii
)) ->
4015 let (ib1, ib2
) = tuple_of_list2 ii
in
4016 tokenf def
ib1 >>= (fun def
ib1 ->
4017 tokenf colon ib2
>>= (fun colon ib2
->
4019 A.Default
(def
,colon
),
4020 F.Default
(st
, ((),[ib1;ib2
]))
4025 | A.Case
(case
,ea
,colon
), F.Case
(st
, (eb
,ii
)) ->
4026 let (ib1, ib2
) = tuple_of_list2 ii
in
4027 tokenf case
ib1 >>= (fun case
ib1 ->
4028 expression ea eb
>>= (fun ea eb
->
4029 tokenf colon ib2
>>= (fun colon ib2
->
4031 A.Case
(case
,ea
,colon
),
4032 F.Case
(st
, (eb
,[ib1;ib2
]))
4035 (* only occurs in the predicates generated by asttomember *)
4036 | A.DisjRuleElem
eas, _
->
4038 List.fold_left
(fun acc ea
-> acc
>|+|> (rule_elem_node ea
node)) fail)
4039 >>= (fun ea eb
-> return (A.unwrap ea
,F.unwrap eb
))
4041 | _
, F.ExprStatement
(_
, (None
, ii
)) -> fail (* happen ? *)
4043 | A.Label
(id
,dd
), F.Label
(st
, nameb
, ((),ii
)) ->
4044 let (ib2
) = tuple_of_list1 ii
in
4045 ident_cpp DontKnow id nameb
>>= (fun ida nameb
->
4046 tokenf dd ib2
>>= (fun dd ib2
->
4049 F.Label
(st
,nameb
, ((),[ib2
]))
4052 | A.Goto
(goto
,id
,sem
), F.Goto
(st
,nameb
, ((),ii
)) ->
4053 let (ib1,ib3) = tuple_of_list2 ii
in
4054 tokenf goto
ib1 >>= (fun goto
ib1 ->
4055 ident_cpp DontKnow id nameb
>>= (fun id nameb
->
4056 tokenf sem
ib3 >>= (fun sem
ib3 ->
4058 A.Goto
(goto
,id
,sem
),
4059 F.Goto
(st
,nameb
, ((),[ib1;ib3]))
4062 (* have not a counter part in coccinelle, for the moment *)
4063 (* todo?: print a warning at least ? *)
4069 | _
, (F.IfdefEndif _
|F.IfdefElse _
|F.IfdefHeader _
)
4073 (F.MacroStmt
(_
, _
)| F.DefineDoWhileZeroHeader _
| F.EndNode
|F.TopNode
)
4076 (F.Label
(_
, _
, _
)|F.Break
(_
, _
)|F.Continue
(_
, _
)|F.Default
(_
, _
)|
4077 F.Case
(_
, _
)|F.Include _
|F.Goto _
|F.ExprStatement _
|
4078 F.DefineType _
|F.DefineExpr _
|F.DefineTodo
|
4079 F.DefineHeader
(_
, _
)|F.ReturnExpr
(_
, _
)|F.Return
(_
, _
)|F.MacroIterHeader
(_
, _
)|
4080 F.SwitchHeader
(_
, _
)|F.ForHeader
(_
, _
)|F.DoWhileTail _
|F.DoHeader
(_
, _
)|
4081 F.WhileHeader
(_
, _
)|F.Else _
|F.IfHeader
(_
, _
)|
4082 F.SeqEnd
(_
, _
)|F.SeqStart
(_
, _
, _
)|
4083 F.Decl _
|F.FunHeader _
)