2 * Copyright 2005-2010, Ecole des Mines de Nantes, University of Copenhagen
3 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
4 * This file is part of Coccinelle.
6 * Coccinelle is free software: you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation, according to version 2 of the License.
10 * Coccinelle is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
15 * You should have received a copy of the GNU General Public License
16 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
18 * The authors reserve the right to distribute this or future versions of
19 * Coccinelle under other licenses.
23 (* Yoann Padioleau, Julia Lawall
25 * Copyright (C) 2006, 2007, 2008 Ecole des Mines de Nantes
27 * This program is free software; you can redistribute it and/or
28 * modify it under the terms of the GNU General Public License (GPL)
29 * version 2 as published by the Free Software Foundation.
31 * This program is distributed in the hope that it will be useful,
32 * but WITHOUT ANY WARRANTY; without even the implied warranty of
33 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
34 * file license.txt for more details.
36 * This file was part of Coccinelle.
44 module F
= Control_flow_c
46 module Flag
= Flag_matcher
48 (*****************************************************************************)
50 (*****************************************************************************)
51 let pr2, pr2_once
= Common.mk_pr2_wrappers
Flag_matcher.verbose_matcher
53 (*****************************************************************************)
55 (*****************************************************************************)
57 type sequence
= Ordered
| Unordered
60 match A.unwrap eas
with
62 | A.CIRCLES _
-> Unordered
63 | A.STARS _
-> failwith
"not handling stars"
65 let (redots
: 'a
A.dots
-> 'a list
-> 'a
A.dots
)=fun eas easundots
->
67 match A.unwrap eas
with
68 | A.DOTS _
-> A.DOTS easundots
69 | A.CIRCLES _
-> A.CIRCLES easundots
70 | A.STARS _
-> A.STARS easundots
74 let (need_unordered_initialisers
: B.initialiser
B.wrap2 list
-> bool) =
76 ibs
+> List.exists
(fun (ib
, icomma
) ->
77 match B.unwrap ib
with
87 (* For the #include <linux/...> in the .cocci, need to find where is
88 * the '+' attached to this element, to later find the first concrete
89 * #include <linux/xxx.h> or last one in the serie of #includes in the
92 type include_requirement
=
99 (* todo? put in semantic_c.ml *)
102 | LocalFunction
(* entails Function *)
106 let term mc
= A.unwrap_mcode mc
107 let mcodekind mc
= A.get_mcodekind mc
110 let mcode_contain_plus = function
111 | A.CONTEXT
(_
,A.NOTHING
) -> false
112 | A.CONTEXT _
-> true
113 | A.MINUS
(_
,_
,_
,[]) -> false
114 | A.MINUS
(_
,_
,_
,x
::xs
) -> true
115 | A.PLUS _
-> raise Impossible
117 let mcode_simple_minus = function
118 | A.MINUS
(_
,_
,_
,[]) -> true
122 (* In transformation.ml sometime I build some mcodekind myself and
123 * julia has put None for the pos. But there is no possible raise
124 * NoMatch in those cases because it is for the minusall trick or for
125 * the distribute, so either have to build those pos, in fact a range,
126 * because for the distribute have to erase a fullType with one
127 * mcodekind, or add an argument to tag_with_mck such as "safe" that
128 * don't do the check_pos. Hence this DontCarePos constructor. *)
132 {A.line
= 0; A.column
=0; A.strbef
=[]; A.straft
=[];},
133 (A.MINUS
(A.DontCarePos
,[],-1,[])),
136 let generalize_mcode ia
=
137 let (s1
, i
, mck
, pos
) = ia
in
140 | A.PLUS _
-> raise Impossible
141 | A.CONTEXT
(A.NoPos
,x
) ->
142 A.CONTEXT
(A.DontCarePos
,x
)
143 | A.MINUS
(A.NoPos
,inst
,adj
,x
) ->
144 A.MINUS
(A.DontCarePos
,inst
,adj
,x
)
146 | A.CONTEXT
((A.FixPos _
|A.DontCarePos
), _
)
147 | A.MINUS
((A.FixPos _
|A.DontCarePos
), _
, _
, _
)
151 (s1
, i
, new_mck, pos
)
155 (*---------------------------------------------------------------------------*)
157 (* 0x0 is equivalent to 0, value format isomorphism *)
158 let equal_c_int s1 s2
=
160 int_of_string s1
=|= int_of_string s2
161 with Failure
("int_of_string") ->
166 (*---------------------------------------------------------------------------*)
167 (* Normally A should reuse some types of Ast_c, so those
168 * functions should not exist.
170 * update: but now Ast_c depends on A, so can't make too
171 * A depends on Ast_c, so have to stay with those equal_xxx
175 let equal_unaryOp a b
=
177 | A.GetRef
, B.GetRef
-> true
178 | A.DeRef
, B.DeRef
-> true
179 | A.UnPlus
, B.UnPlus
-> true
180 | A.UnMinus
, B.UnMinus
-> true
181 | A.Tilde
, B.Tilde
-> true
182 | A.Not
, B.Not
-> true
183 | _
, B.GetRefLabel
-> false (* todo cocci? *)
184 | _
, (B.Not
|B.Tilde
|B.UnMinus
|B.UnPlus
|B.DeRef
|B.GetRef
) -> false
188 let equal_arithOp a b
=
190 | A.Plus
, B.Plus
-> true
191 | A.Minus
, B.Minus
-> true
192 | A.Mul
, B.Mul
-> true
193 | A.Div
, B.Div
-> true
194 | A.Mod
, B.Mod
-> true
195 | A.DecLeft
, B.DecLeft
-> true
196 | A.DecRight
, B.DecRight
-> true
197 | A.And
, B.And
-> true
198 | A.Or
, B.Or
-> true
199 | A.Xor
, B.Xor
-> true
200 | _
, (B.Xor
|B.Or
|B.And
|B.DecRight
|B.DecLeft
|B.Mod
|B.Div
|B.Mul
|B.Minus
|B.Plus
)
203 let equal_logicalOp a b
=
205 | A.Inf
, B.Inf
-> true
206 | A.Sup
, B.Sup
-> true
207 | A.InfEq
, B.InfEq
-> true
208 | A.SupEq
, B.SupEq
-> true
209 | A.Eq
, B.Eq
-> true
210 | A.NotEq
, B.NotEq
-> true
211 | A.AndLog
, B.AndLog
-> true
212 | A.OrLog
, B.OrLog
-> true
213 | _
, (B.OrLog
|B.AndLog
|B.NotEq
|B.Eq
|B.SupEq
|B.InfEq
|B.Sup
|B.Inf
)
216 let equal_assignOp a b
=
218 | A.SimpleAssign
, B.SimpleAssign
-> true
219 | A.OpAssign a
, B.OpAssign b
-> equal_arithOp a b
220 | _
, (B.OpAssign _
|B.SimpleAssign
) -> false
222 let equal_fixOp a b
=
224 | A.Dec
, B.Dec
-> true
225 | A.Inc
, B.Inc
-> true
226 | _
, (B.Inc
|B.Dec
) -> false
228 let equal_binaryOp a b
=
230 | A.Arith a
, B.Arith b
-> equal_arithOp a b
231 | A.Logical a
, B.Logical b
-> equal_logicalOp a b
232 | _
, (B.Logical _
| B.Arith _
) -> false
234 let equal_structUnion a b
=
236 | A.Struct
, B.Struct
-> true
237 | A.Union
, B.Union
-> true
238 | _
, (B.Struct
|B.Union
) -> false
242 | A.Signed
, B.Signed
-> true
243 | A.Unsigned
, B.UnSigned
-> true
244 | _
, (B.UnSigned
|B.Signed
) -> false
246 let equal_storage a b
=
248 | A.Static
, B.Sto
B.Static
249 | A.Auto
, B.Sto
B.Auto
250 | A.Register
, B.Sto
B.Register
251 | A.Extern
, B.Sto
B.Extern
253 | _
, (B.NoSto
| B.StoTypedef
) -> false
254 | _
, (B.Sto
(B.Register
|B.Static
|B.Auto
|B.Extern
)) -> false
257 (*---------------------------------------------------------------------------*)
259 let equal_metavarval valu valu'
=
260 match valu
, valu'
with
261 | Ast_c.MetaIdVal a
, Ast_c.MetaIdVal b
-> a
=$
= b
262 | Ast_c.MetaFuncVal a
, Ast_c.MetaFuncVal b
-> a
=$
= b
263 | Ast_c.MetaLocalFuncVal a
, Ast_c.MetaLocalFuncVal b
->
264 (* do something more ? *)
267 (* al_expr before comparing !!! and accept when they match.
268 * Note that here we have Astc._expression, so it is a match
269 * modulo isomorphism (there is no metavariable involved here,
270 * just isomorphisms). => TODO call isomorphism_c_c instead of
271 * =*=. Maybe would be easier to transform ast_c in ast_cocci
272 * and call the iso engine of julia. *)
273 | Ast_c.MetaExprVal a
, Ast_c.MetaExprVal b
->
274 Lib_parsing_c.al_expr a
=*= Lib_parsing_c.al_expr b
275 | Ast_c.MetaExprListVal a
, Ast_c.MetaExprListVal b
->
276 Lib_parsing_c.al_arguments a
=*= Lib_parsing_c.al_arguments b
278 | Ast_c.MetaStmtVal a
, Ast_c.MetaStmtVal b
->
279 Lib_parsing_c.al_statement a
=*= Lib_parsing_c.al_statement b
280 | Ast_c.MetaInitVal a
, Ast_c.MetaInitVal b
->
281 Lib_parsing_c.al_init a
=*= Lib_parsing_c.al_init b
282 | Ast_c.MetaTypeVal a
, Ast_c.MetaTypeVal b
->
283 (* old: Lib_parsing_c.al_type a =*= Lib_parsing_c.al_type b *)
286 | Ast_c.MetaListlenVal a
, Ast_c.MetaListlenVal b
-> a
=|= b
288 | Ast_c.MetaParamVal a
, Ast_c.MetaParamVal b
->
289 Lib_parsing_c.al_param a
=*= Lib_parsing_c.al_param b
290 | Ast_c.MetaParamListVal a
, Ast_c.MetaParamListVal b
->
291 Lib_parsing_c.al_params a
=*= Lib_parsing_c.al_params b
293 | Ast_c.MetaPosVal
(posa1
,posa2
), Ast_c.MetaPosVal
(posb1
,posb2
) ->
294 Ast_cocci.equal_pos posa1 posb1
&& Ast_cocci.equal_pos posa2 posb2
296 | Ast_c.MetaPosValList l1
, Ast_c.MetaPosValList l2
->
298 (function (fla
,cea
,posa1
,posa2
) ->
300 (function (flb
,ceb
,posb1
,posb2
) ->
301 fla
=$
= flb
&& cea
=$
= ceb
&&
302 Ast_c.equal_posl posa1 posb1
&& Ast_c.equal_posl posa2 posb2
)
306 | (B.MetaPosValList _
|B.MetaListlenVal _
|B.MetaPosVal _
|B.MetaStmtVal _
307 |B.MetaTypeVal _
|B.MetaInitVal _
308 |B.MetaParamListVal _
|B.MetaParamVal _
|B.MetaExprListVal _
309 |B.MetaExprVal _
|B.MetaLocalFuncVal _
|B.MetaFuncVal _
|B.MetaIdVal _
313 (* probably only one argument needs to be stripped, because inherited
314 metavariables containing expressions are stripped in advance. But don't
315 know which one is which... *)
316 let equal_inh_metavarval valu valu'
=
317 match valu
, valu'
with
318 | Ast_c.MetaIdVal a
, Ast_c.MetaIdVal b
-> a
=$
= b
319 | Ast_c.MetaFuncVal a
, Ast_c.MetaFuncVal b
-> a
=$
= b
320 | Ast_c.MetaLocalFuncVal a
, Ast_c.MetaLocalFuncVal b
->
321 (* do something more ? *)
324 (* al_expr before comparing !!! and accept when they match.
325 * Note that here we have Astc._expression, so it is a match
326 * modulo isomorphism (there is no metavariable involved here,
327 * just isomorphisms). => TODO call isomorphism_c_c instead of
328 * =*=. Maybe would be easier to transform ast_c in ast_cocci
329 * and call the iso engine of julia. *)
330 | Ast_c.MetaExprVal a
, Ast_c.MetaExprVal b
->
331 Lib_parsing_c.al_inh_expr a
=*= Lib_parsing_c.al_inh_expr b
332 | Ast_c.MetaExprListVal a
, Ast_c.MetaExprListVal b
->
333 Lib_parsing_c.al_inh_arguments a
=*= Lib_parsing_c.al_inh_arguments b
335 | Ast_c.MetaStmtVal a
, Ast_c.MetaStmtVal b
->
336 Lib_parsing_c.al_inh_statement a
=*= Lib_parsing_c.al_inh_statement b
337 | Ast_c.MetaInitVal a
, Ast_c.MetaInitVal b
->
338 Lib_parsing_c.al_inh_init a
=*= Lib_parsing_c.al_inh_init b
339 | Ast_c.MetaTypeVal a
, Ast_c.MetaTypeVal b
->
340 (* old: Lib_parsing_c.al_inh_type a =*= Lib_parsing_c.al_inh_type b *)
343 | Ast_c.MetaListlenVal a
, Ast_c.MetaListlenVal b
-> a
=|= b
345 | Ast_c.MetaParamVal a
, Ast_c.MetaParamVal b
->
346 Lib_parsing_c.al_param a
=*= Lib_parsing_c.al_param b
347 | Ast_c.MetaParamListVal a
, Ast_c.MetaParamListVal b
->
348 Lib_parsing_c.al_params a
=*= Lib_parsing_c.al_params b
350 | Ast_c.MetaPosVal
(posa1
,posa2
), Ast_c.MetaPosVal
(posb1
,posb2
) ->
351 Ast_cocci.equal_pos posa1 posb1
&& Ast_cocci.equal_pos posa2 posb2
353 | Ast_c.MetaPosValList l1
, Ast_c.MetaPosValList l2
->
355 (function (fla
,cea
,posa1
,posa2
) ->
357 (function (flb
,ceb
,posb1
,posb2
) ->
358 fla
=$
= flb
&& cea
=$
= ceb
&&
359 Ast_c.equal_posl posa1 posb1
&& Ast_c.equal_posl posa2 posb2
)
363 | (B.MetaPosValList _
|B.MetaListlenVal _
|B.MetaPosVal _
|B.MetaStmtVal _
364 |B.MetaTypeVal _
|B.MetaInitVal _
365 |B.MetaParamListVal _
|B.MetaParamVal _
|B.MetaExprListVal _
366 |B.MetaExprVal _
|B.MetaLocalFuncVal _
|B.MetaFuncVal _
|B.MetaIdVal _
371 (*---------------------------------------------------------------------------*)
372 (* could put in ast_c.ml, next to the split/unsplit_comma *)
373 let split_signb_baseb_ii (baseb
, ii
) =
374 let iis = ii
+> List.map
(fun info
-> (B.str_of_info info
), info
) in
375 match baseb
, iis with
377 | B.Void
, ["void",i1
] -> None
, [i1
]
379 | B.FloatType
(B.CFloat
),["float",i1
] -> None
, [i1
]
380 | B.FloatType
(B.CDouble
),["double",i1
] -> None
, [i1
]
381 | B.FloatType
(B.CLongDouble
),["long",i1
;"double",i2
] -> None
,[i1
;i2
]
383 | B.IntType
(B.CChar
), ["char",i1
] -> None
, [i1
]
386 | B.IntType
(B.Si
(sign
, base
)), xs
->
390 | (B.Signed
,(("signed",i1
)::rest
)) -> (Some
(B.Signed
,i1
),rest
)
391 | (B.Signed
,rest
) -> (None
,rest
)
392 | (B.UnSigned
,(("unsigned",i1
)::rest
)) -> (Some
(B.UnSigned
,i1
),rest
)
393 | (B.UnSigned
,rest
) -> (* is this case possible? *) (None
,rest
) in
394 (* The original code only allowed explicit signed and unsigned for char,
395 while this code allows char by itself. Not sure that needs to be
396 checked for here. If it does, then add a special case. *)
398 match (base
,rest
) with
399 B.CInt
, ["int",i1
] -> [i1
]
402 | B.CInt
, ["",i1
] -> (* no type is specified at all *)
403 (match i1
.B.pinfo
with
405 | _
-> failwith
("unrecognized signed int: "^
406 (String.concat
" "(List.map fst
iis))))
408 | B.CChar2
, ["char",i2
] -> [i2
]
410 | B.CShort
, ["short",i1
] -> [i1
]
411 | B.CShort
, ["short",i1
;"int",i2
] -> [i1
;i2
]
413 | B.CLong
, ["long",i1
] -> [i1
]
414 | B.CLong
, ["long",i1
;"int",i2
] -> [i1
;i2
]
416 | B.CLongLong
, ["long",i1
;"long",i2
] -> [i1
;i2
]
417 | B.CLongLong
, ["long",i1
;"long",i2
;"int",i3
] -> [i1
;i2
;i3
]
420 failwith
("strange type1, maybe because of weird order: "^
421 (String.concat
" " (List.map fst
iis))) in
423 | _
-> failwith
("strange type2, maybe because of weird order: "^
424 (String.concat
" " (List.map fst
iis)))
426 (*---------------------------------------------------------------------------*)
428 let rec unsplit_icomma xs
=
432 (match A.unwrap y
with
434 (x
, y
)::unsplit_icomma xs
435 | _
-> failwith
"wrong ast_cocci in initializer"
438 failwith
("wrong ast_cocci in initializer, should have pair " ^
443 let resplit_initialiser ibs iicomma
=
444 match iicomma
, ibs
with
447 failwith
"should have a iicomma, do you generate fakeInfo in parser?"
449 failwith
"shouldn't have a iicomma"
450 | [iicomma
], x
::xs
->
451 let elems = List.map fst
(x
::xs
) in
452 let commas = List.map snd
(x
::xs
) +> List.flatten
in
453 let commas = commas @ [iicomma
] in
455 | _
-> raise Impossible
459 let rec split_icomma xs
=
462 | (x
,y
)::xs
-> x
::y
::split_icomma xs
464 let rec unsplit_initialiser ibs_unsplit
=
465 match ibs_unsplit
with
466 | [] -> [], [] (* empty iicomma *)
468 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
469 (x
, [])::xs
, lastcomma
471 and unsplit_initialiser_bis comma_before
= function
472 | [] -> [], [comma_before
]
474 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
475 (x
, [comma_before
])::xs
, lastcomma
480 (*---------------------------------------------------------------------------*)
481 (* coupling: same in type_annotater_c.ml *)
482 let structdef_to_struct_name ty
=
484 | qu
, (B.StructUnion
(su
, sopt
, fields
), iis) ->
486 | Some s
, [i1
;i2
;i3
;i4
] ->
487 qu
, (B.StructUnionName
(su
, s
), [i1
;i2
])
491 | x
-> raise Impossible
493 | _
-> raise Impossible
495 (*---------------------------------------------------------------------------*)
496 let initialisation_to_affectation decl
=
498 | B.MacroDecl _
-> F.Decl decl
499 | B.DeclList
(xs
, iis) ->
501 (* todo?: should not do that if the variable is an array cos
502 * will have x[] = , mais de toute facon ca sera pas un InitExp
505 | [] -> raise Impossible
507 let ({B.v_namei
= var
;
508 B.v_type
= returnType
;
509 B.v_type_bis
= tybis
;
510 B.v_storage
= storage
;
517 | Some
(name
, iniopt
) ->
519 | Some
(iini
, (B.InitExpr e
, ii_empty2
)) ->
523 Ast_c.NotLocalDecl
-> Ast_c.NotLocalVar
525 Ast_c.LocalVar
(Ast_c.info_of_type returnType
) in
528 (* old: Lib_parsing_c.al_type returnType
529 * but this type has not the typename completed so
530 * instead try to use tybis
533 | Some ty_with_typename_completed
->
534 ty_with_typename_completed
535 | None
-> raise Impossible
539 ref (Some
(typexp,local),
543 Ast_c.mk_e_bis
(B.Ident
(ident)) typ Ast_c.noii
547 (B.Assignment
(idexpr,B.SimpleAssign
, e
)) [iini
] in
555 pr2_once
"TODO: initialisation_to_affectation for multi vars";
556 (* todo? do a fold_left and generate 'x = a, y = b' etc, use
557 * the Sequence expression operator of C and make an
558 * ExprStatement from that.
567 (*****************************************************************************)
568 (* Functor parameter combinators *)
569 (*****************************************************************************)
571 * src: papers on parser combinators in haskell (cf a pearl by meijer in ICFP)
573 * version0: was not tagging the SP, so just tag the C
575 * (tin -> 'c tout) -> ('c -> (tin -> 'b tout)) -> (tin -> 'b tout)
576 * val return : 'b -> tin -> 'b tout
577 * val fail : tin -> 'b tout
579 * version1: now also tag the SP so return a ('a * 'b)
582 type mode
= PatternMode
| TransformMode
590 type ('a
, 'b
) matcher
= 'a
-> 'b
-> tin
-> ('a
* 'b
) tout
595 (tin
-> ('a
* 'b
) tout
) ->
596 ('a
-> 'b
-> (tin
-> ('c
* 'd
) tout
)) ->
597 (tin
-> ('c
* 'd
) tout
)
599 val return
: ('a
* 'b
) -> tin
-> ('a
*'b
) tout
600 val fail
: tin
-> ('a
* 'b
) tout
612 val (>&&>) : (tin
-> bool) -> (tin
-> 'x tout
) -> (tin
-> 'x tout
)
614 val tokenf
: ('a
A.mcode
, B.info
) matcher
615 val tokenf_mck
: (A.mcodekind, B.info
) matcher
618 (A.meta_name
A.mcode
, B.expression
) matcher
620 (A.meta_name
A.mcode
, (Ast_c.argument
, Ast_c.il
) either list
) matcher
622 (A.meta_name
A.mcode
, Ast_c.fullType
) matcher
624 (A.meta_name
A.mcode
,
625 (Ast_c.parameterType
, Ast_c.il
) either list
) matcher
627 (A.meta_name
A.mcode
, Ast_c.parameterType
) matcher
629 (A.meta_name
A.mcode
, Ast_c.initialiser
) matcher
631 (A.meta_name
A.mcode
, Control_flow_c.node
) matcher
633 val distrf_define_params
:
634 (A.meta_name
A.mcode
, (string Ast_c.wrap
, Ast_c.il
) either list
)
637 val distrf_struct_fields
:
638 (A.meta_name
A.mcode
, B.field list
) matcher
641 (A.meta_name
A.mcode
, (B.constant
, string) either
B.wrap
) matcher
644 (A.expression
, B.expression
) matcher
-> (A.expression
, F.node
) matcher
647 (A.expression
, B.expression
) matcher
->
648 (A.expression
, B.expression
) matcher
651 (A.fullType
, B.fullType
) matcher
-> (A.fullType
, F.node
) matcher
654 (A.initialiser
, B.initialiser
) matcher
-> (A.initialiser
, F.node
) matcher
657 A.keep_binding
-> A.inherited
->
658 A.meta_name
A.mcode
* Ast_c.metavar_binding_kind
*
659 (unit -> Common.filename
* string * Ast_c.posl
* Ast_c.posl
) ->
660 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
662 val check_idconstraint
:
663 ('a
-> 'b
-> bool) -> 'a
-> 'b
->
664 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
666 val check_constraints_ne
:
667 ('a
, 'b
) matcher
-> 'a list
-> 'b
->
668 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
670 val all_bound
: A.meta_name list
-> (tin
-> bool)
672 val optional_storage_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
673 val optional_qualifier_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
674 val value_format_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
679 (*****************************************************************************)
680 (* Functor code, "Cocci vs C" *)
681 (*****************************************************************************)
684 functor (X
: PARAM
) ->
687 type ('a
, 'b
) matcher
= 'a
-> 'b
-> X.tin
-> ('a
* 'b
) X.tout
690 let return = X.return
693 let (>||>) = X.(>||>)
694 let (>|+|>) = X.(>|+|>)
695 let (>&&>) = X.(>&&>)
697 let tokenf = X.tokenf
699 (* should be raise Impossible when called from transformation.ml *)
702 | PatternMode
-> fail
703 | TransformMode
-> raise Impossible
706 let (option: ('a
,'b
) matcher
-> ('a
option,'b
option) matcher
)= fun f t1 t2
->
708 | (Some t1
, Some t2
) ->
709 f t1 t2
>>= (fun t1 t2
->
710 return (Some t1
, Some t2
)
712 | (None
, None
) -> return (None
, None
)
715 (* Dots are sometimes used as metavariables, since like metavariables they
716 can match other things. But they no longer have the same type. Perhaps these
717 functions could be avoided by introducing an appropriate level of polymorphism,
718 but I don't know how to declare polymorphism across functors *)
719 let dots2metavar (_
,info
,mcodekind,pos
) =
720 (("","..."),info
,mcodekind,pos
)
721 let metavar2dots (_
,info
,mcodekind,pos
) = ("...",info
,mcodekind,pos
)
723 let satisfies_iconstraint c id
: bool =
725 A.IdNoConstraint
-> true
726 | A.IdNegIdSet l
-> not
(List.mem id l
)
727 | A.IdRegExp
(_
,recompiled
) ->
728 if Str.string_match recompiled id
0 then
732 | A.IdNotRegExp
(_
,recompiled
) ->
733 if Str.string_match recompiled id
0 then
738 let satisfies_econstraint c exp
: bool =
739 match Ast_c.unwrap_expr exp
with
740 Ast_c.Ident
(name
) ->
743 Ast_c.RegularName rname
-> satisfies_iconstraint c
(Ast_c.unwrap_st rname
)
744 | Ast_c.CppConcatenatedName _
->
745 pr2_once
("WARNING: Unable to apply a constraint on a CppConcatenatedName identifier !"); true
746 | Ast_c.CppVariadicName _
->
747 pr2_once
("WARNING: Unable to apply a constraint on a CppVariadicName identifier !"); true
748 | Ast_c.CppIdentBuilder _
->
749 pr2_once
("WARNING: Unable to apply a constraint on a CppIdentBuilder identifier !"); true
751 | Ast_c.Constant cst
->
753 | Ast_c.String
(str
, _
) -> satisfies_iconstraint c str
754 | Ast_c.MultiString strlist
->
755 pr2_once
("WARNING: Unable to apply a constraint on an multistring constant !"); true
756 | Ast_c.Char
(char
, _
) -> satisfies_iconstraint c char
757 | Ast_c.Int
(int , _
) -> satisfies_iconstraint c
int
758 | Ast_c.Float
(float, _
) -> satisfies_iconstraint c
float
760 | _
-> pr2_once
("WARNING: Unable to apply a constraint on an expression !"); true
762 (*---------------------------------------------------------------------------*)
774 (*---------------------------------------------------------------------------*)
775 let rec (expression
: (A.expression
, Ast_c.expression
) matcher
) =
777 if A.get_test_exp ea
&& not
(Ast_c.is_test eb
) then fail
779 X.all_bound
(A.get_inherited ea
) >&&>
780 let wa x
= A.rewrap ea x
in
781 match A.unwrap ea
, eb
with
783 (* general case: a MetaExpr can match everything *)
784 | A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
),
785 (((expr
, opttypb
), ii
) as expb
) ->
787 (* old: before have a MetaConst. Now we factorize and use 'form' to
788 * differentiate between different cases *)
789 let rec matches_id = function
790 B.Ident
(name
) -> true
791 | B.Cast
(ty
,e
) -> matches_id (B.unwrap_expr e
)
794 match (form
,expr
) with
797 let rec matches = function
798 B.Constant
(c
) -> true
799 | B.Ident
(nameidb
) ->
800 let s = Ast_c.str_of_name nameidb
in
801 if s =~
"^[A-Z_][A-Z_0-9]*$"
803 pr2_once
("warning: " ^
s ^
" treated as a constant");
807 | B.Cast
(ty
,e
) -> matches (B.unwrap_expr e
)
808 | B.Unary
(e
,B.UnMinus
) -> matches (B.unwrap_expr e
)
809 | B.SizeOfExpr
(exp
) -> true
810 | B.SizeOfType
(ty
) -> true
816 (Some
(_
,Ast_c.LocalVar _
),_
) -> true
818 | (A.ID
,e
) -> matches_id e
in
822 (let (opttypb
,_testb
) = !opttypb
in
823 match opttypa
, opttypb
with
824 | None
, _
-> return ((),())
826 pr2_once
("Missing type information. Certainly a pb in " ^
827 "annotate_typer.ml");
830 | Some tas
, Some tb
->
831 tas
+> List.fold_left
(fun acc ta
->
832 acc
>|+|> compatible_type ta tb
) fail
835 match constraints
with
836 Ast_cocci.NoConstraint
->
838 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_expr expb
) in
839 X.envf keep inherited
(ida
, Ast_c.MetaExprVal expb
, max_min)
841 X.distrf_e ida expb
>>=
844 A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
)+>
850 | Ast_cocci.NotIdCstrt cstrt
->
851 X.check_idconstraint
satisfies_econstraint cstrt eb
854 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_expr expb
) in
855 X.envf keep inherited
(ida
, Ast_c.MetaExprVal expb
, max_min)
857 X.distrf_e ida expb
>>=
860 A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
)+>
866 | Ast_cocci.NotExpCstrt cstrts
->
867 X.check_constraints_ne expression cstrts eb
870 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_expr expb
) in
871 X.envf keep inherited
(ida
, Ast_c.MetaExprVal expb
, max_min)
873 X.distrf_e ida expb
>>=
876 A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
)+>
884 * | A.MetaExpr(ida,false,opttypa,_inherited), expb ->
885 * D.distribute_mck (mcodekind ida) D.distribute_mck_e expb binding
887 * but bug! because if have not tagged SP, then transform without doing
888 * any checks. Hopefully now have tagged SP technique.
893 * | A.Edots _, _ -> raise Impossible.
895 * In fact now can also have the Edots inside normal expression, not
896 * just in arg lists. in 'x[...];' less: in if(<... x ... y ...>)
898 | A.Edots
(mcode
, None
), expb
->
899 X.distrf_e
(dots2metavar mcode
) expb
>>= (fun mcode expb
->
901 A.Edots
(metavar2dots mcode
, None
) +> A.rewrap ea
,
906 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
909 | A.Ident ida
, ((B.Ident
(nameidb
), typ),noii
) ->
911 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
913 ((A.Ident ida
)) +> wa,
914 ((B.Ident
(nameidb
), typ),Ast_c.noii
)
920 | A.MetaErr _
, _
-> failwith
"not handling MetaErr"
922 (* todo?: handle some isomorphisms in int/float ? can have different
923 * format : 1l can match a 1.
925 * todo: normally string can contain some metavar too, so should
926 * recurse on the string
928 | A.Constant
(ia1
), ((B.Constant
(ib
) , typ),ii
) ->
929 (* for everything except the String case where can have multi elems *)
931 let ib1 = tuple_of_list1 ii
in
932 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
934 ((A.Constant ia1
)) +> wa,
935 ((B.Constant
(ib
), typ),[ib1])
938 (match term ia1
, ib
with
939 | A.Int x
, B.Int
(y
,_
) ->
940 X.value_format_flag
(fun use_value_equivalence
->
941 if use_value_equivalence
951 | A.Char x
, B.Char
(y
,_
) when x
=$
= y
(* todo: use kind ? *)
953 | A.Float x
, B.Float
(y
,_
) when x
=$
= y
(* todo: use floatType ? *)
956 | A.String sa
, B.String
(sb
,_kind
) when sa
=$
= sb
->
959 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
961 ((A.Constant ia1
)) +> wa,
962 ((B.Constant
(ib
), typ),[ib1])
964 | _
-> fail (* multi string, not handled *)
967 | _
, B.MultiString _
-> (* todo cocci? *) fail
968 | _
, (B.String _
| B.Float _
| B.Char _
| B.Int _
) -> fail
972 | A.FunCall
(ea
, ia1
, eas
, ia2
), ((B.FunCall
(eb
, ebs
), typ),ii
) ->
973 (* todo: do special case to allow IdMetaFunc, cos doing the
974 * recursive call will be too late, match_ident will not have the
975 * info whether it was a function. todo: but how detect when do
976 * x.field = f; how know that f is a Func ? By having computed
977 * some information before the matching!
979 * Allow match with FunCall containing types. Now ast_cocci allow
980 * type in parameter, and morover ast_cocci allow f(...) and those
981 * ... could match type.
983 let (ib1, ib2
) = tuple_of_list2 ii
in
984 expression ea eb
>>= (fun ea eb
->
985 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
986 tokenf ia2 ib2
>>= (fun ia2 ib2
->
987 arguments
(seqstyle eas
) (A.undots eas
) ebs
>>= (fun easundots ebs
->
988 let eas = redots
eas easundots
in
990 ((A.FunCall
(ea
, ia1
, eas, ia2
)) +> wa,
991 ((B.FunCall
(eb
, ebs
),typ), [ib1;ib2
])
997 | A.Assignment
(ea1
, opa
, ea2
, simple
),
998 ((B.Assignment
(eb1
, opb
, eb2
), typ),ii
) ->
999 let (opbi
) = tuple_of_list1 ii
in
1000 if equal_assignOp (term opa
) opb
1002 expression ea1 eb1
>>= (fun ea1 eb1
->
1003 expression ea2 eb2
>>= (fun ea2 eb2
->
1004 tokenf opa opbi
>>= (fun opa opbi
->
1006 ((A.Assignment
(ea1
, opa
, ea2
, simple
))) +> wa,
1007 ((B.Assignment
(eb1
, opb
, eb2
), typ), [opbi
])
1011 | A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
),((B.CondExpr
(eb1
,eb2opt
,eb3
),typ),ii
) ->
1012 let (ib1, ib2
) = tuple_of_list2 ii
in
1013 expression ea1 eb1
>>= (fun ea1 eb1
->
1014 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
1015 expression ea3 eb3
>>= (fun ea3 eb3
->
1016 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1017 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1019 ((A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
))) +> wa,
1020 ((B.CondExpr
(eb1
, eb2opt
, eb3
),typ), [ib1;ib2
])
1023 (* todo?: handle some isomorphisms here ? *)
1024 | A.Postfix
(ea
, opa
), ((B.Postfix
(eb
, opb
), typ),ii
) ->
1025 let opbi = tuple_of_list1 ii
in
1026 if equal_fixOp (term opa
) opb
1028 expression ea eb
>>= (fun ea eb
->
1029 tokenf opa
opbi >>= (fun opa
opbi ->
1031 ((A.Postfix
(ea
, opa
))) +> wa,
1032 ((B.Postfix
(eb
, opb
), typ),[opbi])
1037 | A.Infix
(ea
, opa
), ((B.Infix
(eb
, opb
), typ),ii
) ->
1038 let opbi = tuple_of_list1 ii
in
1039 if equal_fixOp (term opa
) opb
1041 expression ea eb
>>= (fun ea eb
->
1042 tokenf opa
opbi >>= (fun opa
opbi ->
1044 ((A.Infix
(ea
, opa
))) +> wa,
1045 ((B.Infix
(eb
, opb
), typ),[opbi])
1049 | A.Unary
(ea
, opa
), ((B.Unary
(eb
, opb
), typ),ii
) ->
1050 let opbi = tuple_of_list1 ii
in
1051 if equal_unaryOp (term opa
) opb
1053 expression ea eb
>>= (fun ea eb
->
1054 tokenf opa
opbi >>= (fun opa
opbi ->
1056 ((A.Unary
(ea
, opa
))) +> wa,
1057 ((B.Unary
(eb
, opb
), typ),[opbi])
1061 | A.Binary
(ea1
, opa
, ea2
), ((B.Binary
(eb1
, opb
, eb2
), typ),ii
) ->
1062 let opbi = tuple_of_list1 ii
in
1063 if equal_binaryOp (term opa
) opb
1065 expression ea1 eb1
>>= (fun ea1 eb1
->
1066 expression ea2 eb2
>>= (fun ea2 eb2
->
1067 tokenf opa
opbi >>= (fun opa
opbi ->
1069 ((A.Binary
(ea1
, opa
, ea2
))) +> wa,
1070 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1074 | A.Nested
(ea1
, opa
, ea2
), eb
->
1076 expression ea1 eb
>|+|>
1078 ((B.Binary
(eb1
, opb
, eb2
), typ),ii
)
1079 when equal_binaryOp (term opa
) opb
->
1080 let opbi = tuple_of_list1 ii
in
1082 (expression ea1 eb1
>>= (fun ea1 eb1
->
1083 expression ea2 eb2
>>= (fun ea2 eb2
->
1084 tokenf opa
opbi >>= (fun opa
opbi ->
1086 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1087 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1090 (expression ea2 eb1
>>= (fun ea2 eb1
->
1091 expression ea1 eb2
>>= (fun ea1 eb2
->
1092 tokenf opa
opbi >>= (fun opa
opbi ->
1094 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1095 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1098 (loop eb1
>>= (fun ea1 eb1
->
1099 expression ea2 eb2
>>= (fun ea2 eb2
->
1100 tokenf opa
opbi >>= (fun opa
opbi ->
1102 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1103 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1106 (expression ea2 eb1
>>= (fun ea2 eb1
->
1107 loop eb2
>>= (fun ea1 eb2
->
1108 tokenf opa
opbi >>= (fun opa
opbi ->
1110 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1111 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1113 left_to_right >|+|> right_to_left >|+|> in_left >|+|> in_right
1117 (* todo?: handle some isomorphisms here ? (with pointers = Unary Deref) *)
1118 | A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
),((B.ArrayAccess
(eb1
, eb2
), typ),ii
) ->
1119 let (ib1, ib2
) = tuple_of_list2 ii
in
1120 expression ea1 eb1
>>= (fun ea1 eb1
->
1121 expression ea2 eb2
>>= (fun ea2 eb2
->
1122 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1123 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1125 ((A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
))) +> wa,
1126 ((B.ArrayAccess
(eb1
, eb2
),typ), [ib1;ib2
])
1129 (* todo?: handle some isomorphisms here ? *)
1130 | A.RecordAccess
(ea
, ia1
, ida
), ((B.RecordAccess
(eb
, idb
), typ),ii
) ->
1131 let (ib1) = tuple_of_list1 ii
in
1132 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
1133 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1134 expression ea eb
>>= (fun ea eb
->
1136 ((A.RecordAccess
(ea
, ia1
, ida
))) +> wa,
1137 ((B.RecordAccess
(eb
, idb
), typ), [ib1])
1142 | A.RecordPtAccess
(ea
,ia1
,ida
),((B.RecordPtAccess
(eb
, idb
), typ), ii
) ->
1143 let (ib1) = tuple_of_list1 ii
in
1144 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
1145 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1146 expression ea eb
>>= (fun ea eb
->
1148 ((A.RecordPtAccess
(ea
, ia1
, ida
))) +> wa,
1149 ((B.RecordPtAccess
(eb
, idb
), typ), [ib1])
1153 (* todo?: handle some isomorphisms here ?
1154 * todo?: do some iso-by-absence on cast ?
1155 * by trying | ea, B.Case (typb, eb) -> match_e_e ea eb ?
1158 | A.Cast
(ia1
, typa
, ia2
, ea
), ((B.Cast
(typb
, eb
), typ),ii
) ->
1159 let (ib1, ib2
) = tuple_of_list2 ii
in
1160 fullType typa typb
>>= (fun typa typb
->
1161 expression ea eb
>>= (fun ea eb
->
1162 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1163 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1165 ((A.Cast
(ia1
, typa
, ia2
, ea
))) +> wa,
1166 ((B.Cast
(typb
, eb
),typ),[ib1;ib2
])
1169 | A.SizeOfExpr
(ia1
, ea
), ((B.SizeOfExpr
(eb
), typ),ii
) ->
1170 let ib1 = tuple_of_list1 ii
in
1171 expression ea eb
>>= (fun ea eb
->
1172 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1174 ((A.SizeOfExpr
(ia1
, ea
))) +> wa,
1175 ((B.SizeOfExpr
(eb
), typ),[ib1])
1178 | A.SizeOfType
(ia1
, ia2
, typa
, ia3
), ((B.SizeOfType typb
, typ),ii
) ->
1179 let (ib1,ib2
,ib3
) = tuple_of_list3 ii
in
1180 fullType typa typb
>>= (fun typa typb
->
1181 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1182 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1183 tokenf ia3 ib3
>>= (fun ia3 ib3
->
1185 ((A.SizeOfType
(ia1
, ia2
, typa
, ia3
))) +> wa,
1186 ((B.SizeOfType
(typb
),typ),[ib1;ib2
;ib3
])
1190 (* todo? iso ? allow all the combinations ? *)
1191 | A.Paren
(ia1
, ea
, ia2
), ((B.ParenExpr
(eb
), typ),ii
) ->
1192 let (ib1, ib2
) = tuple_of_list2 ii
in
1193 expression ea eb
>>= (fun ea eb
->
1194 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1195 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1197 ((A.Paren
(ia1
, ea
, ia2
))) +> wa,
1198 ((B.ParenExpr
(eb
), typ), [ib1;ib2
])
1201 | A.NestExpr
(exps
,None
,true), eb
->
1202 (match A.unwrap exps
with
1204 X.cocciExpExp expression exp eb
>>= (fun exp eb
->
1206 (A.NestExpr
(A.rewrap exps
(A.DOTS
[exp
]),None
,true)) +> wa,
1212 "for nestexpr, only handling the case with dots and only one exp")
1214 | A.NestExpr _
, _
->
1215 failwith
"only handling multi and no when code in a nest expr"
1217 (* only in arg lists or in define body *)
1218 | A.TypeExp _
, _
-> fail
1220 (* only in arg lists *)
1221 | A.MetaExprList _
, _
1228 | A.DisjExpr
eas, eb
->
1229 eas +> List.fold_left
(fun acc ea
-> acc
>|+|> (expression ea eb
)) fail
1231 | A.UniqueExp _
,_
| A.OptExp _
,_
->
1232 failwith
"not handling Opt/Unique/Multi on expr"
1234 (* Because of Exp cant put a raise Impossible; have to put a fail *)
1236 (* have not a counter part in coccinelle, for the moment *)
1237 | _
, ((B.Sequence _
,_
),_
)
1238 | _
, ((B.StatementExpr _
,_
),_
)
1239 | _
, ((B.Constructor _
,_
),_
)
1244 (((B.Cast
(_
, _
)|B.ParenExpr _
|B.SizeOfType _
|B.SizeOfExpr _
|
1245 B.RecordPtAccess
(_
, _
)|
1246 B.RecordAccess
(_
, _
)|B.ArrayAccess
(_
, _
)|
1247 B.Binary
(_
, _
, _
)|B.Unary
(_
, _
)|
1248 B.Infix
(_
, _
)|B.Postfix
(_
, _
)|
1249 B.Assignment
(_
, _
, _
)|B.CondExpr
(_
, _
, _
)|
1250 B.FunCall
(_
, _
)|B.Constant _
|B.Ident _
),
1258 (* ------------------------------------------------------------------------- *)
1259 and (ident_cpp
: info_ident
-> (A.ident, B.name
) matcher
) =
1260 fun infoidb ida idb
->
1262 | B.RegularName
(s, iis) ->
1263 let iis = tuple_of_list1
iis in
1264 ident infoidb ida
(s, iis) >>= (fun ida
(s,iis) ->
1267 (B.RegularName
(s, [iis]))
1269 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
1271 (* This should be moved to the Id case of ident. Metavariables
1272 should be allowed to be bound to such variables. But doing so
1273 would require implementing an appropriate distr function *)
1276 and (ident: info_ident
-> (A.ident, string * Ast_c.info
) matcher
) =
1277 fun infoidb ida
((idb
, iib
)) -> (* (idb, iib) as ib *)
1278 X.all_bound
(A.get_inherited ida
) >&&>
1279 match A.unwrap ida
with
1281 if (term sa
) =$
= idb
then
1282 tokenf sa iib
>>= (fun sa iib
->
1284 ((A.Id sa
)) +> A.rewrap ida
,
1289 | A.MetaId
(mida
,constraints
,keep
,inherited
) ->
1290 X.check_idconstraint
satisfies_iconstraint constraints idb
1292 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1293 (* use drop_pos for ids so that the pos is not added a second time in
1294 the call to tokenf *)
1295 X.envf keep inherited
(A.drop_pos mida
, Ast_c.MetaIdVal
(idb
), max_min)
1297 tokenf mida iib
>>= (fun mida iib
->
1299 ((A.MetaId
(mida
, constraints
, keep
, inherited
)) +> A.rewrap ida
,
1304 | A.MetaFunc
(mida
,constraints
,keep
,inherited
) ->
1306 X.check_idconstraint
satisfies_iconstraint constraints idb
1308 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1309 X.envf keep inherited
(A.drop_pos mida
,Ast_c.MetaFuncVal idb
,max_min)
1311 tokenf mida iib
>>= (fun mida iib
->
1313 ((A.MetaFunc
(mida
,constraints
,keep
,inherited
)))+>A.rewrap ida
,
1318 | LocalFunction
| Function
-> is_function()
1320 failwith
"MetaFunc, need more semantic info about id"
1321 (* the following implementation could possibly be useful, if one
1322 follows the convention that a macro is always in capital letters
1323 and that a macro is not a function.
1324 (if idb =~ "^[A-Z_][A-Z_0-9]*$" then fail else is_function())*)
1327 | A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
) ->
1330 X.check_idconstraint
satisfies_iconstraint constraints idb
1332 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1333 X.envf keep inherited
1334 (A.drop_pos mida
,Ast_c.MetaLocalFuncVal idb
, max_min)
1336 tokenf mida iib
>>= (fun mida iib
->
1338 ((A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
)))
1344 | DontKnow
-> failwith
"MetaLocalFunc, need more semantic info about id"
1347 | A.OptIdent _
| A.UniqueIdent _
->
1348 failwith
"not handling Opt/Unique for ident"
1352 (* ------------------------------------------------------------------------- *)
1353 and (arguments
: sequence
->
1354 (A.expression list
, Ast_c.argument
Ast_c.wrap2 list
) matcher
) =
1355 fun seqstyle eas ebs
->
1357 | Unordered
-> failwith
"not handling ooo"
1359 arguments_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1360 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1362 (* because '...' can match nothing, need to take care when have
1363 * ', ...' or '...,' as in f(..., X, Y, ...). It must match
1364 * f(1,2) for instance.
1365 * So I have added special cases such as (if startxs = []) and code
1366 * in the Ecomma matching rule.
1368 * old: Must do some try, for instance when f(...,X,Y,...) have to
1369 * test the transfo for all the combinaitions and if multiple transfo
1370 * possible ? pb ? => the type is to return a expression option ? use
1371 * some combinators to help ?
1372 * update: with the tag-SP approach, no more a problem.
1375 and arguments_bis
= fun eas ebs
->
1377 | [], [] -> return ([], [])
1378 | [], eb
::ebs
-> fail
1380 X.all_bound
(A.get_inherited ea
) >&&>
1381 (match A.unwrap ea
, ebs
with
1382 | A.Edots
(mcode
, optexpr
), ys
->
1383 (* todo: if optexpr, then a WHEN and so may have to filter yys *)
1384 if optexpr
<> None
then failwith
"not handling when in argument";
1386 (* '...' can take more or less the beginnings of the arguments *)
1387 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1388 startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
1391 (* allow '...', and maybe its associated ',' to match nothing.
1392 * for the associated ',' see below how we handle the EComma
1397 if mcode_contain_plus (mcodekind mcode
)
1399 (* failwith "I have no token that I could accroche myself on" *)
1400 else return (dots2metavar mcode
, [])
1402 (* subtil: we dont want the '...' to match until the
1403 * comma. cf -test pb_params_iso. We would get at
1404 * "already tagged" error.
1405 * this is because both f (... x, ...) and f (..., x, ...)
1406 * would match a f(x,3) with our "optional-comma" strategy.
1408 (match Common.last startxs
with
1411 X.distrf_args
(dots2metavar mcode
) startxs
1414 >>= (fun mcode startxs
->
1415 let mcode = metavar2dots mcode in
1416 arguments_bis
eas endxs
>>= (fun eas endxs
->
1418 (A.Edots
(mcode, optexpr
) +> A.rewrap ea
) ::eas,
1424 | A.EComma ia1
, Right ii
::ebs
->
1425 let ib1 = tuple_of_list1 ii
in
1426 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1427 arguments_bis
eas ebs
>>= (fun eas ebs
->
1429 (A.EComma ia1
+> A.rewrap ea
)::eas,
1433 | A.EComma ia1
, ebs
->
1434 (* allow ',' to maching nothing. optional comma trick *)
1435 if mcode_contain_plus (mcodekind ia1
)
1437 else arguments_bis
eas ebs
1439 | A.MetaExprList
(ida
,leninfo
,keep
,inherited
),ys
->
1440 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1441 startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
1446 if mcode_contain_plus (mcodekind ida
)
1448 (* failwith "no token that I could accroche myself on" *)
1451 (match Common.last startxs
with
1459 let startxs'
= Ast_c.unsplit_comma
startxs in
1460 let len = List.length
startxs'
in
1463 | Some
(lenname
,lenkeep
,leninherited
) ->
1464 let max_min _
= failwith
"no pos" in
1465 X.envf lenkeep leninherited
1466 (lenname
, Ast_c.MetaListlenVal
(len), max_min)
1467 | None
-> function f
-> f
()
1471 Lib_parsing_c.lin_col_by_pos
1472 (Lib_parsing_c.ii_of_args
startxs) in
1473 X.envf keep inherited
1474 (ida
, Ast_c.MetaExprListVal
startxs'
, max_min)
1477 then return (ida
, [])
1478 else X.distrf_args ida
(Ast_c.split_comma
startxs'
)
1480 >>= (fun ida
startxs ->
1481 arguments_bis
eas endxs
>>= (fun eas endxs
->
1483 (A.MetaExprList
(ida
,leninfo
,keep
,inherited
))
1484 +> A.rewrap ea
::eas,
1492 | _unwrapx
, (Left eb
)::ebs
->
1493 argument ea eb
>>= (fun ea eb
->
1494 arguments_bis
eas ebs
>>= (fun eas ebs
->
1495 return (ea
::eas, Left eb
::ebs
)
1497 | _unwrapx
, (Right y
)::ys
-> raise Impossible
1498 | _unwrapx
, [] -> fail
1502 and argument arga argb
=
1503 X.all_bound
(A.get_inherited arga
) >&&>
1504 match A.unwrap arga
, argb
with
1506 Right
(B.ArgType
{B.p_register
=b
,iib
; p_namei
=sopt
;p_type
=tyb
}) ->
1508 if b
|| sopt
<> None
1510 (* failwith "the argument have a storage and ast_cocci does not have"*)
1513 (* b = false and sopt = None *)
1514 fullType tya tyb
>>= (fun tya tyb
->
1516 (A.TypeExp tya
) +> A.rewrap arga
,
1517 (Right
(B.ArgType
{B.p_register
=(b
,iib
);
1522 | A.TypeExp tya
, _
-> fail
1523 | _
, Right
(B.ArgType _
) -> fail
1525 expression arga argb
>>= (fun arga argb
->
1526 return (arga
, Left argb
)
1528 | _
, Right
(B.ArgAction y
) -> fail
1531 (* ------------------------------------------------------------------------- *)
1532 (* todo? facto code with argument ? *)
1533 and (parameters
: sequence
->
1534 (A.parameterTypeDef list
, Ast_c.parameterType
Ast_c.wrap2 list
)
1536 fun seqstyle eas ebs
->
1538 | Unordered
-> failwith
"not handling ooo"
1540 parameters_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1541 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1545 and parameters_bis
eas ebs
=
1547 | [], [] -> return ([], [])
1548 | [], eb
::ebs
-> fail
1550 (* the management of positions is inlined into each case, because
1551 sometimes there is a Param and sometimes a ParamList *)
1552 X.all_bound
(A.get_inherited ea
) >&&>
1553 (match A.unwrap ea
, ebs
with
1554 | A.Pdots
(mcode), ys
->
1556 (* '...' can take more or less the beginnings of the arguments *)
1557 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1558 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
1563 if mcode_contain_plus (mcodekind mcode)
1565 (* failwith "I have no token that I could accroche myself on"*)
1566 else return (dots2metavar mcode, [])
1568 (match Common.last
startxs with
1571 X.distrf_params
(dots2metavar mcode) startxs
1573 ) >>= (fun mcode startxs ->
1574 let mcode = metavar2dots mcode in
1575 parameters_bis
eas endxs
>>= (fun eas endxs
->
1577 (A.Pdots
(mcode) +> A.rewrap ea
) ::eas,
1583 | A.PComma ia1
, Right ii
::ebs
->
1584 let ib1 = tuple_of_list1 ii
in
1585 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1586 parameters_bis
eas ebs
>>= (fun eas ebs
->
1588 (A.PComma ia1
+> A.rewrap ea
)::eas,
1593 | A.PComma ia1
, ebs
->
1594 (* try optional comma trick *)
1595 if mcode_contain_plus (mcodekind ia1
)
1597 else parameters_bis
eas ebs
1600 | A.MetaParamList
(ida
,leninfo
,keep
,inherited
),ys
->
1601 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1602 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
1607 if mcode_contain_plus (mcodekind ida
)
1609 (* failwith "I have no token that I could accroche myself on" *)
1612 (match Common.last
startxs with
1620 let startxs'
= Ast_c.unsplit_comma
startxs in
1621 let len = List.length
startxs'
in
1624 Some
(lenname
,lenkeep
,leninherited
) ->
1625 let max_min _
= failwith
"no pos" in
1626 X.envf lenkeep leninherited
1627 (lenname
, Ast_c.MetaListlenVal
(len), max_min)
1628 | None
-> function f
-> f
()
1632 Lib_parsing_c.lin_col_by_pos
1633 (Lib_parsing_c.ii_of_params
startxs) in
1634 X.envf keep inherited
1635 (ida
, Ast_c.MetaParamListVal
startxs'
, max_min)
1638 then return (ida
, [])
1639 else X.distrf_params ida
(Ast_c.split_comma
startxs'
)
1640 ) >>= (fun ida
startxs ->
1641 parameters_bis
eas endxs
>>= (fun eas endxs
->
1643 (A.MetaParamList
(ida
,leninfo
,keep
,inherited
))
1644 +> A.rewrap ea
::eas,
1652 | A.VoidParam ta
, ys
->
1653 (match eas, ebs
with
1655 let {B.p_register
=(hasreg
,iihasreg
);
1657 p_type
=tb
; } = eb
in
1659 if idbopt
=*= None
&& not hasreg
1662 | (qub
, (B.BaseType
B.Void
,_
)) ->
1663 fullType ta tb
>>= (fun ta tb
->
1665 [(A.VoidParam ta
) +> A.rewrap ea
],
1666 [Left
{B.p_register
=(hasreg
, iihasreg
);
1675 | (A.OptParam _
| A.UniqueParam _
), _
->
1676 failwith
"handling Opt/Unique for Param"
1678 | A.Pcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
1681 | A.MetaParam
(ida
,keep
,inherited
), (Left eb
)::ebs
->
1682 (* todo: use quaopt, hasreg ? *)
1684 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_param eb
) in
1685 X.envf keep inherited
(ida
,Ast_c.MetaParamVal eb
,max_min) (fun () ->
1686 X.distrf_param ida eb
1687 ) >>= (fun ida eb
->
1688 parameters_bis
eas ebs
>>= (fun eas ebs
->
1690 (A.MetaParam
(ida
,keep
,inherited
))+> A.rewrap ea
::eas,
1695 | A.Param
(typa
, idaopt
), (Left eb
)::ebs
->
1696 (*this should succeed if the C code has a name, and fail otherwise*)
1697 parameter
(idaopt
, typa
) eb
>>= (fun (idaopt
, typa
) eb
->
1698 parameters_bis
eas ebs
>>= (fun eas ebs
->
1700 (A.Param
(typa
, idaopt
))+> A.rewrap ea
:: eas,
1704 | _unwrapx
, (Right y
)::ys
-> raise Impossible
1705 | _unwrapx
, [] -> fail
1711 let split_register_param = fun (hasreg, idb, ii_b_s) ->
1712 match hasreg, idb, ii_b_s with
1713 | false, Some s, [i1] -> Left (s, [], i1)
1714 | true, Some s, [i1;i2] -> Left (s, [i1], i2)
1715 | _, None, ii -> Right ii
1716 | _ -> raise Impossible
1720 and parameter
= fun (idaopt
, typa
) paramb
->
1722 let {B.p_register
= (hasreg
,iihasreg
);
1723 p_namei
= nameidbopt
;
1724 p_type
= typb
;} = paramb
in
1726 fullType typa typb
>>= (fun typa typb
->
1727 match idaopt
, nameidbopt
with
1728 | Some ida
, Some nameidb
->
1729 (* todo: if minus on ida, should also minus the iihasreg ? *)
1730 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1733 {B.p_register
= (hasreg
, iihasreg
);
1734 p_namei
= Some
(nameidb
);
1741 {B.p_register
=(hasreg
,iihasreg
);
1747 (* why handle this case ? because of transform_proto ? we may not
1748 * have an ident in the proto.
1749 * If have some plus on ida ? do nothing about ida ?
1751 (* not anymore !!! now that julia is handling the proto.
1752 | _, Right iihasreg ->
1755 ((hasreg, None, typb), iihasreg)
1759 | Some _
, None
-> fail
1760 | None
, Some _
-> fail
1766 (* ------------------------------------------------------------------------- *)
1767 and (declaration
: (A.mcodekind * bool * A.declaration
,B.declaration
) matcher
) =
1768 fun (mckstart
, allminus
, decla
) declb
->
1769 X.all_bound
(A.get_inherited decla
) >&&>
1770 match A.unwrap decla
, declb
with
1772 (* Un MetaDecl est introduit dans l'asttoctl pour sauter au dessus
1773 * de toutes les declarations qui sont au debut d'un fonction et
1774 * commencer le reste du match au premier statement. Alors, ca matche
1775 * n'importe quelle declaration. On n'a pas besoin d'ajouter
1776 * quoi que ce soit dans l'environnement. C'est une sorte de DDots.
1778 * When the SP want to remove the whole function, the minus is not
1779 * on the MetaDecl but on the MetaRuleElem. So there should
1780 * be no transform of MetaDecl, just matching are allowed.
1783 | A.MetaDecl
(ida
,_keep
,_inherited
), _
-> (* keep ? inherited ? *)
1784 (* todo: should not happen in transform mode *)
1785 return ((mckstart
, allminus
, decla
), declb
)
1789 | _
, (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
)) ->
1790 onedecl allminus decla
(var
,iiptvirgb
,iisto
) >>=
1791 (fun decla
(var
,iiptvirgb
,iisto
)->
1792 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1794 (mckstart
, allminus
, decla
),
1795 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1798 | _
, (B.DeclList
(xs
, iiptvirgb
::iifakestart
::iisto
)) ->
1799 if X.mode
=*= PatternMode
1801 xs
+> List.fold_left
(fun acc var
->
1803 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1804 onedecl allminus decla
(var
, iiptvirgb
, iisto
) >>=
1805 (fun decla
(var
, iiptvirgb
, iisto
) ->
1807 (mckstart
, allminus
, decla
),
1808 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1812 failwith
"More that one variable in decl. Have to split to transform."
1814 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
), B.MacroDecl
((sb
,ebs
),ii
) ->
1815 let (iisb
, lpb
, rpb
, iiendb
, iifakestart
, iistob
) =
1817 | iisb
::lpb
::rpb
::iiendb
::iifakestart
::iisto
->
1818 (iisb
,lpb
,rpb
,iiendb
, iifakestart
,iisto
)
1819 | _
-> raise Impossible
1822 then minusize_list iistob
1823 else return ((), iistob
)
1824 ) >>= (fun () iistob
->
1826 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1827 ident DontKnow sa
(sb
, iisb
) >>= (fun sa
(sb
, iisb
) ->
1828 tokenf lpa lpb
>>= (fun lpa lpb
->
1829 tokenf rpa rpb
>>= (fun rpa rpb
->
1830 tokenf enda iiendb
>>= (fun enda iiendb
->
1831 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
1832 let eas = redots
eas easundots
in
1835 (mckstart
, allminus
,
1836 (A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
)) +> A.rewrap decla
),
1837 (B.MacroDecl
((sb
,ebs
),
1838 [iisb
;lpb
;rpb
;iiendb
;iifakestart
] ++ iistob
))
1841 | _
, (B.MacroDecl _
|B.DeclList _
) -> fail
1844 and onedecl
= fun allminus decla
(declb
, iiptvirgb
, iistob
) ->
1845 X.all_bound
(A.get_inherited decla
) >&&>
1846 match A.unwrap decla
, declb
with
1848 (* kind of typedef iso, we must unfold, it's for the case
1849 * T { }; that we want to match against typedef struct { } xx_t;
1851 | A.TyDecl
(tya0
, ptvirga
),
1852 ({B.v_namei
= Some
(nameidb
, None
);
1854 B.v_storage
= (B.StoTypedef
, inl
);
1857 B.v_type_bis
= typb0bis
;
1860 (match A.unwrap tya0
, typb0
with
1861 | A.Type
(cv1
,tya1
), ((qu
,il
),typb1
) ->
1863 (match A.unwrap tya1
, typb1
with
1864 | A.StructUnionDef
(tya2
, lba
, declsa
, rba
),
1865 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
1867 let (iisub
, iisbopt
, lbb
, rbb
) =
1870 let (iisub
, lbb
, rbb
) = tuple_of_list3 ii
in
1871 (iisub
, [], lbb
, rbb
)
1874 "warning: both a typedef (%s) and struct name introduction (%s)"
1875 (Ast_c.str_of_name nameidb
) s
1877 pr2 "warning: I will consider only the typedef";
1878 let (iisub
, iisb
, lbb
, rbb
) = tuple_of_list4 ii
in
1879 (iisub
, [iisb
], lbb
, rbb
)
1882 structdef_to_struct_name
1883 (Ast_c.nQ
, (B.StructUnion
(sub
, sbopt
, declsb
), ii
))
1886 Ast_c.nQ
,((B.TypeName
(nameidb
, Some
1887 (Lib_parsing_c.al_type
structnameb))), [])
1890 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1891 tokenf lba lbb
>>= (fun lba lbb
->
1892 tokenf rba rbb
>>= (fun rba rbb
->
1893 struct_fields
(A.undots declsa
) declsb
>>=(fun undeclsa declsb
->
1894 let declsa = redots
declsa undeclsa
in
1896 (match A.unwrap tya2
with
1897 | A.Type
(cv3
, tya3
) ->
1898 (match A.unwrap tya3
with
1899 | A.MetaType
(ida
,keep
, inherited
) ->
1901 fullType tya2
fake_typeb >>= (fun tya2
fake_typeb ->
1903 A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1 in
1904 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1907 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1908 [iisub
] @ iisbopt
@ [lbb
;rbb
] in
1909 let typb0 = ((qu
, il
), typb1) in
1911 match fake_typeb with
1912 | _nQ
, ((B.TypeName
(nameidb
, _typ
)),[]) ->
1915 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1916 (({B.v_namei
= Some
(nameidb
, None
);
1918 B.v_storage
= (B.StoTypedef
, inl
);
1921 B.v_type_bis
= typb0bis
;
1923 iivirg
),iiptvirgb
,iistob
)
1925 | _
-> raise Impossible
1928 | A.StructUnionName
(sua
, sa
) ->
1930 fullType tya2
structnameb >>= (fun tya2
structnameb ->
1932 let tya1 = A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1
1934 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1936 match structnameb with
1937 | _nQ
, (B.StructUnionName
(sub
, s), [iisub
;iisbopt
]) ->
1939 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1940 [iisub
;iisbopt
;lbb
;rbb
] in
1941 let typb0 = ((qu
, il
), typb1) in
1944 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1945 (({B.v_namei
= Some
(nameidb
, None
);
1947 B.v_storage
= (B.StoTypedef
, inl
);
1950 B.v_type_bis
= typb0bis
;
1952 iivirg
),iiptvirgb
,iistob
)
1954 | _
-> raise Impossible
1956 | _
-> raise Impossible
1965 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1966 ({B.v_namei
= Some
(nameidb
, _
);B.v_storage
= (B.StoTypedef
,_
);}, iivirg
)
1969 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1970 ({B.v_namei
=Some
(nameidb
, _
);B.v_storage
=(B.StoTypedef
,_
);}, iivirg
)
1975 (* could handle iso here but handled in standard.iso *)
1976 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1977 ({B.v_namei
= Some
(nameidb
, None
);
1982 B.v_type_bis
= typbbis
;
1985 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1986 fullType typa typb
>>= (fun typa typb
->
1987 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1988 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1989 (fun stoa
(stob
, iistob
) ->
1991 (A.UnInit
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
1992 (({B.v_namei
= Some
(nameidb
, None
);
1997 B.v_type_bis
= typbbis
;
2002 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
2003 ({B.v_namei
= Some
(nameidb
, Some
(iieqb
, inib
));
2008 B.v_type_bis
= typbbis
;
2011 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2012 tokenf eqa iieqb
>>= (fun eqa iieqb
->
2013 fullType typa typb
>>= (fun typa typb
->
2014 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
2015 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
2016 (fun stoa
(stob
, iistob
) ->
2017 initialiser inia inib
>>= (fun inia inib
->
2019 (A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
)) +> A.rewrap decla
,
2020 (({B.v_namei
= Some
(nameidb
, Some
(iieqb
, inib
));
2025 B.v_type_bis
= typbbis
;
2030 (* do iso-by-absence here ? allow typedecl and var ? *)
2031 | A.TyDecl
(typa
, ptvirga
),
2032 ({B.v_namei
= None
; B.v_type
= typb
;
2036 B.v_type_bis
= typbbis
;
2039 if stob
=*= (B.NoSto
, false)
2041 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2042 fullType typa typb
>>= (fun typa typb
->
2044 (A.TyDecl
(typa
, ptvirga
)) +> A.rewrap decla
,
2045 (({B.v_namei
= None
;
2050 B.v_type_bis
= typbbis
;
2051 }, iivirg
), iiptvirgb
, iistob
)
2056 | A.Typedef
(stoa
, typa
, ida
, ptvirga
),
2057 ({B.v_namei
= Some
(nameidb
, None
);
2059 B.v_storage
= (B.StoTypedef
,inline
);
2062 B.v_type_bis
= typbbis
;
2065 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2066 fullType typa typb
>>= (fun typa typb
->
2069 tokenf stoa iitypedef
>>= (fun stoa iitypedef
->
2070 return (stoa
, [iitypedef
])
2072 | _
-> failwith
"weird, have both typedef and inline or nothing";
2073 ) >>= (fun stoa iistob
->
2074 (match A.unwrap ida
with
2075 | A.MetaType
(_
,_
,_
) ->
2078 Ast_c.nQ
, ((B.TypeName
(nameidb
, Ast_c.noTypedefDef
())), [])
2080 fullTypebis ida
fake_typeb >>= (fun ida
fake_typeb ->
2081 match fake_typeb with
2082 | _nQ
, ((B.TypeName
(nameidb
, _typ
)), []) ->
2083 return (ida
, nameidb
)
2084 | _
-> raise Impossible
2089 | B.RegularName
(sb
, iidb
) ->
2090 let iidb1 = tuple_of_list1 iidb
in
2094 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
2096 (A.TypeName sa
) +> A.rewrap ida
,
2097 B.RegularName
(sb
, [iidb1])
2101 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
2105 | _
-> raise Impossible
2107 ) >>= (fun ida nameidb
->
2109 (A.Typedef
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
2110 (({B.v_namei
= Some
(nameidb
, None
);
2112 B.v_storage
= (B.StoTypedef
,inline
);
2115 B.v_type_bis
= typbbis
;
2123 | _
, ({B.v_namei
= None
;}, _
) ->
2124 (* old: failwith "no variable in this declaration, weird" *)
2129 | A.DisjDecl declas
, declb
->
2130 declas
+> List.fold_left
(fun acc decla
->
2132 (* (declaration (mckstart, allminus, decla) declb) *)
2133 (onedecl allminus decla
(declb
,iiptvirgb
, iistob
))
2138 (* only in struct type decls *)
2139 | A.Ddots
(dots
,whencode
), _
->
2142 | A.OptDecl _
, _
| A.UniqueDecl _
, _
->
2143 failwith
"not handling Opt/Unique Decl"
2145 | _
, ({B.v_namei
=Some _
}, _
) ->
2151 (* ------------------------------------------------------------------------- *)
2153 and (initialiser
: (A.initialiser
, Ast_c.initialiser
) matcher
) = fun ia ib
->
2154 X.all_bound
(A.get_inherited ia
) >&&>
2155 match (A.unwrap ia
,ib
) with
2157 | (A.MetaInit
(ida
,keep
,inherited
), ib
) ->
2159 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_ini ib
) in
2160 X.envf keep inherited
(ida
, Ast_c.MetaInitVal ib
, max_min)
2162 X.distrf_ini ida ib
>>= (fun ida ib
->
2164 A.MetaInit
(ida
,keep
,inherited
) +> A.rewrap ia
,
2169 | (A.InitExpr expa
, ib
) ->
2170 (match A.unwrap expa
, ib
with
2171 | A.Edots
(mcode, None
), ib
->
2172 X.distrf_ini
(dots2metavar mcode) ib
>>= (fun mcode ib
->
2175 (A.Edots
(metavar2dots mcode, None
) +> A.rewrap expa
)
2180 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
2182 | _
, (B.InitExpr expb
, ii
) ->
2184 expression expa expb
>>= (fun expa expb
->
2186 (A.InitExpr expa
) +> A.rewrap ia
,
2187 (B.InitExpr expb
, ii
)
2192 | (A.InitList
(ia1
, ias
, ia2
, []), (B.InitList ibs
, ii
)) ->
2194 | ib1::ib2
::iicommaopt
->
2195 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2196 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2197 initialisers ias
(ibs
, iicommaopt
) >>= (fun ias
(ibs
,iicommaopt
) ->
2199 (A.InitList
(ia1
, ias
, ia2
, [])) +> A.rewrap ia
,
2200 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2203 | _
-> raise Impossible
2206 | (A.InitList
(i1
, ias
, i2
, whencode
),(B.InitList ibs
, _ii
)) ->
2207 failwith
"TODO: not handling whencode in initialisers"
2210 | (A.InitGccExt
(designatorsa
, ia2
, inia
),
2211 (B.InitDesignators
(designatorsb
, inib
), ii2
))->
2213 let iieq = tuple_of_list1 ii2
in
2215 tokenf ia2
iieq >>= (fun ia2
iieq ->
2216 designators designatorsa designatorsb
>>=
2217 (fun designatorsa designatorsb
->
2218 initialiser inia inib
>>= (fun inia inib
->
2220 (A.InitGccExt
(designatorsa
, ia2
, inia
)) +> A.rewrap ia
,
2221 (B.InitDesignators
(designatorsb
, inib
), [iieq])
2227 | (A.InitGccName
(ida
, ia1
, inia
), (B.InitFieldOld
(idb
, inib
), ii
)) ->
2230 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2231 initialiser inia inib
>>= (fun inia inib
->
2232 tokenf ia1 iicolon
>>= (fun ia1 iicolon
->
2234 (A.InitGccName
(ida
, ia1
, inia
)) +> A.rewrap ia
,
2235 (B.InitFieldOld
(idb
, inib
), [iidb
;iicolon
])
2242 | A.IComma
(comma
), _
->
2245 | A.UniqueIni _
,_
| A.OptIni _
,_
->
2246 failwith
"not handling Opt/Unique on initialisers"
2248 | _
, (B.InitIndexOld
(_
, _
), _
) -> fail
2249 | _
, (B.InitFieldOld
(_
, _
), _
) -> fail
2251 | _
, ((B.InitDesignators
(_
, _
)|B.InitList _
|B.InitExpr _
), _
)
2254 and designators dla dlb
=
2255 match (dla
,dlb
) with
2256 ([],[]) -> return ([], [])
2257 | ([],_
) | (_
,[]) -> fail
2258 | (da
::dla
,db
::dlb
) ->
2259 designator da db
>>= (fun da db
->
2260 designators dla dlb
>>= (fun dla dlb
->
2261 return (da
::dla
, db
::dlb
)))
2263 and designator da db
=
2265 (A.DesignatorField
(ia1
, ida
), (B.DesignatorField idb
,ii1
)) ->
2267 let (iidot
, iidb
) = tuple_of_list2 ii1
in
2268 tokenf ia1 iidot
>>= (fun ia1 iidot
->
2269 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2271 A.DesignatorField
(ia1
, ida
),
2272 (B.DesignatorField idb
, [iidot
;iidb
])
2275 | (A.DesignatorIndex
(ia1
,ea
,ia2
), (B.DesignatorIndex eb
, ii1
)) ->
2277 let (ib1, ib2
) = tuple_of_list2 ii1
in
2278 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2279 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2280 expression ea eb
>>= (fun ea eb
->
2282 A.DesignatorIndex
(ia1
,ea
,ia2
),
2283 (B.DesignatorIndex eb
, [ib1;ib2
])
2286 | (A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2287 (B.DesignatorRange
(e1b
, e2b
), ii1
)) ->
2289 let (ib1, ib2
, ib3
) = tuple_of_list3 ii1
in
2290 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2291 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2292 tokenf ia3 ib3
>>= (fun ia3 ib3
->
2293 expression e1a e1b
>>= (fun e1a e1b
->
2294 expression e2a e2b
>>= (fun e2a e2b
->
2296 A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2297 (B.DesignatorRange
(e1b
, e2b
), [ib1;ib2
;ib3
])
2299 | (_
, ((B.DesignatorField _
|B.DesignatorIndex _
|B.DesignatorRange _
), _
)) ->
2303 and initialisers
= fun ias
(ibs
, iicomma
) ->
2304 let ias_unsplit = unsplit_icomma ias
in
2305 let ibs_split = resplit_initialiser ibs iicomma
in
2308 if need_unordered_initialisers ibs
2309 then initialisers_unordered2
2310 else initialisers_ordered2
2312 f ias_unsplit ibs_split >>=
2313 (fun ias_unsplit ibs_split ->
2315 split_icomma ias_unsplit,
2316 unsplit_initialiser ibs_split
2320 (* todo: one day julia will reput a IDots *)
2321 and initialisers_ordered2
= fun ias ibs
->
2323 | [], [] -> return ([], [])
2324 | (x
, xcomma
)::xs
, (y
, commay
)::ys
->
2325 (match A.unwrap xcomma
with
2326 | A.IComma commax
->
2327 tokenf commax commay
>>= (fun commax commay
->
2328 initialiser x y
>>= (fun x y
->
2329 initialisers_ordered2 xs ys
>>= (fun xs ys
->
2331 (x
, (A.IComma commax
) +> A.rewrap xcomma
)::xs
,
2335 | _
-> raise Impossible
(* unsplit_iicomma wrong *)
2341 and initialisers_unordered2
= fun ias ibs
->
2344 | [], ys
-> return ([], ys
)
2345 | (x
,xcomma
)::xs
, ys
->
2347 let permut = Common.uncons_permut_lazy ys
in
2348 permut +> List.fold_left
(fun acc
((e
, pos
), rest
) ->
2351 (match A.unwrap xcomma
, e
with
2352 | A.IComma commax
, (y
, commay
) ->
2353 tokenf commax commay
>>= (fun commax commay
->
2354 initialiser x y
>>= (fun x y
->
2356 (x
, (A.IComma commax
) +> A.rewrap xcomma
),
2360 | _
-> raise Impossible
(* unsplit_iicomma wrong *)
2363 let rest = Lazy.force
rest in
2364 initialisers_unordered2 xs
rest >>= (fun xs
rest ->
2367 Common.insert_elem_pos
(e
, pos
) rest
2372 (* ------------------------------------------------------------------------- *)
2373 and (struct_fields
: (A.declaration list
, B.field list
) matcher
) =
2376 | [], [] -> return ([], [])
2377 | [], eb
::ebs
-> fail
2379 X.all_bound
(A.get_inherited ea
) >&&>
2380 (match A.unwrap ea
, ebs
with
2381 | A.Ddots
(mcode, optwhen
), ys
->
2382 if optwhen
<> None
then failwith
"not handling when in argument";
2384 (* '...' can take more or less the beginnings of the arguments *)
2387 then [(ys
,[])] (* hack! the only one that can work *)
2388 else Common.zip
(Common.inits ys
) (Common.tails ys
) in
2389 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
2394 if mcode_contain_plus (mcodekind mcode)
2396 (* failwith "I have no token that I could accroche myself on" *)
2397 else return (dots2metavar mcode, [])
2400 X.distrf_struct_fields
(dots2metavar mcode) startxs
2401 ) >>= (fun mcode startxs ->
2402 let mcode = metavar2dots mcode in
2403 struct_fields
eas endxs
>>= (fun eas endxs
->
2405 (A.Ddots
(mcode, optwhen
) +> A.rewrap ea
) ::eas,
2410 | _unwrapx
, eb
::ebs
->
2411 struct_field ea eb
>>= (fun ea eb
->
2412 struct_fields
eas ebs
>>= (fun eas ebs
->
2413 return (ea
::eas, eb
::ebs
)
2416 | _unwrapx
, [] -> fail
2419 and (struct_field
: (A.declaration
, B.field
) matcher
) = fun fa fb
->
2422 | B.DeclarationField
(B.FieldDeclList
(onefield_multivars
,iiptvirg
)) ->
2424 let iiptvirgb = tuple_of_list1 iiptvirg
in
2426 (match onefield_multivars
with
2427 | [] -> raise Impossible
2428 | [onevar
,iivirg
] ->
2429 assert (null iivirg
);
2431 | B.BitField
(sopt
, typb
, _
, expr
) ->
2432 pr2_once
"warning: bitfield not handled by ast_cocci";
2434 | B.Simple
(None
, typb
) ->
2435 pr2_once
"warning: unamed struct field not handled by ast_cocci";
2437 | B.Simple
(Some nameidb
, typb
) ->
2439 (* build a declaration from a struct field *)
2440 let allminus = false in
2442 let stob = B.NoSto
, false in
2444 ({B.v_namei
= Some
(nameidb
, None
);
2447 B.v_local
= Ast_c.NotLocalDecl
;
2448 B.v_attr
= Ast_c.noattr
;
2449 B.v_type_bis
= ref None
;
2450 (* the struct field should also get expanded ? no it's not
2451 * important here, we will rematch very soon *)
2455 onedecl
allminus fa
(fake_var,iiptvirgb,iisto) >>=
2456 (fun fa
(var
,iiptvirgb,iisto) ->
2459 | ({B.v_namei
= Some
(nameidb
, None
);
2464 let onevar = B.Simple
(Some nameidb
, typb
) in
2468 ((B.DeclarationField
2469 (B.FieldDeclList
([onevar, iivirg
], [iiptvirgb])))
2472 | _
-> raise Impossible
2477 pr2_once
"PB: More that one variable in decl. Have to split";
2480 | B.EmptyField _iifield
->
2483 | B.MacroDeclField
((sb
,ebs
),ii
) ->
2484 (match A.unwrap fa
with
2485 A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
) -> raise Todo
2488 | B.CppDirectiveStruct directive
-> fail
2489 | B.IfdefStruct directive
-> fail
2493 (* ------------------------------------------------------------------------- *)
2494 and (fullType
: (A.fullType
, Ast_c.fullType
) matcher
) =
2496 X.optional_qualifier_flag
(fun optional_qualifier
->
2497 X.all_bound
(A.get_inherited typa
) >&&>
2498 match A.unwrap typa
, typb
with
2499 | A.Type
(cv
,ty1
), ((qu
,il
),ty2
) ->
2501 if qu
.B.const
&& qu
.B.volatile
2504 ("warning: the type is both const & volatile but cocci " ^
2505 "does not handle that");
2507 (* Drop out the const/volatile part that has been matched.
2508 * This is because a SP can contain const T v; in which case
2509 * later in match_t_t when we encounter a T, we must not add in
2510 * the environment the whole type.
2515 (* "iso-by-absence" *)
2518 fullTypebis ty1
((qu
,il
), ty2
) >>= (fun ty1 fullty2
->
2520 (A.Type
(None
, ty1
)) +> A.rewrap typa
,
2524 (match optional_qualifier
, qu
.B.const
|| qu
.B.volatile
with
2525 | false, false -> do_stuff ()
2526 | false, true -> fail
2527 | true, false -> do_stuff ()
2530 then pr2_once
"USING optional_qualifier builtin isomorphism";
2536 (* todo: can be __const__ ? can be const & volatile so
2537 * should filter instead ?
2539 (match term x
, il
with
2540 | A.Const
, [i1
] when qu
.B.const
->
2542 tokenf x i1
>>= (fun x i1
->
2543 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2545 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2549 | A.Volatile
, [i1
] when qu
.B.volatile
->
2550 tokenf x i1
>>= (fun x i1
->
2551 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2553 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2561 | A.DisjType typas
, typb
->
2563 List.fold_left
(fun acc typa
-> acc
>|+|> (fullType typa typb
)) fail
2565 | A.OptType
(_
), _
| A.UniqueType
(_
), _
2566 -> failwith
"not handling Opt/Unique on type"
2571 * Why not (A.typeC, Ast_c.typeC) matcher ?
2572 * because when there is MetaType, we want that T record the whole type,
2573 * including the qualifier, and so this type (and the new_il function in
2574 * preceding function).
2577 and (fullTypebis
: (A.typeC
, Ast_c.fullType
) matcher
) =
2579 X.all_bound
(A.get_inherited ta
) >&&>
2580 match A.unwrap ta
, tb
with
2583 | A.MetaType
(ida
,keep
, inherited
), typb
->
2585 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
2586 X.envf keep inherited
(ida
, B.MetaTypeVal typb
, max_min) (fun () ->
2587 X.distrf_type ida typb
>>= (fun ida typb
->
2589 A.MetaType
(ida
,keep
, inherited
) +> A.rewrap ta
,
2593 | unwrap
, (qub
, typb
) ->
2594 typeC ta typb
>>= (fun ta typb
->
2595 return (ta
, (qub
, typb
))
2598 and simulate_signed ta basea stringsa signaopt tb baseb ii rebuilda
=
2599 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2600 * And even if in baseb we have a Signed Int, that does not mean
2601 * that ii is of length 2, cos Signed is the default, so if in signa
2602 * we have Signed explicitely ? we cant "accrocher" this mcode to
2603 * something :( So for the moment when there is signed in cocci,
2604 * we force that there is a signed in c too (done in pattern.ml).
2606 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2609 (* handle some iso on type ? (cf complex C rule for possible implicit
2611 match basea
, baseb
with
2612 | A.VoidType
, B.Void
2613 | A.FloatType
, B.FloatType
(B.CFloat
)
2614 | A.DoubleType
, B.FloatType
(B.CDouble
) ->
2615 assert (signaopt
=*= None
);
2616 let stringa = tuple_of_list1 stringsa
in
2617 let (ibaseb
) = tuple_of_list1 ii
in
2618 tokenf stringa ibaseb
>>= (fun stringa ibaseb
->
2620 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2621 (B.BaseType baseb
, [ibaseb
])
2624 | A.CharType
, B.IntType
B.CChar
when signaopt
=*= None
->
2625 let stringa = tuple_of_list1 stringsa
in
2626 let ibaseb = tuple_of_list1 ii
in
2627 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2629 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2630 (B.BaseType
(B.IntType
B.CChar
), [ibaseb])
2633 | A.CharType
,B.IntType
(B.Si
(_sign
, B.CChar2
)) when signaopt
<> None
->
2634 let stringa = tuple_of_list1 stringsa
in
2635 let ibaseb = tuple_of_list1 iibaseb
in
2636 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2637 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2639 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2640 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2643 | A.ShortType
, B.IntType
(B.Si
(_
, B.CShort
))
2644 | A.IntType
, B.IntType
(B.Si
(_
, B.CInt
))
2645 | A.LongType
, B.IntType
(B.Si
(_
, B.CLong
)) ->
2646 let stringa = tuple_of_list1 stringsa
in
2649 (* iso-by-presence ? *)
2650 (* when unsigned int in SP, allow have just unsigned in C ? *)
2651 if mcode_contain_plus (mcodekind stringa)
2655 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2657 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2658 (B.BaseType
(baseb
), iisignbopt
++ [])
2664 "warning: long int or short int not handled by ast_cocci";
2668 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2669 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2671 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2672 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2674 | _
-> raise Impossible
2679 | A.LongLongType
, B.IntType
(B.Si
(_
, B.CLongLong
)) ->
2680 let (string1a
,string2a
) = tuple_of_list2 stringsa
in
2682 [ibase1b
;ibase2b
] ->
2683 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2684 tokenf string1a ibase1b
>>= (fun base1a ibase1b
->
2685 tokenf string2a ibase2b
>>= (fun base2a ibase2b
->
2687 (rebuilda
([base1a
;base2a
], signaopt
)) +> A.rewrap ta
,
2688 (B.BaseType
(baseb
), iisignbopt
++ [ibase1b
;ibase2b
])
2690 | [] -> fail (* should something be done in this case? *)
2691 | _
-> raise Impossible
)
2694 | _
, B.FloatType
B.CLongDouble
2697 "warning: long double not handled by ast_cocci";
2700 | _
, (B.Void
|B.FloatType _
|B.IntType _
) -> fail
2702 and simulate_signed_meta ta basea signaopt tb baseb ii rebuilda
=
2703 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2704 * And even if in baseb we have a Signed Int, that does not mean
2705 * that ii is of length 2, cos Signed is the default, so if in signa
2706 * we have Signed explicitely ? we cant "accrocher" this mcode to
2707 * something :( So for the moment when there is signed in cocci,
2708 * we force that there is a signed in c too (done in pattern.ml).
2710 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2712 let match_to_type rebaseb
=
2713 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2714 let fta = A.rewrap basea
(A.Type
(None
,basea
)) in
2715 let ftb = Ast_c.nQ
,(B.BaseType
(rebaseb
), iibaseb
) in
2716 fullType
fta ftb >>= (fun fta (_
,tb
) ->
2717 (match A.unwrap
fta,tb
with
2718 A.Type
(_
,basea
), (B.BaseType baseb
, ii
) ->
2720 (rebuilda
(basea
, signaopt
)) +> A.rewrap ta
,
2721 (B.BaseType
(baseb
), iisignbopt
++ ii
)
2723 | _
-> failwith
"not possible"))) in
2725 (* handle some iso on type ? (cf complex C rule for possible implicit
2728 | B.IntType
(B.Si
(_sign
, B.CChar2
)) ->
2729 match_to_type (B.IntType
B.CChar
)
2731 | B.IntType
(B.Si
(_
, ty
)) ->
2733 | [] -> fail (* metavariable has to match something *)
2735 | _
-> match_to_type (B.IntType
(B.Si
(B.Signed
, ty
)))
2739 | (B.Void
|B.FloatType _
|B.IntType _
) -> fail
2741 and (typeC
: (A.typeC
, Ast_c.typeC
) matcher
) =
2743 match A.unwrap ta
, tb
with
2744 | A.BaseType
(basea
,stringsa
), (B.BaseType baseb
, ii
) ->
2745 simulate_signed ta basea stringsa None tb baseb ii
2746 (function (stringsa
, signaopt
) -> A.BaseType
(basea
,stringsa
))
2747 | A.SignedT
(signaopt
, Some basea
), (B.BaseType baseb
, ii
) ->
2748 (match A.unwrap basea
with
2749 A.BaseType
(basea1
,strings1
) ->
2750 simulate_signed ta basea1 strings1
(Some signaopt
) tb baseb ii
2751 (function (strings1
, Some signaopt
) ->
2754 Some
(A.rewrap basea
(A.BaseType
(basea1
,strings1
))))
2755 | _
-> failwith
"not possible")
2756 | A.MetaType
(ida
,keep
,inherited
) ->
2757 simulate_signed_meta ta basea
(Some signaopt
) tb baseb ii
2758 (function (basea
, Some signaopt
) ->
2759 A.SignedT
(signaopt
,Some basea
)
2760 | _
-> failwith
"not possible")
2761 | _
-> failwith
"not possible")
2762 | A.SignedT
(signa
,None
), (B.BaseType baseb
, ii
) ->
2763 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2764 (match iibaseb
, baseb
with
2765 | [], B.IntType
(B.Si
(_sign
, B.CInt
)) ->
2766 sign
(Some signa
) signbopt >>= (fun signaopt iisignbopt
->
2768 | None
-> raise Impossible
2771 (A.SignedT
(signa
,None
)) +> A.rewrap ta
,
2772 (B.BaseType baseb
, iisignbopt
)
2780 (* todo? iso with array *)
2781 | A.Pointer
(typa
, iamult
), (B.Pointer typb
, ii
) ->
2782 let (ibmult
) = tuple_of_list1 ii
in
2783 fullType typa typb
>>= (fun typa typb
->
2784 tokenf iamult ibmult
>>= (fun iamult ibmult
->
2786 (A.Pointer
(typa
, iamult
)) +> A.rewrap ta
,
2787 (B.Pointer typb
, [ibmult
])
2790 | A.FunctionType
(allminus,tyaopt
,lpa
,paramsa
,rpa
),
2791 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
) ->
2793 let (lpb
, rpb
) = tuple_of_list2 ii
in
2797 ("Not handling well variable length arguments func. "^
2798 "You have been warned");
2799 tokenf lpa lpb
>>= (fun lpa lpb
->
2800 tokenf rpa rpb
>>= (fun rpa rpb
->
2801 fullType_optional_allminus
allminus tyaopt tyb
>>= (fun tyaopt tyb
->
2802 parameters
(seqstyle paramsa
) (A.undots paramsa
) paramsb
>>=
2803 (fun paramsaundots paramsb
->
2804 let paramsa = redots
paramsa paramsaundots
in
2806 (A.FunctionType
(allminus,tyaopt
,lpa
,paramsa,rpa
) +> A.rewrap ta
,
2807 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), [lpb
;rpb
])
2815 | A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
),
2816 (B.ParenType t1
, ii
) ->
2817 let (lp1b
, rp1b
) = tuple_of_list2 ii
in
2818 let (qu1b
, t1b
) = t1
in
2820 | B.Pointer t2
, ii
->
2821 let (starb
) = tuple_of_list1 ii
in
2822 let (qu2b
, t2b
) = t2
in
2824 | B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
->
2825 let (lp2b
, rp2b
) = tuple_of_list2 ii
in
2830 ("Not handling well variable length arguments func. "^
2831 "You have been warned");
2833 fullType tya tyb
>>= (fun tya tyb
->
2834 tokenf lp1a lp1b
>>= (fun lp1a lp1b
->
2835 tokenf rp1a rp1b
>>= (fun rp1a rp1b
->
2836 tokenf lp2a lp2b
>>= (fun lp2a lp2b
->
2837 tokenf rp2a rp2b
>>= (fun rp2a rp2b
->
2838 tokenf stara starb
>>= (fun stara starb
->
2839 parameters
(seqstyle paramsa) (A.undots
paramsa) paramsb
>>=
2840 (fun paramsaundots paramsb
->
2841 let paramsa = redots
paramsa paramsaundots
in
2845 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))),
2850 (B.Pointer
t2, [starb
]))
2854 (A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
))
2856 (B.ParenType
t1, [lp1b
;rp1b
])
2869 (* todo: handle the iso on optionnal size specifification ? *)
2870 | A.Array
(typa
, ia1
, eaopt
, ia2
), (B.Array
(ebopt
, typb
), ii
) ->
2871 let (ib1, ib2
) = tuple_of_list2 ii
in
2872 fullType typa typb
>>= (fun typa typb
->
2873 option expression eaopt ebopt
>>= (fun eaopt ebopt
->
2874 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2875 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2877 (A.Array
(typa
, ia1
, eaopt
, ia2
)) +> A.rewrap ta
,
2878 (B.Array
(ebopt
, typb
), [ib1;ib2
])
2882 (* todo: could also match a Struct that has provided a name *)
2883 (* This is for the case where the SmPL code contains "struct x", without
2884 a definition. In this case, the name field is always present.
2885 This case is also called from the case for A.StructUnionDef when
2886 a name is present in the C code. *)
2887 | A.StructUnionName
(sua
, Some sa
), (B.StructUnionName
(sub
, sb
), ii
) ->
2888 (* sa is now an ident, not an mcode, old: ... && (term sa) =$= sb *)
2889 let (ib1, ib2
) = tuple_of_list2 ii
in
2890 if equal_structUnion (term sua
) sub
2892 ident DontKnow sa
(sb
, ib2
) >>= (fun sa
(sb
, ib2
) ->
2893 tokenf sua
ib1 >>= (fun sua
ib1 ->
2895 (A.StructUnionName
(sua
, Some sa
)) +> A.rewrap ta
,
2896 (B.StructUnionName
(sub
, sb
), [ib1;ib2
])
2901 | A.StructUnionDef
(ty
, lba
, declsa, rba
),
2902 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
2904 let (ii_sub_sb
, lbb
, rbb
) =
2906 [iisub
; lbb
; rbb
] -> (Common.Left iisub
,lbb
,rbb
)
2907 | [iisub
; iisb
; lbb
; rbb
] -> (Common.Right
(iisub
,iisb
),lbb
,rbb
)
2908 | _
-> failwith
"list of length 3 or 4 expected" in
2911 match (sbopt
,ii_sub_sb
) with
2912 (None
,Common.Left iisub
) ->
2913 (* the following doesn't reconstruct the complete SP code, just
2914 the part that matched *)
2916 match A.unwrap
s with
2918 (match A.unwrap ty
with
2919 A.StructUnionName
(sua
, None
) ->
2920 tokenf sua iisub
>>= (fun sua iisub
->
2923 A.StructUnionName
(sua
, None
) +> A.rewrap
ty)
2925 return (ty,[iisub
]))
2927 | A.DisjType
(disjs
) ->
2929 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
2933 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
2935 (* build a StructUnionName from a StructUnion *)
2936 let fake_su = B.nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) in
2938 fullType
ty fake_su >>= (fun ty fake_su ->
2940 | _nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) ->
2941 return (ty, [iisub
; iisb
])
2942 | _
-> raise Impossible
)
2946 >>= (fun ty ii_sub_sb
->
2948 tokenf lba lbb
>>= (fun lba lbb
->
2949 tokenf rba rbb
>>= (fun rba rbb
->
2950 struct_fields
(A.undots
declsa) declsb
>>=(fun undeclsa declsb
->
2951 let declsa = redots
declsa undeclsa
in
2954 (A.StructUnionDef
(ty, lba
, declsa, rba
)) +> A.rewrap ta
,
2955 (B.StructUnion
(sub
, sbopt
, declsb
),ii_sub_sb
@[lbb
;rbb
])
2959 (* todo? handle isomorphisms ? because Unsigned Int can be match on a
2960 * uint in the C code. But some CEs consists in renaming some types,
2961 * so we don't want apply isomorphisms every time.
2963 | A.TypeName sa
, (B.TypeName
(nameb
, typb
), noii
) ->
2967 | B.RegularName
(sb
, iidb
) ->
2968 let iidb1 = tuple_of_list1 iidb
in
2972 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
2974 (A.TypeName sa
) +> A.rewrap ta
,
2975 (B.TypeName
(B.RegularName
(sb
, [iidb1]), typb
), noii
)
2979 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
2984 | _
, (B.TypeOfExpr e
, ii
) -> fail
2985 | _
, (B.TypeOfType e
, ii
) -> fail
2987 | _
, (B.ParenType e
, ii
) -> fail (* todo ?*)
2988 | A.EnumName
(en
,namea
), (B.EnumName nameb
, ii
) ->
2989 let (ib1,ib2
) = tuple_of_list2 ii
in
2990 ident DontKnow namea
(nameb
, ib2
) >>= (fun namea
(nameb
, ib2
) ->
2991 tokenf en
ib1 >>= (fun en
ib1 ->
2993 (A.EnumName
(en
, namea
)) +> A.rewrap ta
,
2994 (B.EnumName nameb
, [ib1;ib2
])
2997 | _
, (B.Enum _
, _
) -> fail (* todo cocci ?*)
3000 ((B.TypeName _
| B.StructUnionName
(_
, _
) | B.EnumName _
|
3001 B.StructUnion
(_
, _
, _
) |
3002 B.FunctionType _
| B.Array
(_
, _
) | B.Pointer _
|
3008 (* todo: iso on sign, if not mentioned then free. tochange?
3009 * but that require to know if signed int because explicit
3010 * signed int, or because implicit signed int.
3013 and sign signa signb
=
3014 match signa
, signb
with
3015 | None
, None
-> return (None
, [])
3016 | Some signa
, Some
(signb
, ib
) ->
3017 if equal_sign (term signa
) signb
3018 then tokenf signa ib
>>= (fun signa ib
->
3019 return (Some signa
, [ib
])
3025 and minusize_list iixs
=
3026 iixs
+> List.fold_left
(fun acc ii
->
3027 acc
>>= (fun xs ys
->
3028 tokenf minusizer ii
>>= (fun minus ii
->
3029 return (minus
::xs
, ii
::ys
)
3030 ))) (return ([],[]))
3031 >>= (fun _xsminys ys
->
3032 return ((), List.rev ys
)
3035 and storage_optional_allminus
allminus stoa
(stob, iistob
) =
3036 (* "iso-by-absence" for storage, and return type. *)
3037 X.optional_storage_flag
(fun optional_storage
->
3038 match stoa
, stob with
3039 | None
, (stobis
, inline
) ->
3043 minusize_list iistob
>>= (fun () iistob
->
3044 return (None
, (stob, iistob
))
3046 else return (None
, (stob, iistob
))
3049 (match optional_storage
, stobis
with
3050 | false, B.NoSto
-> do_minus ()
3052 | true, B.NoSto
-> do_minus ()
3055 then pr2_once
"USING optional_storage builtin isomorphism";
3059 | Some x
, ((stobis
, inline
)) ->
3060 if equal_storage (term x
) stobis
3064 tokenf x i1
>>= (fun x i1
->
3065 return (Some x
, ((stobis
, inline
), [i1
]))
3067 (* or if have inline ? have to do a split_storage_inline a la
3068 * split_signb_baseb_ii *)
3069 | _
-> raise Impossible
3077 and fullType_optional_allminus
allminus tya retb
=
3082 X.distrf_type
minusizer retb
>>= (fun _x retb
->
3086 else return (None
, retb
)
3088 fullType tya retb
>>= (fun tya retb
->
3089 return (Some tya
, retb
)
3094 (*---------------------------------------------------------------------------*)
3096 and compatible_base_type a signa b
=
3097 let ok = return ((),()) in
3100 | Type_cocci.VoidType
, B.Void
->
3101 assert (signa
=*= None
);
3103 | Type_cocci.CharType
, B.IntType
B.CChar
when signa
=*= None
->
3105 | Type_cocci.CharType
, B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3106 compatible_sign signa signb
3107 | Type_cocci.ShortType
, B.IntType
(B.Si
(signb
, B.CShort
)) ->
3108 compatible_sign signa signb
3109 | Type_cocci.IntType
, B.IntType
(B.Si
(signb
, B.CInt
)) ->
3110 compatible_sign signa signb
3111 | Type_cocci.LongType
, B.IntType
(B.Si
(signb
, B.CLong
)) ->
3112 compatible_sign signa signb
3113 | _
, B.IntType
(B.Si
(signb
, B.CLongLong
)) ->
3114 pr2_once
"no longlong in cocci";
3116 | Type_cocci.FloatType
, B.FloatType
B.CFloat
->
3117 assert (signa
=*= None
);
3119 | Type_cocci.DoubleType
, B.FloatType
B.CDouble
->
3120 assert (signa
=*= None
);
3122 | _
, B.FloatType
B.CLongDouble
->
3123 pr2_once
"no longdouble in cocci";
3125 | Type_cocci.BoolType
, _
-> failwith
"no booltype in C"
3127 | _
, (B.Void
|B.FloatType _
|B.IntType _
) -> fail
3129 and compatible_base_type_meta a signa qua b ii
local =
3131 | Type_cocci.MetaType
(ida
,keep
,inherited
),
3132 B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3133 compatible_sign signa signb
>>= fun _ _
->
3134 let newb = ((qua
, (B.BaseType
(B.IntType
B.CChar
),ii
)),local) in
3135 compatible_type a
newb
3136 | Type_cocci.MetaType
(ida
,keep
,inherited
), B.IntType
(B.Si
(signb
, ty)) ->
3137 compatible_sign signa signb
>>= fun _ _
->
3139 ((qua
, (B.BaseType
(B.IntType
(B.Si
(B.Signed
, ty))),ii
)),local) in
3140 compatible_type a
newb
3141 | _
, B.FloatType
B.CLongDouble
->
3142 pr2_once
"no longdouble in cocci";
3145 | _
, (B.Void
|B.FloatType _
|B.IntType _
) -> fail
3148 and compatible_type a
(b
,local) =
3149 let ok = return ((),()) in
3151 let rec loop = function
3152 | Type_cocci.BaseType a
, (qua
, (B.BaseType b
,ii
)) ->
3153 compatible_base_type a None b
3155 | Type_cocci.SignedT
(signa
,None
), (qua
, (B.BaseType b
,ii
)) ->
3156 compatible_base_type
Type_cocci.IntType
(Some signa
) b
3158 | Type_cocci.SignedT
(signa
,Some
ty), (qua
, (B.BaseType b
,ii
)) ->
3160 Type_cocci.BaseType
ty ->
3161 compatible_base_type
ty (Some signa
) b
3162 | Type_cocci.MetaType
(ida
,keep
,inherited
) ->
3163 compatible_base_type_meta
ty (Some signa
) qua b ii
local
3164 | _
-> failwith
"not possible")
3166 | Type_cocci.Pointer a
, (qub
, (B.Pointer b
, ii
)) ->
3168 | Type_cocci.FunctionPointer a
, _
->
3170 "TODO: function pointer type doesn't store enough information to determine compatability"
3171 | Type_cocci.Array a
, (qub
, (B.Array
(eopt
, b
),ii
)) ->
3172 (* no size info for cocci *)
3174 | Type_cocci.StructUnionName
(sua
, _
, sa
),
3175 (qub
, (B.StructUnionName
(sub
, sb
),ii
)) ->
3176 if equal_structUnion_type_cocci sua sub
&& sa
=$
= sb
3179 | Type_cocci.EnumName
(_
, sa
),
3180 (qub
, (B.EnumName
(sb
),ii
)) ->
3184 | Type_cocci.TypeName sa
, (qub
, (B.TypeName
(namesb
, _typb
),noii
)) ->
3185 let sb = Ast_c.str_of_name namesb
in
3190 | Type_cocci.ConstVol
(qua
, a
), (qub
, b
) ->
3191 if (fst qub
).B.const
&& (fst qub
).B.volatile
3194 pr2_once
("warning: the type is both const & volatile but cocci " ^
3195 "does not handle that");
3201 | Type_cocci.Const
-> (fst qub
).B.const
3202 | Type_cocci.Volatile
-> (fst qub
).B.volatile
3204 then loop (a
,(Ast_c.nQ
, b
))
3207 | Type_cocci.MetaType
(ida
,keep
,inherited
), typb
->
3209 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
3210 X.envf keep inherited
(A.make_mcode ida
, B.MetaTypeVal typb
, max_min)
3214 (* subtil: must be after the MetaType case *)
3215 | a
, (qub
, (B.TypeName
(_namesb
, Some b
), noii
)) ->
3216 (* kind of typedef iso *)
3223 (* for metavariables of type expression *^* *)
3224 | Type_cocci.Unknown
, _
-> ok
3229 B.TypeOfType _
|B.TypeOfExpr _
|B.ParenType _
|
3230 B.EnumName _
|B.StructUnion
(_
, _
, _
)|B.Enum
(_
, _
)
3237 B.StructUnionName
(_
, _
)|
3239 B.Array
(_
, _
)|B.Pointer _
|B.TypeName _
|
3248 and compatible_sign signa signb
=
3249 let ok = return ((),()) in
3250 match signa
, signb
with
3252 | Some
Type_cocci.Signed
, B.Signed
3253 | Some
Type_cocci.Unsigned
, B.UnSigned
3258 and equal_structUnion_type_cocci a b
=
3260 | Type_cocci.Struct
, B.Struct
-> true
3261 | Type_cocci.Union
, B.Union
-> true
3262 | _
, (B.Struct
| B.Union
) -> false
3266 (*---------------------------------------------------------------------------*)
3267 and inc_file
(a
, before_after
) (b
, h_rel_pos
) =
3269 let rec aux_inc (ass
, bss
) passed
=
3273 let passed = List.rev
passed in
3275 (match before_after
, !h_rel_pos
with
3276 | IncludeNothing
, _
-> true
3277 | IncludeMcodeBefore
, Some x
->
3278 List.mem
passed (x
.Ast_c.first_of
)
3280 | IncludeMcodeAfter
, Some x
->
3281 List.mem
passed (x
.Ast_c.last_of
)
3283 (* no info, maybe cos of a #include <xx.h> that was already in a .h *)
3287 | (A.IncPath x
)::xs
, y
::ys
-> x
=$
= y
&& aux_inc (xs
, ys
) (x
::passed)
3288 | _
-> failwith
"IncDots not in last place or other pb"
3293 | A.Local ass
, B.Local bss
->
3294 aux_inc (ass
, bss
) []
3295 | A.NonLocal ass
, B.NonLocal bss
->
3296 aux_inc (ass
, bss
) []
3301 (*---------------------------------------------------------------------------*)
3303 and (define_params
: sequence
->
3304 (A.define_param list
, (string B.wrap
) B.wrap2 list
) matcher
) =
3305 fun seqstyle eas ebs
->
3307 | Unordered
-> failwith
"not handling ooo"
3309 define_paramsbis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
3310 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
3313 (* todo? facto code with argument and parameters ? *)
3314 and define_paramsbis
= fun eas ebs
->
3316 | [], [] -> return ([], [])
3317 | [], eb
::ebs
-> fail
3319 X.all_bound
(A.get_inherited ea
) >&&>
3320 (match A.unwrap ea
, ebs
with
3321 | A.DPdots
(mcode), ys
->
3323 (* '...' can take more or less the beginnings of the arguments *)
3324 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
3325 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
3330 if mcode_contain_plus (mcodekind mcode)
3332 (* failwith "I have no token that I could accroche myself on" *)
3333 else return (dots2metavar mcode, [])
3335 (match Common.last
startxs with
3338 X.distrf_define_params
(dots2metavar mcode) startxs
3340 ) >>= (fun mcode startxs ->
3341 let mcode = metavar2dots mcode in
3342 define_paramsbis
eas endxs
>>= (fun eas endxs
->
3344 (A.DPdots
(mcode) +> A.rewrap ea
) ::eas,
3350 | A.DPComma ia1
, Right ii
::ebs
->
3351 let ib1 = tuple_of_list1 ii
in
3352 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3353 define_paramsbis
eas ebs
>>= (fun eas ebs
->
3355 (A.DPComma ia1
+> A.rewrap ea
)::eas,
3360 | A.DPComma ia1
, ebs
->
3361 if mcode_contain_plus (mcodekind ia1
)
3364 (define_paramsbis
eas ebs
) (* try optional comma trick *)
3366 | (A.OptDParam _
| A.UniqueDParam _
), _
->
3367 failwith
"handling Opt/Unique for define parameters"
3369 | A.DPcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
3371 | A.DParam ida
, (Left
(idb
, ii
))::ebs
->
3372 let ib1 = tuple_of_list1 ii
in
3373 ident DontKnow ida
(idb
, ib1) >>= (fun ida
(idb
, ib1) ->
3374 define_paramsbis
eas ebs
>>= (fun eas ebs
->
3376 (A.DParam ida
)+> A.rewrap ea
:: eas,
3377 (Left
(idb
, [ib1]))::ebs
3380 | _unwrapx
, (Right y
)::ys
-> raise Impossible
3381 | _unwrapx
, [] -> fail
3386 (*****************************************************************************)
3388 (*****************************************************************************)
3390 (* no global solution for positions here, because for a statement metavariable
3391 we want a MetaStmtVal, and for the others, it's not clear what we want *)
3393 let rec (rule_elem_node
: (A.rule_elem
, Control_flow_c.node
) matcher
) =
3396 x
>>= (fun a b
-> return (A.rewrap re a
, F.rewrap node b
))
3398 X.all_bound
(A.get_inherited re
) >&&>
3401 match A.unwrap re
, F.unwrap node
with
3403 (* note: the order of the clauses is important. *)
3405 | _
, F.Enter
| _
, F.Exit
| _
, F.ErrorExit
-> fail2()
3407 (* the metaRuleElem contains just '-' information. We dont need to add
3408 * stuff in the environment. If we need stuff in environment, because
3409 * there is a + S somewhere, then this will be done via MetaStmt, not
3411 * Can match TrueNode/FalseNode/... so must be placed before those cases.
3414 | A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
->
3415 let default = A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
in
3416 (match unwrap_node
with
3418 | F.TrueNode
| F.FalseNode
| F.AfterNode
3419 | F.LoopFallThroughNode
| F.FallThroughNode
3421 if X.mode
=*= PatternMode
3424 if mcode_contain_plus (mcodekind mcode)
3425 then failwith
"try add stuff on fake node"
3426 (* minusize or contextize a fake node is ok *)
3429 | F.EndStatement None
->
3430 if X.mode
=*= PatternMode
then return default
3432 (* DEAD CODE NOW ? only useful in -no_cocci_vs_c_3 ?
3433 if mcode_contain_plus (mcodekind mcode)
3435 let fake_info = Ast_c.fakeInfo() in
3436 distrf distrf_node (mcodekind mcode)
3437 (F.EndStatement (Some fake_info))
3438 else return unwrap_node
3442 | F.EndStatement
(Some i1
) ->
3443 tokenf mcode i1
>>= (fun mcode i1
->
3445 A.MetaRuleElem
(mcode,keep
, inherited
),
3446 F.EndStatement
(Some i1
)
3450 if X.mode
=*= PatternMode
then return default
3451 else failwith
"a MetaRuleElem can't transform a headfunc"
3453 if X.mode
=*= PatternMode
then return default
3455 X.distrf_node
(generalize_mcode mcode) node
>>= (fun mcode node
->
3457 A.MetaRuleElem
(mcode,keep
, inherited
),
3463 (* rene cant have found that a state containing a fake/exit/... should be
3465 * TODO: and F.Fake ?
3467 | _
, F.EndStatement _
| _
, F.CaseNode _
3468 | _
, F.TrueNode
| _
, F.FalseNode
| _
, F.AfterNode
3469 | _
, F.FallThroughNode
| _
, F.LoopFallThroughNode
3473 (* really ? diff between pattern.ml and transformation.ml *)
3474 | _
, F.Fake
-> fail2()
3477 (* cas general: a Meta can match everything. It matches only
3478 * "header"-statement. We transform only MetaRuleElem, not MetaStmt.
3479 * So can't have been called in transform.
3481 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), F.Decl
(_
) -> fail
3483 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), unwrap_node
->
3484 (* todo: should not happen in transform mode *)
3486 (match Control_flow_c.extract_fullstatement node
with
3489 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_stmt stb
) in
3490 X.envf keep inherited
(ida
, Ast_c.MetaStmtVal stb
, max_min)
3492 (* no need tag ida, we can't be called in transform-mode *)
3494 A.MetaStmt
(ida
, keep
, metainfoMaybeTodo
, inherited
),
3502 | A.MetaStmtList _
, _
->
3503 failwith
"not handling MetaStmtList"
3505 | A.TopExp ea
, F.DefineExpr eb
->
3506 expression ea eb
>>= (fun ea eb
->
3512 | A.TopExp ea
, F.DefineType eb
->
3513 (match A.unwrap ea
with
3515 fullType ft eb
>>= (fun ft eb
->
3517 A.TopExp
(A.rewrap ea
(A.TypeExp
(ft
))),
3524 (* It is important to put this case before the one that fails because
3525 * of the lack of the counter part of a C construct in SmPL (for instance
3526 * there is not yet a CaseRange in SmPL). Even if SmPL don't handle
3527 * yet certain constructs, those constructs may contain expression
3528 * that we still want and can transform.
3531 | A.Exp exp
, nodeb
->
3533 (* kind of iso, initialisation vs affectation *)
3535 match A.unwrap exp
, nodeb
with
3536 | A.Assignment
(ea
, op
, eb
, true), F.Decl decl
->
3537 initialisation_to_affectation decl
+> F.rewrap node
3542 (* Now keep fullstatement inside the control flow node,
3543 * so that can then get in a MetaStmtVar the fullstatement to later
3544 * pp back when the S is in a +. But that means that
3545 * Exp will match an Ifnode even if there is no such exp
3546 * inside the condition of the Ifnode (because the exp may
3547 * be deeper, in the then branch). So have to not visit
3548 * all inside a node anymore.
3550 * update: j'ai choisi d'accrocher au noeud du CFG Ã la
3551 * fois le fullstatement et le partialstatement et appeler le
3552 * visiteur que sur le partialstatement.
3555 match Ast_cocci.get_pos re
with
3556 | None
-> expression
3560 Lib_parsing_c.max_min_by_pos
(Lib_parsing_c.ii_of_expr eb
) in
3561 let keep = Type_cocci.Unitary
in
3562 let inherited = false in
3563 let max_min _
= failwith
"no pos" in
3564 X.envf
keep inherited (pos
, B.MetaPosVal
(min
,max
), max_min)
3570 X.cocciExp
expfn exp
node >>= (fun exp
node ->
3578 X.cocciTy fullType
ty node >>= (fun ty node ->
3585 | A.TopInit init
, nodeb
->
3586 X.cocciInit initialiser init
node >>= (fun init
node ->
3594 | A.FunHeader
(mckstart
, allminus, fninfoa
, ida
, oparen
, paramsa, cparen
),
3595 F.FunHeader
({B.f_name
= nameidb
;
3596 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3600 f_old_c_style
= oldstyle
;
3605 then pr2 "OLD STYLE DECL NOT WELL SUPPORTED";
3608 (* fninfoa records the order in which the SP specified the various
3609 information, but this isn't taken into account in the matching.
3610 Could this be a problem for transformation? *)
3613 List.filter
(function A.FStorage
(s) -> true | _
-> false) fninfoa
3614 with [A.FStorage
(s)] -> Some
s | _
-> None
in
3616 match List.filter
(function A.FType
(s) -> true | _
-> false) fninfoa
3617 with [A.FType
(t
)] -> Some t
| _
-> None
in
3619 (match List.filter
(function A.FInline
(i
) -> true | _
-> false) fninfoa
3620 with [A.FInline
(i
)] -> failwith
"not checking inline" | _
-> ());
3622 (match List.filter
(function A.FAttr
(a
) -> true | _
-> false) fninfoa
3623 with [A.FAttr
(a
)] -> failwith
"not checking attributes" | _
-> ());
3626 | ioparenb
::icparenb
::iifakestart
::iistob
->
3628 (* maybe important to put ident as the first tokens to transform.
3629 * It's related to transform_proto. So don't change order
3632 ident_cpp LocalFunction ida nameidb
>>= (fun ida nameidb
->
3633 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
3634 tokenf oparen ioparenb
>>= (fun oparen ioparenb
->
3635 tokenf cparen icparenb
>>= (fun cparen icparenb
->
3636 parameters
(seqstyle paramsa)
3637 (A.undots
paramsa) paramsb
>>=
3638 (fun paramsaundots paramsb
->
3639 let paramsa = redots
paramsa paramsaundots
in
3640 storage_optional_allminus
allminus
3641 stoa (stob, iistob
) >>= (fun stoa (stob, iistob
) ->
3646 ("Not handling well variable length arguments func. "^
3647 "You have been warned");
3649 then minusize_list iidotsb
3650 else return ((),iidotsb
)
3651 ) >>= (fun () iidotsb
->
3653 fullType_optional_allminus
allminus tya retb
>>= (fun tya retb
->
3656 (match stoa with Some st
-> [A.FStorage st
] | None
-> []) ++
3657 (match tya with Some t
-> [A.FType t
] | None
-> [])
3662 A.FunHeader
(mckstart
,allminus,fninfoa,ida
,oparen
,
3664 F.FunHeader
({B.f_name
= nameidb
;
3665 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3669 f_old_c_style
= oldstyle
; (* TODO *)
3671 ioparenb
::icparenb
::iifakestart
::iistob
)
3674 | _
-> raise Impossible
3682 | A.Decl
(mckstart
,allminus,decla
), F.Decl declb
->
3683 declaration
(mckstart
,allminus,decla
) declb
>>=
3684 (fun (mckstart
,allminus,decla
) declb
->
3686 A.Decl
(mckstart
,allminus,decla
),
3691 | A.SeqStart
mcode, F.SeqStart
(st
, level
, i1
) ->
3692 tokenf mcode i1
>>= (fun mcode i1
->
3695 F.SeqStart
(st
, level
, i1
)
3698 | A.SeqEnd
mcode, F.SeqEnd
(level
, i1
) ->
3699 tokenf mcode i1
>>= (fun mcode i1
->
3702 F.SeqEnd
(level
, i1
)
3705 | A.ExprStatement
(ea
, ia1
), F.ExprStatement
(st
, (Some eb
, ii
)) ->
3706 let ib1 = tuple_of_list1 ii
in
3707 expression ea eb
>>= (fun ea eb
->
3708 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3710 A.ExprStatement
(ea
, ia1
),
3711 F.ExprStatement
(st
, (Some eb
, [ib1]))
3716 | A.IfHeader
(ia1
,ia2
, ea
, ia3
), F.IfHeader
(st
, (eb
,ii
)) ->
3717 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3718 expression ea eb
>>= (fun ea eb
->
3719 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3720 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3721 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3723 A.IfHeader
(ia1
, ia2
, ea
, ia3
),
3724 F.IfHeader
(st
, (eb
,[ib1;ib2
;ib3
]))
3727 | A.Else ia
, F.Else ib
->
3728 tokenf ia ib
>>= (fun ia ib
->
3729 return (A.Else ia
, F.Else ib
)
3732 | A.WhileHeader
(ia1
, ia2
, ea
, ia3
), F.WhileHeader
(st
, (eb
, ii
)) ->
3733 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3734 expression ea eb
>>= (fun ea eb
->
3735 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3736 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3737 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3739 A.WhileHeader
(ia1
, ia2
, ea
, ia3
),
3740 F.WhileHeader
(st
, (eb
, [ib1;ib2
;ib3
]))
3743 | A.DoHeader ia
, F.DoHeader
(st
, ib
) ->
3744 tokenf ia ib
>>= (fun ia ib
->
3749 | A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
), F.DoWhileTail
(eb
, ii
) ->
3750 let (ib1, ib2
, ib3
, ib4
) = tuple_of_list4 ii
in
3751 expression ea eb
>>= (fun ea eb
->
3752 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3753 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3754 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3755 tokenf ia4 ib4
>>= (fun ia4 ib4
->
3757 A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
),
3758 F.DoWhileTail
(eb
, [ib1;ib2
;ib3
;ib4
])
3760 | A.IteratorHeader
(ia1
, ia2
, eas, ia3
), F.MacroIterHeader
(st
, ((s,ebs
),ii
))
3762 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3764 ident DontKnow ia1
(s, ib1) >>= (fun ia1
(s, ib1) ->
3765 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3766 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3767 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
3768 let eas = redots
eas easundots
in
3770 A.IteratorHeader
(ia1
, ia2
, eas, ia3
),
3771 F.MacroIterHeader
(st
, ((s,ebs
), [ib1;ib2
;ib3
]))
3776 | A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3777 F.ForHeader
(st
, (((eb1opt
,ib3s
), (eb2opt
,ib4s
), (eb3opt
,ib4vide
)), ii
))
3779 assert (null ib4vide
);
3780 let (ib1, ib2
, ib5
) = tuple_of_list3 ii
in
3781 let ib3 = tuple_of_list1 ib3s
in
3782 let ib4 = tuple_of_list1 ib4s
in
3784 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3785 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3786 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3787 tokenf ia4
ib4 >>= (fun ia4
ib4 ->
3788 tokenf ia5 ib5
>>= (fun ia5 ib5
->
3789 option expression ea1opt eb1opt
>>= (fun ea1opt eb1opt
->
3790 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
3791 option expression ea3opt eb3opt
>>= (fun ea3opt eb3opt
->
3793 A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3794 F.ForHeader
(st
, (((eb1opt
,[ib3]), (eb2opt
,[ib4]), (eb3opt
,[])),
3800 | A.SwitchHeader
(ia1
,ia2
,ea
,ia3
), F.SwitchHeader
(st
, (eb
,ii
)) ->
3801 let (ib1, ib2
, ib3) = tuple_of_list3 ii
in
3802 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3803 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3804 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3805 expression ea eb
>>= (fun ea eb
->
3807 A.SwitchHeader
(ia1
,ia2
,ea
,ia3
),
3808 F.SwitchHeader
(st
, (eb
,[ib1;ib2
;ib3]))
3811 | A.Break
(ia1
, ia2
), F.Break
(st
, ((),ii
)) ->
3812 let (ib1, ib2
) = tuple_of_list2 ii
in
3813 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3814 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3817 F.Break
(st
, ((),[ib1;ib2
]))
3820 | A.Continue
(ia1
, ia2
), F.Continue
(st
, ((),ii
)) ->
3821 let (ib1, ib2
) = tuple_of_list2 ii
in
3822 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3823 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3825 A.Continue
(ia1
, ia2
),
3826 F.Continue
(st
, ((),[ib1;ib2
]))
3829 | A.Return
(ia1
, ia2
), F.Return
(st
, ((),ii
)) ->
3830 let (ib1, ib2
) = tuple_of_list2 ii
in
3831 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3832 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3834 A.Return
(ia1
, ia2
),
3835 F.Return
(st
, ((),[ib1;ib2
]))
3838 | A.ReturnExpr
(ia1
, ea
, ia2
), F.ReturnExpr
(st
, (eb
, ii
)) ->
3839 let (ib1, ib2
) = tuple_of_list2 ii
in
3840 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3841 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3842 expression ea eb
>>= (fun ea eb
->
3844 A.ReturnExpr
(ia1
, ea
, ia2
),
3845 F.ReturnExpr
(st
, (eb
, [ib1;ib2
]))
3850 | A.Include
(incla
,filea
),
3851 F.Include
{B.i_include
= (fileb
, ii
);
3852 B.i_rel_pos
= h_rel_pos
;
3853 B.i_is_in_ifdef
= inifdef
;
3856 assert (copt
=*= None
);
3858 let include_requirment =
3859 match mcodekind incla
, mcodekind filea
with
3860 | A.CONTEXT
(_
, A.BEFORE _
), _
->
3862 | _
, A.CONTEXT
(_
, A.AFTER _
) ->
3868 let (inclb
, iifileb
) = tuple_of_list2 ii
in
3869 if inc_file
(term filea
, include_requirment) (fileb
, h_rel_pos
)
3871 tokenf incla inclb
>>= (fun incla inclb
->
3872 tokenf filea iifileb
>>= (fun filea iifileb
->
3874 A.Include
(incla
, filea
),
3875 F.Include
{B.i_include
= (fileb
, [inclb
;iifileb
]);
3876 B.i_rel_pos
= h_rel_pos
;
3877 B.i_is_in_ifdef
= inifdef
;
3885 | A.DefineHeader
(definea
,ida
,params
), F.DefineHeader
((idb
, ii
), defkind
) ->
3886 let (defineb
, iidb
, ieol
) = tuple_of_list3 ii
in
3887 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
3888 tokenf definea defineb
>>= (fun definea defineb
->
3889 (match A.unwrap params
, defkind
with
3890 | A.NoParams
, B.DefineVar
->
3892 A.NoParams
+> A.rewrap params
,
3895 | A.DParams
(lpa
,eas,rpa
), (B.DefineFunc
(ebs
, ii
)) ->
3896 let (lpb
, rpb
) = tuple_of_list2 ii
in
3897 tokenf lpa lpb
>>= (fun lpa lpb
->
3898 tokenf rpa rpb
>>= (fun rpa rpb
->
3900 define_params
(seqstyle eas) (A.undots
eas) ebs
>>=
3901 (fun easundots ebs
->
3902 let eas = redots
eas easundots
in
3904 A.DParams
(lpa
,eas,rpa
) +> A.rewrap params
,
3905 B.DefineFunc
(ebs
,[lpb
;rpb
])
3909 ) >>= (fun params defkind
->
3911 A.DefineHeader
(definea
, ida
, params
),
3912 F.DefineHeader
((idb
,[defineb
;iidb
;ieol
]),defkind
)
3917 | A.Default
(def
,colon
), F.Default
(st
, ((),ii
)) ->
3918 let (ib1, ib2
) = tuple_of_list2 ii
in
3919 tokenf def
ib1 >>= (fun def
ib1 ->
3920 tokenf colon ib2
>>= (fun colon ib2
->
3922 A.Default
(def
,colon
),
3923 F.Default
(st
, ((),[ib1;ib2
]))
3928 | A.Case
(case
,ea
,colon
), F.Case
(st
, (eb
,ii
)) ->
3929 let (ib1, ib2
) = tuple_of_list2 ii
in
3930 tokenf case
ib1 >>= (fun case
ib1 ->
3931 expression ea eb
>>= (fun ea eb
->
3932 tokenf colon ib2
>>= (fun colon ib2
->
3934 A.Case
(case
,ea
,colon
),
3935 F.Case
(st
, (eb
,[ib1;ib2
]))
3938 (* only occurs in the predicates generated by asttomember *)
3939 | A.DisjRuleElem
eas, _
->
3941 List.fold_left
(fun acc ea
-> acc
>|+|> (rule_elem_node ea
node)) fail)
3942 >>= (fun ea eb
-> return (A.unwrap ea
,F.unwrap eb
))
3944 | _
, F.ExprStatement
(_
, (None
, ii
)) -> fail (* happen ? *)
3946 | A.Label
(id
,dd
), F.Label
(st
, nameb
, ((),ii
)) ->
3947 let (ib2
) = tuple_of_list1 ii
in
3948 ident_cpp DontKnow id nameb
>>= (fun ida nameb
->
3949 tokenf dd ib2
>>= (fun dd ib2
->
3952 F.Label
(st
,nameb
, ((),[ib2
]))
3955 | A.Goto
(goto
,id
,sem
), F.Goto
(st
,nameb
, ((),ii
)) ->
3956 let (ib1,ib3) = tuple_of_list2 ii
in
3957 tokenf goto
ib1 >>= (fun goto
ib1 ->
3958 ident_cpp DontKnow id nameb
>>= (fun id nameb
->
3959 tokenf sem
ib3 >>= (fun sem
ib3 ->
3961 A.Goto
(goto
,id
,sem
),
3962 F.Goto
(st
,nameb
, ((),[ib1;ib3]))
3965 (* have not a counter part in coccinelle, for the moment *)
3966 (* todo?: print a warning at least ? *)
3972 | _
, (F.IfdefEndif _
|F.IfdefElse _
|F.IfdefHeader _
)
3976 (F.MacroStmt
(_
, _
)| F.DefineDoWhileZeroHeader _
| F.EndNode
|F.TopNode
)
3979 (F.Label
(_
, _
, _
)|F.Break
(_
, _
)|F.Continue
(_
, _
)|F.Default
(_
, _
)|
3980 F.Case
(_
, _
)|F.Include _
|F.Goto _
|F.ExprStatement _
|
3981 F.DefineType _
|F.DefineExpr _
|F.DefineTodo
|
3982 F.DefineHeader
(_
, _
)|F.ReturnExpr
(_
, _
)|F.Return
(_
, _
)|F.MacroIterHeader
(_
, _
)|
3983 F.SwitchHeader
(_
, _
)|F.ForHeader
(_
, _
)|F.DoWhileTail _
|F.DoHeader
(_
, _
)|
3984 F.WhileHeader
(_
, _
)|F.Else _
|F.IfHeader
(_
, _
)|
3985 F.SeqEnd
(_
, _
)|F.SeqStart
(_
, _
, _
)|
3986 F.Decl _
|F.FunHeader _
)