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.
24 * Copyright 2005-2010, Ecole des Mines de Nantes, University of Copenhagen
25 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
26 * This file is part of Coccinelle.
28 * Coccinelle is free software: you can redistribute it and/or modify
29 * it under the terms of the GNU General Public License as published by
30 * the Free Software Foundation, according to version 2 of the License.
32 * Coccinelle is distributed in the hope that it will be useful,
33 * but WITHOUT ANY WARRANTY; without even the implied warranty of
34 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
35 * GNU General Public License for more details.
37 * You should have received a copy of the GNU General Public License
38 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
40 * The authors reserve the right to distribute this or future versions of
41 * Coccinelle under other licenses.
45 (* Yoann Padioleau, Julia Lawall
47 * Copyright (C) 2006, 2007, 2008 Ecole des Mines de Nantes
49 * This program is free software; you can redistribute it and/or
50 * modify it under the terms of the GNU General Public License (GPL)
51 * version 2 as published by the Free Software Foundation.
53 * This program is distributed in the hope that it will be useful,
54 * but WITHOUT ANY WARRANTY; without even the implied warranty of
55 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
56 * file license.txt for more details.
58 * This file was part of Coccinelle.
66 module F
= Control_flow_c
68 module Flag
= Flag_matcher
70 (*****************************************************************************)
72 (*****************************************************************************)
73 let pr2, pr2_once
= Common.mk_pr2_wrappers
Flag_matcher.verbose_matcher
75 (*****************************************************************************)
77 (*****************************************************************************)
79 type sequence
= Ordered
| Unordered
82 match A.unwrap eas
with
84 | A.CIRCLES _
-> Unordered
85 | A.STARS _
-> failwith
"not handling stars"
87 let (redots
: 'a
A.dots
-> 'a list
-> 'a
A.dots
)=fun eas easundots
->
89 match A.unwrap eas
with
90 | A.DOTS _
-> A.DOTS easundots
91 | A.CIRCLES _
-> A.CIRCLES easundots
92 | A.STARS _
-> A.STARS easundots
96 let (need_unordered_initialisers
: B.initialiser
B.wrap2 list
-> bool) =
98 ibs
+> List.exists
(fun (ib
, icomma
) ->
99 match B.unwrap ib
with
100 | B.InitDesignators _
109 (* For the #include <linux/...> in the .cocci, need to find where is
110 * the '+' attached to this element, to later find the first concrete
111 * #include <linux/xxx.h> or last one in the serie of #includes in the
114 type include_requirement
=
121 (* todo? put in semantic_c.ml *)
124 | LocalFunction
(* entails Function *)
128 let term mc
= A.unwrap_mcode mc
129 let mcodekind mc
= A.get_mcodekind mc
132 let mcode_contain_plus = function
133 | A.CONTEXT
(_
,A.NOTHING
) -> false
134 | A.CONTEXT _
-> true
135 | A.MINUS
(_
,_
,_
,[]) -> false
136 | A.MINUS
(_
,_
,_
,x
::xs
) -> true
137 | A.PLUS _
-> raise Impossible
139 let mcode_simple_minus = function
140 | A.MINUS
(_
,_
,_
,[]) -> true
144 (* In transformation.ml sometime I build some mcodekind myself and
145 * julia has put None for the pos. But there is no possible raise
146 * NoMatch in those cases because it is for the minusall trick or for
147 * the distribute, so either have to build those pos, in fact a range,
148 * because for the distribute have to erase a fullType with one
149 * mcodekind, or add an argument to tag_with_mck such as "safe" that
150 * don't do the check_pos. Hence this DontCarePos constructor. *)
154 {A.line
= 0; A.column
=0; A.strbef
=[]; A.straft
=[];},
155 (A.MINUS
(A.DontCarePos
,[],-1,[])),
158 let generalize_mcode ia
=
159 let (s1
, i
, mck
, pos
) = ia
in
162 | A.PLUS _
-> raise Impossible
163 | A.CONTEXT
(A.NoPos
,x
) ->
164 A.CONTEXT
(A.DontCarePos
,x
)
165 | A.MINUS
(A.NoPos
,inst
,adj
,x
) ->
166 A.MINUS
(A.DontCarePos
,inst
,adj
,x
)
168 | A.CONTEXT
((A.FixPos _
|A.DontCarePos
), _
)
169 | A.MINUS
((A.FixPos _
|A.DontCarePos
), _
, _
, _
)
173 (s1
, i
, new_mck, pos
)
177 (*---------------------------------------------------------------------------*)
179 (* 0x0 is equivalent to 0, value format isomorphism *)
180 let equal_c_int s1 s2
=
182 int_of_string s1
=|= int_of_string s2
183 with Failure
("int_of_string") ->
188 (*---------------------------------------------------------------------------*)
189 (* Normally A should reuse some types of Ast_c, so those
190 * functions should not exist.
192 * update: but now Ast_c depends on A, so can't make too
193 * A depends on Ast_c, so have to stay with those equal_xxx
197 let equal_unaryOp a b
=
199 | A.GetRef
, B.GetRef
-> true
200 | A.DeRef
, B.DeRef
-> true
201 | A.UnPlus
, B.UnPlus
-> true
202 | A.UnMinus
, B.UnMinus
-> true
203 | A.Tilde
, B.Tilde
-> true
204 | A.Not
, B.Not
-> true
205 | _
, B.GetRefLabel
-> false (* todo cocci? *)
206 | _
, (B.Not
|B.Tilde
|B.UnMinus
|B.UnPlus
|B.DeRef
|B.GetRef
) -> false
210 let equal_arithOp a b
=
212 | A.Plus
, B.Plus
-> true
213 | A.Minus
, B.Minus
-> true
214 | A.Mul
, B.Mul
-> true
215 | A.Div
, B.Div
-> true
216 | A.Mod
, B.Mod
-> true
217 | A.DecLeft
, B.DecLeft
-> true
218 | A.DecRight
, B.DecRight
-> true
219 | A.And
, B.And
-> true
220 | A.Or
, B.Or
-> true
221 | A.Xor
, B.Xor
-> true
222 | _
, (B.Xor
|B.Or
|B.And
|B.DecRight
|B.DecLeft
|B.Mod
|B.Div
|B.Mul
|B.Minus
|B.Plus
)
225 let equal_logicalOp a b
=
227 | A.Inf
, B.Inf
-> true
228 | A.Sup
, B.Sup
-> true
229 | A.InfEq
, B.InfEq
-> true
230 | A.SupEq
, B.SupEq
-> true
231 | A.Eq
, B.Eq
-> true
232 | A.NotEq
, B.NotEq
-> true
233 | A.AndLog
, B.AndLog
-> true
234 | A.OrLog
, B.OrLog
-> true
235 | _
, (B.OrLog
|B.AndLog
|B.NotEq
|B.Eq
|B.SupEq
|B.InfEq
|B.Sup
|B.Inf
)
238 let equal_assignOp a b
=
240 | A.SimpleAssign
, B.SimpleAssign
-> true
241 | A.OpAssign a
, B.OpAssign b
-> equal_arithOp a b
242 | _
, (B.OpAssign _
|B.SimpleAssign
) -> false
244 let equal_fixOp a b
=
246 | A.Dec
, B.Dec
-> true
247 | A.Inc
, B.Inc
-> true
248 | _
, (B.Inc
|B.Dec
) -> false
250 let equal_binaryOp a b
=
252 | A.Arith a
, B.Arith b
-> equal_arithOp a b
253 | A.Logical a
, B.Logical b
-> equal_logicalOp a b
254 | _
, (B.Logical _
| B.Arith _
) -> false
256 let equal_structUnion a b
=
258 | A.Struct
, B.Struct
-> true
259 | A.Union
, B.Union
-> true
260 | _
, (B.Struct
|B.Union
) -> false
264 | A.Signed
, B.Signed
-> true
265 | A.Unsigned
, B.UnSigned
-> true
266 | _
, (B.UnSigned
|B.Signed
) -> false
268 let equal_storage a b
=
270 | A.Static
, B.Sto
B.Static
271 | A.Auto
, B.Sto
B.Auto
272 | A.Register
, B.Sto
B.Register
273 | A.Extern
, B.Sto
B.Extern
275 | _
, (B.NoSto
| B.StoTypedef
) -> false
276 | _
, (B.Sto
(B.Register
|B.Static
|B.Auto
|B.Extern
)) -> false
279 (*---------------------------------------------------------------------------*)
281 let equal_metavarval valu valu'
=
282 match valu
, valu'
with
283 | Ast_c.MetaIdVal
(a
,_
), Ast_c.MetaIdVal
(b
,_
) -> a
=$
= b
284 | Ast_c.MetaFuncVal a
, Ast_c.MetaFuncVal b
-> a
=$
= b
285 | Ast_c.MetaLocalFuncVal a
, Ast_c.MetaLocalFuncVal b
->
286 (* do something more ? *)
289 (* al_expr before comparing !!! and accept when they match.
290 * Note that here we have Astc._expression, so it is a match
291 * modulo isomorphism (there is no metavariable involved here,
292 * just isomorphisms). => TODO call isomorphism_c_c instead of
293 * =*=. Maybe would be easier to transform ast_c in ast_cocci
294 * and call the iso engine of julia. *)
295 | Ast_c.MetaExprVal
(a
,_
), Ast_c.MetaExprVal
(b
,_
) ->
296 Lib_parsing_c.al_expr a
=*= Lib_parsing_c.al_expr b
297 | Ast_c.MetaExprListVal a
, Ast_c.MetaExprListVal b
->
298 Lib_parsing_c.al_arguments a
=*= Lib_parsing_c.al_arguments b
300 | Ast_c.MetaStmtVal a
, Ast_c.MetaStmtVal b
->
301 Lib_parsing_c.al_statement a
=*= Lib_parsing_c.al_statement b
302 | Ast_c.MetaInitVal a
, Ast_c.MetaInitVal b
->
303 Lib_parsing_c.al_init a
=*= Lib_parsing_c.al_init b
304 | Ast_c.MetaTypeVal a
, Ast_c.MetaTypeVal b
->
305 (* old: Lib_parsing_c.al_type a =*= Lib_parsing_c.al_type b *)
308 | Ast_c.MetaListlenVal a
, Ast_c.MetaListlenVal b
-> a
=|= b
310 | Ast_c.MetaParamVal a
, Ast_c.MetaParamVal b
->
311 Lib_parsing_c.al_param a
=*= Lib_parsing_c.al_param b
312 | Ast_c.MetaParamListVal a
, Ast_c.MetaParamListVal b
->
313 Lib_parsing_c.al_params a
=*= Lib_parsing_c.al_params b
315 | Ast_c.MetaPosVal
(posa1
,posa2
), Ast_c.MetaPosVal
(posb1
,posb2
) ->
316 Ast_cocci.equal_pos posa1 posb1
&& Ast_cocci.equal_pos posa2 posb2
318 | Ast_c.MetaPosValList l1
, Ast_c.MetaPosValList l2
->
320 (function (fla
,cea
,posa1
,posa2
) ->
322 (function (flb
,ceb
,posb1
,posb2
) ->
323 fla
=$
= flb
&& cea
=$
= ceb
&&
324 Ast_c.equal_posl posa1 posb1
&& Ast_c.equal_posl posa2 posb2
)
328 | (B.MetaPosValList _
|B.MetaListlenVal _
|B.MetaPosVal _
|B.MetaStmtVal _
329 |B.MetaTypeVal _
|B.MetaInitVal _
330 |B.MetaParamListVal _
|B.MetaParamVal _
|B.MetaExprListVal _
331 |B.MetaExprVal _
|B.MetaLocalFuncVal _
|B.MetaFuncVal _
|B.MetaIdVal _
335 (* probably only one argument needs to be stripped, because inherited
336 metavariables containing expressions are stripped in advance. But don't
337 know which one is which... *)
338 let equal_inh_metavarval valu valu'
=
339 match valu
, valu'
with
340 | Ast_c.MetaIdVal
(a
,_
), Ast_c.MetaIdVal
(b
,_
) -> a
=$
= b
341 | Ast_c.MetaFuncVal a
, Ast_c.MetaFuncVal b
-> a
=$
= b
342 | Ast_c.MetaLocalFuncVal a
, Ast_c.MetaLocalFuncVal b
->
343 (* do something more ? *)
346 (* al_expr before comparing !!! and accept when they match.
347 * Note that here we have Astc._expression, so it is a match
348 * modulo isomorphism (there is no metavariable involved here,
349 * just isomorphisms). => TODO call isomorphism_c_c instead of
350 * =*=. Maybe would be easier to transform ast_c in ast_cocci
351 * and call the iso engine of julia. *)
352 | Ast_c.MetaExprVal
(a
,_
), Ast_c.MetaExprVal
(b
,_
) ->
353 Lib_parsing_c.al_inh_expr a
=*= Lib_parsing_c.al_inh_expr b
354 | Ast_c.MetaExprListVal a
, Ast_c.MetaExprListVal b
->
355 Lib_parsing_c.al_inh_arguments a
=*= Lib_parsing_c.al_inh_arguments b
357 | Ast_c.MetaStmtVal a
, Ast_c.MetaStmtVal b
->
358 Lib_parsing_c.al_inh_statement a
=*= Lib_parsing_c.al_inh_statement b
359 | Ast_c.MetaInitVal a
, Ast_c.MetaInitVal b
->
360 Lib_parsing_c.al_inh_init a
=*= Lib_parsing_c.al_inh_init b
361 | Ast_c.MetaTypeVal a
, Ast_c.MetaTypeVal b
->
362 (* old: Lib_parsing_c.al_inh_type a =*= Lib_parsing_c.al_inh_type b *)
365 | Ast_c.MetaListlenVal a
, Ast_c.MetaListlenVal b
-> a
=|= b
367 | Ast_c.MetaParamVal a
, Ast_c.MetaParamVal b
->
368 Lib_parsing_c.al_param a
=*= Lib_parsing_c.al_param b
369 | Ast_c.MetaParamListVal a
, Ast_c.MetaParamListVal b
->
370 Lib_parsing_c.al_params a
=*= Lib_parsing_c.al_params b
372 | Ast_c.MetaPosVal
(posa1
,posa2
), Ast_c.MetaPosVal
(posb1
,posb2
) ->
373 Ast_cocci.equal_pos posa1 posb1
&& Ast_cocci.equal_pos posa2 posb2
375 | Ast_c.MetaPosValList l1
, Ast_c.MetaPosValList l2
->
377 (function (fla
,cea
,posa1
,posa2
) ->
379 (function (flb
,ceb
,posb1
,posb2
) ->
380 fla
=$
= flb
&& cea
=$
= ceb
&&
381 Ast_c.equal_posl posa1 posb1
&& Ast_c.equal_posl posa2 posb2
)
385 | (B.MetaPosValList _
|B.MetaListlenVal _
|B.MetaPosVal _
|B.MetaStmtVal _
386 |B.MetaTypeVal _
|B.MetaInitVal _
387 |B.MetaParamListVal _
|B.MetaParamVal _
|B.MetaExprListVal _
388 |B.MetaExprVal _
|B.MetaLocalFuncVal _
|B.MetaFuncVal _
|B.MetaIdVal _
393 (*---------------------------------------------------------------------------*)
394 (* could put in ast_c.ml, next to the split/unsplit_comma *)
395 let split_signb_baseb_ii (baseb
, ii
) =
396 let iis = ii
+> List.map
(fun info
-> (B.str_of_info info
), info
) in
397 match baseb
, iis with
399 | B.Void
, ["void",i1
] -> None
, [i1
]
401 | B.FloatType
(B.CFloat
),["float",i1
] -> None
, [i1
]
402 | B.FloatType
(B.CDouble
),["double",i1
] -> None
, [i1
]
403 | B.FloatType
(B.CLongDouble
),["long",i1
;"double",i2
] -> None
,[i1
;i2
]
405 | B.IntType
(B.CChar
), ["char",i1
] -> None
, [i1
]
408 | B.IntType
(B.Si
(sign
, base
)), xs
->
412 | (B.Signed
,(("signed",i1
)::rest
)) -> (Some
(B.Signed
,i1
),rest
)
413 | (B.Signed
,rest
) -> (None
,rest
)
414 | (B.UnSigned
,(("unsigned",i1
)::rest
)) -> (Some
(B.UnSigned
,i1
),rest
)
415 | (B.UnSigned
,rest
) -> (* is this case possible? *) (None
,rest
) in
416 (* The original code only allowed explicit signed and unsigned for char,
417 while this code allows char by itself. Not sure that needs to be
418 checked for here. If it does, then add a special case. *)
420 match (base
,rest
) with
421 B.CInt
, ["int",i1
] -> [i1
]
424 | B.CInt
, ["",i1
] -> (* no type is specified at all *)
425 (match i1
.B.pinfo
with
427 | _
-> failwith
("unrecognized signed int: "^
428 (String.concat
" "(List.map fst
iis))))
430 | B.CChar2
, ["char",i2
] -> [i2
]
432 | B.CShort
, ["short",i1
] -> [i1
]
433 | B.CShort
, ["short",i1
;"int",i2
] -> [i1
;i2
]
435 | B.CLong
, ["long",i1
] -> [i1
]
436 | B.CLong
, ["long",i1
;"int",i2
] -> [i1
;i2
]
438 | B.CLongLong
, ["long",i1
;"long",i2
] -> [i1
;i2
]
439 | B.CLongLong
, ["long",i1
;"long",i2
;"int",i3
] -> [i1
;i2
;i3
]
442 failwith
("strange type1, maybe because of weird order: "^
443 (String.concat
" " (List.map fst
iis))) in
445 | _
-> failwith
("strange type2, maybe because of weird order: "^
446 (String.concat
" " (List.map fst
iis)))
448 (*---------------------------------------------------------------------------*)
450 let rec unsplit_icomma xs
=
454 (match A.unwrap y
with
456 (x
, y
)::unsplit_icomma xs
457 | _
-> failwith
"wrong ast_cocci in initializer"
460 failwith
("wrong ast_cocci in initializer, should have pair " ^
465 let resplit_initialiser ibs iicomma
=
466 match iicomma
, ibs
with
469 failwith
"should have a iicomma, do you generate fakeInfo in parser?"
471 failwith
"shouldn't have a iicomma"
472 | [iicomma
], x
::xs
->
473 let elems = List.map fst
(x
::xs
) in
474 let commas = List.map snd
(x
::xs
) +> List.flatten
in
475 let commas = commas @ [iicomma
] in
477 | _
-> raise Impossible
481 let rec split_icomma xs
=
484 | (x
,y
)::xs
-> x
::y
::split_icomma xs
486 let rec unsplit_initialiser ibs_unsplit
=
487 match ibs_unsplit
with
488 | [] -> [], [] (* empty iicomma *)
490 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
491 (x
, [])::xs
, lastcomma
493 and unsplit_initialiser_bis comma_before
= function
494 | [] -> [], [comma_before
]
496 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
497 (x
, [comma_before
])::xs
, lastcomma
502 (*---------------------------------------------------------------------------*)
503 (* coupling: same in type_annotater_c.ml *)
504 let structdef_to_struct_name ty
=
506 | qu
, (B.StructUnion
(su
, sopt
, fields
), iis) ->
508 | Some s
, [i1
;i2
;i3
;i4
] ->
509 qu
, (B.StructUnionName
(su
, s
), [i1
;i2
])
513 | x
-> raise Impossible
515 | _
-> raise Impossible
517 (*---------------------------------------------------------------------------*)
518 let initialisation_to_affectation decl
=
520 | B.MacroDecl _
-> F.Decl decl
521 | B.DeclList
(xs
, iis) ->
523 (* todo?: should not do that if the variable is an array cos
524 * will have x[] = , mais de toute facon ca sera pas un InitExp
527 | [] -> raise Impossible
529 let ({B.v_namei
= var
;
530 B.v_type
= returnType
;
531 B.v_type_bis
= tybis
;
532 B.v_storage
= storage
;
539 | Some
(name
, iniopt
) ->
541 | Some
(iini
, (B.InitExpr e
, ii_empty2
)) ->
545 Ast_c.NotLocalDecl
-> Ast_c.NotLocalVar
547 Ast_c.LocalVar
(Ast_c.info_of_type returnType
) in
550 (* old: Lib_parsing_c.al_type returnType
551 * but this type has not the typename completed so
552 * instead try to use tybis
555 | Some ty_with_typename_completed
->
556 ty_with_typename_completed
557 | None
-> raise Impossible
561 ref (Some
(typexp,local),
565 Ast_c.mk_e_bis
(B.Ident
(ident)) typ Ast_c.noii
569 (B.Assignment
(idexpr,B.SimpleAssign
, e
)) [iini
] in
577 pr2_once
"TODO: initialisation_to_affectation for multi vars";
578 (* todo? do a fold_left and generate 'x = a, y = b' etc, use
579 * the Sequence expression operator of C and make an
580 * ExprStatement from that.
589 (*****************************************************************************)
590 (* Functor parameter combinators *)
591 (*****************************************************************************)
593 * src: papers on parser combinators in haskell (cf a pearl by meijer in ICFP)
595 * version0: was not tagging the SP, so just tag the C
597 * (tin -> 'c tout) -> ('c -> (tin -> 'b tout)) -> (tin -> 'b tout)
598 * val return : 'b -> tin -> 'b tout
599 * val fail : tin -> 'b tout
601 * version1: now also tag the SP so return a ('a * 'b)
604 type mode
= PatternMode
| TransformMode
612 type ('a
, 'b
) matcher
= 'a
-> 'b
-> tin
-> ('a
* 'b
) tout
617 (tin
-> ('a
* 'b
) tout
) ->
618 ('a
-> 'b
-> (tin
-> ('c
* 'd
) tout
)) ->
619 (tin
-> ('c
* 'd
) tout
)
621 val return
: ('a
* 'b
) -> tin
-> ('a
*'b
) tout
622 val fail
: tin
-> ('a
* 'b
) tout
634 val (>&&>) : (tin
-> bool) -> (tin
-> 'x tout
) -> (tin
-> 'x tout
)
636 val tokenf
: ('a
A.mcode
, B.info
) matcher
637 val tokenf_mck
: (A.mcodekind, B.info
) matcher
640 (A.meta_name
A.mcode
, B.expression
) matcher
642 (A.meta_name
A.mcode
, (Ast_c.argument
, Ast_c.il
) either list
) matcher
644 (A.meta_name
A.mcode
, Ast_c.fullType
) matcher
646 (A.meta_name
A.mcode
,
647 (Ast_c.parameterType
, Ast_c.il
) either list
) matcher
649 (A.meta_name
A.mcode
, Ast_c.parameterType
) matcher
651 (A.meta_name
A.mcode
, Ast_c.initialiser
) matcher
653 (A.meta_name
A.mcode
, Control_flow_c.node
) matcher
655 val distrf_define_params
:
656 (A.meta_name
A.mcode
, (string Ast_c.wrap
, Ast_c.il
) either list
)
659 val distrf_struct_fields
:
660 (A.meta_name
A.mcode
, B.field list
) matcher
663 (A.meta_name
A.mcode
, (B.constant
, string) either
B.wrap
) matcher
666 (A.expression
, B.expression
) matcher
-> (A.expression
, F.node
) matcher
669 (A.expression
, B.expression
) matcher
->
670 (A.expression
, B.expression
) matcher
673 (A.fullType
, B.fullType
) matcher
-> (A.fullType
, F.node
) matcher
676 (A.initialiser
, B.initialiser
) matcher
-> (A.initialiser
, F.node
) matcher
679 A.keep_binding
-> A.inherited
->
680 A.meta_name
A.mcode
* Ast_c.metavar_binding_kind
*
681 (unit -> Common.filename
* string * Ast_c.posl
* Ast_c.posl
) ->
682 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
684 val check_idconstraint
:
685 ('a
-> 'b
-> bool) -> 'a
-> 'b
->
686 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
688 val check_constraints_ne
:
689 ('a
, 'b
) matcher
-> 'a list
-> 'b
->
690 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
692 val all_bound
: A.meta_name list
-> (tin
-> bool)
694 val optional_storage_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
695 val optional_qualifier_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
696 val value_format_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
701 (*****************************************************************************)
702 (* Functor code, "Cocci vs C" *)
703 (*****************************************************************************)
706 functor (X
: PARAM
) ->
709 type ('a
, 'b
) matcher
= 'a
-> 'b
-> X.tin
-> ('a
* 'b
) X.tout
712 let return = X.return
715 let (>||>) = X.(>||>)
716 let (>|+|>) = X.(>|+|>)
717 let (>&&>) = X.(>&&>)
719 let tokenf = X.tokenf
721 (* should be raise Impossible when called from transformation.ml *)
724 | PatternMode
-> fail
725 | TransformMode
-> raise Impossible
728 let (option: ('a
,'b
) matcher
-> ('a
option,'b
option) matcher
)= fun f t1 t2
->
730 | (Some t1
, Some t2
) ->
731 f t1 t2
>>= (fun t1 t2
->
732 return (Some t1
, Some t2
)
734 | (None
, None
) -> return (None
, None
)
737 (* Dots are sometimes used as metavariables, since like metavariables they
738 can match other things. But they no longer have the same type. Perhaps these
739 functions could be avoided by introducing an appropriate level of polymorphism,
740 but I don't know how to declare polymorphism across functors *)
741 let dots2metavar (_
,info
,mcodekind,pos
) =
742 (("","..."),info
,mcodekind,pos
)
743 let metavar2dots (_
,info
,mcodekind,pos
) = ("...",info
,mcodekind,pos
)
745 let satisfies_regexpconstraint c id
: bool =
747 A.IdRegExp
(_
,recompiled
) -> Str.string_match recompiled id
0
748 | A.IdNotRegExp
(_
,recompiled
) -> not
(Str.string_match recompiled id
0)
750 let satisfies_iconstraint c id
: bool =
753 let satisfies_econstraint c exp
: bool =
754 let warning s
= pr2_once
("WARNING: "^s
); false in
755 match Ast_c.unwrap_expr exp
with
756 Ast_c.Ident
(name
) ->
758 Ast_c.RegularName rname
->
759 satisfies_regexpconstraint c
(Ast_c.unwrap_st rname
)
760 | Ast_c.CppConcatenatedName _
->
762 "Unable to apply a constraint on a CppConcatenatedName identifier!"
763 | Ast_c.CppVariadicName _
->
765 "Unable to apply a constraint on a CppVariadicName identifier!"
766 | Ast_c.CppIdentBuilder _
->
768 "Unable to apply a constraint on a CppIdentBuilder identifier!")
769 | Ast_c.Constant cst
->
771 | Ast_c.String
(str
, _
) -> satisfies_regexpconstraint c str
772 | Ast_c.MultiString strlist
->
773 warning "Unable to apply a constraint on an multistring constant!"
774 | Ast_c.Char
(char
, _
) -> satisfies_regexpconstraint c char
775 | Ast_c.Int
(int , _
) -> satisfies_regexpconstraint c
int
776 | Ast_c.Float
(float, _
) -> satisfies_regexpconstraint c
float)
777 | _
-> warning "Unable to apply a constraint on an expression!"
779 (*---------------------------------------------------------------------------*)
791 (*---------------------------------------------------------------------------*)
792 let rec (expression
: (A.expression
, Ast_c.expression
) matcher
) =
794 if A.get_test_exp ea
&& not
(Ast_c.is_test eb
) then fail
796 X.all_bound
(A.get_inherited ea
) >&&>
797 let wa x
= A.rewrap ea x
in
798 match A.unwrap ea
, eb
with
800 (* general case: a MetaExpr can match everything *)
801 | A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
),
802 (((expr
, opttypb
), ii
) as expb
) ->
804 (* old: before have a MetaConst. Now we factorize and use 'form' to
805 * differentiate between different cases *)
806 let rec matches_id = function
807 B.Ident
(name
) -> true
808 | B.Cast
(ty
,e
) -> matches_id (B.unwrap_expr e
)
811 match (form
,expr
) with
814 let rec matches = function
815 B.Constant
(c
) -> true
816 | B.Ident
(nameidb
) ->
817 let s = Ast_c.str_of_name nameidb
in
818 if s =~
"^[A-Z_][A-Z_0-9]*$"
820 pr2_once
("warning: " ^
s ^
" treated as a constant");
824 | B.Cast
(ty
,e
) -> matches (B.unwrap_expr e
)
825 | B.Unary
(e
,B.UnMinus
) -> matches (B.unwrap_expr e
)
826 | B.SizeOfExpr
(exp
) -> true
827 | B.SizeOfType
(ty
) -> true
833 (Some
(_
,Ast_c.LocalVar _
),_
) -> true
835 | (A.ID
,e
) -> matches_id e
in
839 (let (opttypb
,_testb
) = !opttypb
in
840 match opttypa
, opttypb
with
841 | None
, _
-> return ((),())
843 pr2_once
("Missing type information. Certainly a pb in " ^
844 "annotate_typer.ml");
847 | Some tas
, Some tb
->
848 tas
+> List.fold_left
(fun acc ta
->
849 acc
>|+|> compatible_type ta tb
) fail
852 let meta_expr_val l x
= Ast_c.MetaExprVal
(x
,l
) in
853 match constraints
with
854 Ast_cocci.NoConstraint
-> return (meta_expr_val [],())
855 | Ast_cocci.NotIdCstrt cstrt
->
856 X.check_idconstraint
satisfies_econstraint cstrt eb
857 (fun () -> return (meta_expr_val [],()))
858 | Ast_cocci.NotExpCstrt cstrts
->
859 X.check_constraints_ne expression cstrts eb
860 (fun () -> return (meta_expr_val [],()))
861 | Ast_cocci.SubExpCstrt cstrts
->
862 return (meta_expr_val cstrts
,()))
866 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_expr expb
) in
867 X.envf keep inherited
(ida
, wrapper expb
, max_min)
869 X.distrf_e ida expb
>>=
872 A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
)+>
880 * | A.MetaExpr(ida,false,opttypa,_inherited), expb ->
881 * D.distribute_mck (mcodekind ida) D.distribute_mck_e expb binding
883 * but bug! because if have not tagged SP, then transform without doing
884 * any checks. Hopefully now have tagged SP technique.
889 * | A.Edots _, _ -> raise Impossible.
891 * In fact now can also have the Edots inside normal expression, not
892 * just in arg lists. in 'x[...];' less: in if(<... x ... y ...>)
894 | A.Edots
(mcode
, None
), expb
->
895 X.distrf_e
(dots2metavar mcode
) expb
>>= (fun mcode expb
->
897 A.Edots
(metavar2dots mcode
, None
) +> A.rewrap ea
,
902 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
905 | A.Ident ida
, ((B.Ident
(nameidb
), typ),noii
) ->
907 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
909 ((A.Ident ida
)) +> wa,
910 ((B.Ident
(nameidb
), typ),Ast_c.noii
)
916 | A.MetaErr _
, _
-> failwith
"not handling MetaErr"
918 (* todo?: handle some isomorphisms in int/float ? can have different
919 * format : 1l can match a 1.
921 * todo: normally string can contain some metavar too, so should
922 * recurse on the string
924 | A.Constant
(ia1
), ((B.Constant
(ib
) , typ),ii
) ->
925 (* for everything except the String case where can have multi elems *)
927 let ib1 = tuple_of_list1 ii
in
928 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
930 ((A.Constant ia1
)) +> wa,
931 ((B.Constant
(ib
), typ),[ib1])
934 (match term ia1
, ib
with
935 | A.Int x
, B.Int
(y
,_
) ->
936 X.value_format_flag
(fun use_value_equivalence
->
937 if use_value_equivalence
947 | A.Char x
, B.Char
(y
,_
) when x
=$
= y
(* todo: use kind ? *)
949 | A.Float x
, B.Float
(y
,_
) when x
=$
= y
(* todo: use floatType ? *)
952 | A.String sa
, B.String
(sb
,_kind
) when sa
=$
= sb
->
955 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
957 ((A.Constant ia1
)) +> wa,
958 ((B.Constant
(ib
), typ),[ib1])
960 | _
-> fail (* multi string, not handled *)
963 | _
, B.MultiString _
-> (* todo cocci? *) fail
964 | _
, (B.String _
| B.Float _
| B.Char _
| B.Int _
) -> fail
968 | A.FunCall
(ea
, ia1
, eas
, ia2
), ((B.FunCall
(eb
, ebs
), typ),ii
) ->
969 (* todo: do special case to allow IdMetaFunc, cos doing the
970 * recursive call will be too late, match_ident will not have the
971 * info whether it was a function. todo: but how detect when do
972 * x.field = f; how know that f is a Func ? By having computed
973 * some information before the matching!
975 * Allow match with FunCall containing types. Now ast_cocci allow
976 * type in parameter, and morover ast_cocci allow f(...) and those
977 * ... could match type.
979 let (ib1, ib2
) = tuple_of_list2 ii
in
980 expression ea eb
>>= (fun ea eb
->
981 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
982 tokenf ia2 ib2
>>= (fun ia2 ib2
->
983 arguments
(seqstyle eas
) (A.undots eas
) ebs
>>= (fun easundots ebs
->
984 let eas = redots
eas easundots
in
986 ((A.FunCall
(ea
, ia1
, eas, ia2
)) +> wa,
987 ((B.FunCall
(eb
, ebs
),typ), [ib1;ib2
])
993 | A.Assignment
(ea1
, opa
, ea2
, simple
),
994 ((B.Assignment
(eb1
, opb
, eb2
), typ),ii
) ->
995 let (opbi
) = tuple_of_list1 ii
in
996 if equal_assignOp (term opa
) opb
998 expression ea1 eb1
>>= (fun ea1 eb1
->
999 expression ea2 eb2
>>= (fun ea2 eb2
->
1000 tokenf opa opbi
>>= (fun opa opbi
->
1002 ((A.Assignment
(ea1
, opa
, ea2
, simple
))) +> wa,
1003 ((B.Assignment
(eb1
, opb
, eb2
), typ), [opbi
])
1007 | A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
),((B.CondExpr
(eb1
,eb2opt
,eb3
),typ),ii
) ->
1008 let (ib1, ib2
) = tuple_of_list2 ii
in
1009 expression ea1 eb1
>>= (fun ea1 eb1
->
1010 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
1011 expression ea3 eb3
>>= (fun ea3 eb3
->
1012 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1013 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1015 ((A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
))) +> wa,
1016 ((B.CondExpr
(eb1
, eb2opt
, eb3
),typ), [ib1;ib2
])
1019 (* todo?: handle some isomorphisms here ? *)
1020 | A.Postfix
(ea
, opa
), ((B.Postfix
(eb
, opb
), typ),ii
) ->
1021 let opbi = tuple_of_list1 ii
in
1022 if equal_fixOp (term opa
) opb
1024 expression ea eb
>>= (fun ea eb
->
1025 tokenf opa
opbi >>= (fun opa
opbi ->
1027 ((A.Postfix
(ea
, opa
))) +> wa,
1028 ((B.Postfix
(eb
, opb
), typ),[opbi])
1033 | A.Infix
(ea
, opa
), ((B.Infix
(eb
, opb
), typ),ii
) ->
1034 let opbi = tuple_of_list1 ii
in
1035 if equal_fixOp (term opa
) opb
1037 expression ea eb
>>= (fun ea eb
->
1038 tokenf opa
opbi >>= (fun opa
opbi ->
1040 ((A.Infix
(ea
, opa
))) +> wa,
1041 ((B.Infix
(eb
, opb
), typ),[opbi])
1045 | A.Unary
(ea
, opa
), ((B.Unary
(eb
, opb
), typ),ii
) ->
1046 let opbi = tuple_of_list1 ii
in
1047 if equal_unaryOp (term opa
) opb
1049 expression ea eb
>>= (fun ea eb
->
1050 tokenf opa
opbi >>= (fun opa
opbi ->
1052 ((A.Unary
(ea
, opa
))) +> wa,
1053 ((B.Unary
(eb
, opb
), typ),[opbi])
1057 | A.Binary
(ea1
, opa
, ea2
), ((B.Binary
(eb1
, opb
, eb2
), typ),ii
) ->
1058 let opbi = tuple_of_list1 ii
in
1059 if equal_binaryOp (term opa
) opb
1061 expression ea1 eb1
>>= (fun ea1 eb1
->
1062 expression ea2 eb2
>>= (fun ea2 eb2
->
1063 tokenf opa
opbi >>= (fun opa
opbi ->
1065 ((A.Binary
(ea1
, opa
, ea2
))) +> wa,
1066 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1070 | A.Nested
(ea1
, opa
, ea2
), eb
->
1072 expression ea1 eb
>|+|>
1074 ((B.Binary
(eb1
, opb
, eb2
), typ),ii
)
1075 when equal_binaryOp (term opa
) opb
->
1076 let opbi = tuple_of_list1 ii
in
1078 (expression ea1 eb1
>>= (fun ea1 eb1
->
1079 expression ea2 eb2
>>= (fun ea2 eb2
->
1080 tokenf opa
opbi >>= (fun opa
opbi ->
1082 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1083 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1086 (expression ea2 eb1
>>= (fun ea2 eb1
->
1087 expression ea1 eb2
>>= (fun ea1 eb2
->
1088 tokenf opa
opbi >>= (fun opa
opbi ->
1090 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1091 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1094 (loop eb1
>>= (fun ea1 eb1
->
1095 expression ea2 eb2
>>= (fun ea2 eb2
->
1096 tokenf opa
opbi >>= (fun opa
opbi ->
1098 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1099 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1102 (expression ea2 eb1
>>= (fun ea2 eb1
->
1103 loop eb2
>>= (fun ea1 eb2
->
1104 tokenf opa
opbi >>= (fun opa
opbi ->
1106 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1107 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1109 left_to_right >|+|> right_to_left >|+|> in_left >|+|> in_right
1113 (* todo?: handle some isomorphisms here ? (with pointers = Unary Deref) *)
1114 | A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
),((B.ArrayAccess
(eb1
, eb2
), typ),ii
) ->
1115 let (ib1, ib2
) = tuple_of_list2 ii
in
1116 expression ea1 eb1
>>= (fun ea1 eb1
->
1117 expression ea2 eb2
>>= (fun ea2 eb2
->
1118 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1119 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1121 ((A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
))) +> wa,
1122 ((B.ArrayAccess
(eb1
, eb2
),typ), [ib1;ib2
])
1125 (* todo?: handle some isomorphisms here ? *)
1126 | A.RecordAccess
(ea
, ia1
, ida
), ((B.RecordAccess
(eb
, idb
), typ),ii
) ->
1127 let (ib1) = tuple_of_list1 ii
in
1128 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
1129 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1130 expression ea eb
>>= (fun ea eb
->
1132 ((A.RecordAccess
(ea
, ia1
, ida
))) +> wa,
1133 ((B.RecordAccess
(eb
, idb
), typ), [ib1])
1138 | A.RecordPtAccess
(ea
,ia1
,ida
),((B.RecordPtAccess
(eb
, idb
), typ), ii
) ->
1139 let (ib1) = tuple_of_list1 ii
in
1140 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
1141 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1142 expression ea eb
>>= (fun ea eb
->
1144 ((A.RecordPtAccess
(ea
, ia1
, ida
))) +> wa,
1145 ((B.RecordPtAccess
(eb
, idb
), typ), [ib1])
1149 (* todo?: handle some isomorphisms here ?
1150 * todo?: do some iso-by-absence on cast ?
1151 * by trying | ea, B.Case (typb, eb) -> match_e_e ea eb ?
1154 | A.Cast
(ia1
, typa
, ia2
, ea
), ((B.Cast
(typb
, eb
), typ),ii
) ->
1155 let (ib1, ib2
) = tuple_of_list2 ii
in
1156 fullType typa typb
>>= (fun typa typb
->
1157 expression ea eb
>>= (fun ea eb
->
1158 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1159 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1161 ((A.Cast
(ia1
, typa
, ia2
, ea
))) +> wa,
1162 ((B.Cast
(typb
, eb
),typ),[ib1;ib2
])
1165 | A.SizeOfExpr
(ia1
, ea
), ((B.SizeOfExpr
(eb
), typ),ii
) ->
1166 let ib1 = tuple_of_list1 ii
in
1167 expression ea eb
>>= (fun ea eb
->
1168 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1170 ((A.SizeOfExpr
(ia1
, ea
))) +> wa,
1171 ((B.SizeOfExpr
(eb
), typ),[ib1])
1174 | A.SizeOfType
(ia1
, ia2
, typa
, ia3
), ((B.SizeOfType typb
, typ),ii
) ->
1175 let (ib1,ib2
,ib3
) = tuple_of_list3 ii
in
1176 fullType typa typb
>>= (fun typa typb
->
1177 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1178 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1179 tokenf ia3 ib3
>>= (fun ia3 ib3
->
1181 ((A.SizeOfType
(ia1
, ia2
, typa
, ia3
))) +> wa,
1182 ((B.SizeOfType
(typb
),typ),[ib1;ib2
;ib3
])
1186 (* todo? iso ? allow all the combinations ? *)
1187 | A.Paren
(ia1
, ea
, ia2
), ((B.ParenExpr
(eb
), typ),ii
) ->
1188 let (ib1, ib2
) = tuple_of_list2 ii
in
1189 expression ea eb
>>= (fun ea eb
->
1190 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1191 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1193 ((A.Paren
(ia1
, ea
, ia2
))) +> wa,
1194 ((B.ParenExpr
(eb
), typ), [ib1;ib2
])
1197 | A.NestExpr
(starter
,exps
,ender
,None
,true), eb
->
1198 (match A.get_mcodekind starter
with
1199 A.MINUS _
-> failwith
"TODO: only context nests supported"
1201 (match A.unwrap exps
with
1203 X.cocciExpExp expression exp eb
>>= (fun exp eb
->
1206 (starter
,A.rewrap exps
(A.DOTS
[exp
]),ender
,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 let check_constraints constraints idb
=
1279 let meta_id_val l x
= Ast_c.MetaIdVal
(x
,l
) in
1280 match constraints
with
1281 A.IdNoConstraint
-> return (meta_id_val [],())
1282 | A.IdNegIdSet
(str
,meta
) ->
1283 X.check_idconstraint
satisfies_iconstraint str idb
1284 (fun () -> return (meta_id_val meta
,()))
1285 | A.IdRegExpConstraint re
->
1286 X.check_idconstraint
satisfies_regexpconstraint re idb
1287 (fun () -> return (meta_id_val [],())) in
1288 X.all_bound
(A.get_inherited ida
) >&&>
1289 match A.unwrap ida
with
1291 if (term sa
) =$
= idb
then
1292 tokenf sa iib
>>= (fun sa iib
->
1294 ((A.Id sa
)) +> A.rewrap ida
,
1299 | A.MetaId
(mida
,constraints
,keep
,inherited
) ->
1300 check_constraints constraints idb
>>=
1302 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1303 (* use drop_pos for ids so that the pos is not added a second time in
1304 the call to tokenf *)
1305 X.envf keep inherited
(A.drop_pos mida
, wrapper idb
, max_min)
1307 tokenf mida iib
>>= (fun mida iib
->
1309 ((A.MetaId
(mida
, constraints
, keep
, inherited
)) +> A.rewrap ida
,
1314 | A.MetaFunc
(mida
,constraints
,keep
,inherited
) ->
1316 check_constraints constraints idb
>>=
1318 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1319 X.envf keep inherited
(A.drop_pos mida
,Ast_c.MetaFuncVal idb
,max_min)
1321 tokenf mida iib
>>= (fun mida iib
->
1323 ((A.MetaFunc
(mida
,constraints
,keep
,inherited
)))+>A.rewrap ida
,
1328 | LocalFunction
| Function
-> is_function()
1330 failwith
"MetaFunc, need more semantic info about id"
1331 (* the following implementation could possibly be useful, if one
1332 follows the convention that a macro is always in capital letters
1333 and that a macro is not a function.
1334 (if idb =~ "^[A-Z_][A-Z_0-9]*$" then fail else is_function())*)
1337 | A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
) ->
1340 check_constraints constraints idb
>>=
1342 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1343 X.envf keep inherited
1344 (A.drop_pos mida
,Ast_c.MetaLocalFuncVal idb
, max_min)
1346 tokenf mida iib
>>= (fun mida iib
->
1348 ((A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
)))
1354 | DontKnow
-> failwith
"MetaLocalFunc, need more semantic info about id"
1357 | A.OptIdent _
| A.UniqueIdent _
->
1358 failwith
"not handling Opt/Unique for ident"
1362 (* ------------------------------------------------------------------------- *)
1363 and (arguments
: sequence
->
1364 (A.expression list
, Ast_c.argument
Ast_c.wrap2 list
) matcher
) =
1365 fun seqstyle eas ebs
->
1367 | Unordered
-> failwith
"not handling ooo"
1369 arguments_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1370 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1372 (* because '...' can match nothing, need to take care when have
1373 * ', ...' or '...,' as in f(..., X, Y, ...). It must match
1374 * f(1,2) for instance.
1375 * So I have added special cases such as (if startxs = []) and code
1376 * in the Ecomma matching rule.
1378 * old: Must do some try, for instance when f(...,X,Y,...) have to
1379 * test the transfo for all the combinaitions and if multiple transfo
1380 * possible ? pb ? => the type is to return a expression option ? use
1381 * some combinators to help ?
1382 * update: with the tag-SP approach, no more a problem.
1385 and arguments_bis
= fun eas ebs
->
1387 | [], [] -> return ([], [])
1388 | [], eb
::ebs
-> fail
1390 X.all_bound
(A.get_inherited ea
) >&&>
1391 (match A.unwrap ea
, ebs
with
1392 | A.Edots
(mcode
, optexpr
), ys
->
1393 (* todo: if optexpr, then a WHEN and so may have to filter yys *)
1394 if optexpr
<> None
then failwith
"not handling when in argument";
1396 (* '...' can take more or less the beginnings of the arguments *)
1397 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1398 startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
1401 (* allow '...', and maybe its associated ',' to match nothing.
1402 * for the associated ',' see below how we handle the EComma
1407 if mcode_contain_plus (mcodekind mcode
)
1409 (* failwith "I have no token that I could accroche myself on" *)
1410 else return (dots2metavar mcode
, [])
1412 (* subtil: we dont want the '...' to match until the
1413 * comma. cf -test pb_params_iso. We would get at
1414 * "already tagged" error.
1415 * this is because both f (... x, ...) and f (..., x, ...)
1416 * would match a f(x,3) with our "optional-comma" strategy.
1418 (match Common.last startxs
with
1421 X.distrf_args
(dots2metavar mcode
) startxs
1424 >>= (fun mcode startxs
->
1425 let mcode = metavar2dots mcode in
1426 arguments_bis
eas endxs
>>= (fun eas endxs
->
1428 (A.Edots
(mcode, optexpr
) +> A.rewrap ea
) ::eas,
1434 | A.EComma ia1
, Right ii
::ebs
->
1435 let ib1 = tuple_of_list1 ii
in
1436 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1437 arguments_bis
eas ebs
>>= (fun eas ebs
->
1439 (A.EComma ia1
+> A.rewrap ea
)::eas,
1443 | A.EComma ia1
, ebs
->
1444 (* allow ',' to maching nothing. optional comma trick *)
1445 if mcode_contain_plus (mcodekind ia1
)
1447 else arguments_bis
eas ebs
1449 | A.MetaExprList
(ida
,leninfo
,keep
,inherited
),ys
->
1450 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1451 startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
1456 if mcode_contain_plus (mcodekind ida
)
1458 (* failwith "no token that I could accroche myself on" *)
1461 (match Common.last startxs
with
1469 let startxs'
= Ast_c.unsplit_comma
startxs in
1470 let len = List.length
startxs'
in
1473 | Some
(lenname
,lenkeep
,leninherited
) ->
1474 let max_min _
= failwith
"no pos" in
1475 X.envf lenkeep leninherited
1476 (lenname
, Ast_c.MetaListlenVal
(len), max_min)
1477 | None
-> function f
-> f
()
1481 Lib_parsing_c.lin_col_by_pos
1482 (Lib_parsing_c.ii_of_args
startxs) in
1483 X.envf keep inherited
1484 (ida
, Ast_c.MetaExprListVal
startxs'
, max_min)
1487 then return (ida
, [])
1488 else X.distrf_args ida
(Ast_c.split_comma
startxs'
)
1490 >>= (fun ida
startxs ->
1491 arguments_bis
eas endxs
>>= (fun eas endxs
->
1493 (A.MetaExprList
(ida
,leninfo
,keep
,inherited
))
1494 +> A.rewrap ea
::eas,
1502 | _unwrapx
, (Left eb
)::ebs
->
1503 argument ea eb
>>= (fun ea eb
->
1504 arguments_bis
eas ebs
>>= (fun eas ebs
->
1505 return (ea
::eas, Left eb
::ebs
)
1507 | _unwrapx
, (Right y
)::ys
-> raise Impossible
1508 | _unwrapx
, [] -> fail
1512 and argument arga argb
=
1513 X.all_bound
(A.get_inherited arga
) >&&>
1514 match A.unwrap arga
, argb
with
1516 Right
(B.ArgType
{B.p_register
=b
,iib
; p_namei
=sopt
;p_type
=tyb
}) ->
1518 if b
|| sopt
<> None
1520 (* failwith "the argument have a storage and ast_cocci does not have"*)
1523 (* b = false and sopt = None *)
1524 fullType tya tyb
>>= (fun tya tyb
->
1526 (A.TypeExp tya
) +> A.rewrap arga
,
1527 (Right
(B.ArgType
{B.p_register
=(b
,iib
);
1532 | A.TypeExp tya
, _
-> fail
1533 | _
, Right
(B.ArgType _
) -> fail
1535 expression arga argb
>>= (fun arga argb
->
1536 return (arga
, Left argb
)
1538 | _
, Right
(B.ArgAction y
) -> fail
1541 (* ------------------------------------------------------------------------- *)
1542 (* todo? facto code with argument ? *)
1543 and (parameters
: sequence
->
1544 (A.parameterTypeDef list
, Ast_c.parameterType
Ast_c.wrap2 list
)
1546 fun seqstyle eas ebs
->
1548 | Unordered
-> failwith
"not handling ooo"
1550 parameters_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1551 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1555 and parameters_bis
eas ebs
=
1557 | [], [] -> return ([], [])
1558 | [], eb
::ebs
-> fail
1560 (* the management of positions is inlined into each case, because
1561 sometimes there is a Param and sometimes a ParamList *)
1562 X.all_bound
(A.get_inherited ea
) >&&>
1563 (match A.unwrap ea
, ebs
with
1564 | A.Pdots
(mcode), ys
->
1566 (* '...' can take more or less the beginnings of the arguments *)
1567 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1568 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
1573 if mcode_contain_plus (mcodekind mcode)
1575 (* failwith "I have no token that I could accroche myself on"*)
1576 else return (dots2metavar mcode, [])
1578 (match Common.last
startxs with
1581 X.distrf_params
(dots2metavar mcode) startxs
1583 ) >>= (fun mcode startxs ->
1584 let mcode = metavar2dots mcode in
1585 parameters_bis
eas endxs
>>= (fun eas endxs
->
1587 (A.Pdots
(mcode) +> A.rewrap ea
) ::eas,
1593 | A.PComma ia1
, Right ii
::ebs
->
1594 let ib1 = tuple_of_list1 ii
in
1595 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1596 parameters_bis
eas ebs
>>= (fun eas ebs
->
1598 (A.PComma ia1
+> A.rewrap ea
)::eas,
1603 | A.PComma ia1
, ebs
->
1604 (* try optional comma trick *)
1605 if mcode_contain_plus (mcodekind ia1
)
1607 else parameters_bis
eas ebs
1610 | A.MetaParamList
(ida
,leninfo
,keep
,inherited
),ys
->
1611 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1612 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
1617 if mcode_contain_plus (mcodekind ida
)
1619 (* failwith "I have no token that I could accroche myself on" *)
1622 (match Common.last
startxs with
1630 let startxs'
= Ast_c.unsplit_comma
startxs in
1631 let len = List.length
startxs'
in
1634 Some
(lenname
,lenkeep
,leninherited
) ->
1635 let max_min _
= failwith
"no pos" in
1636 X.envf lenkeep leninherited
1637 (lenname
, Ast_c.MetaListlenVal
(len), max_min)
1638 | None
-> function f
-> f
()
1642 Lib_parsing_c.lin_col_by_pos
1643 (Lib_parsing_c.ii_of_params
startxs) in
1644 X.envf keep inherited
1645 (ida
, Ast_c.MetaParamListVal
startxs'
, max_min)
1648 then return (ida
, [])
1649 else X.distrf_params ida
(Ast_c.split_comma
startxs'
)
1650 ) >>= (fun ida
startxs ->
1651 parameters_bis
eas endxs
>>= (fun eas endxs
->
1653 (A.MetaParamList
(ida
,leninfo
,keep
,inherited
))
1654 +> A.rewrap ea
::eas,
1662 | A.VoidParam ta
, ys
->
1663 (match eas, ebs
with
1665 let {B.p_register
=(hasreg
,iihasreg
);
1667 p_type
=tb
; } = eb
in
1669 if idbopt
=*= None
&& not hasreg
1672 | (qub
, (B.BaseType
B.Void
,_
)) ->
1673 fullType ta tb
>>= (fun ta tb
->
1675 [(A.VoidParam ta
) +> A.rewrap ea
],
1676 [Left
{B.p_register
=(hasreg
, iihasreg
);
1685 | (A.OptParam _
| A.UniqueParam _
), _
->
1686 failwith
"handling Opt/Unique for Param"
1688 | A.Pcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
1691 | A.MetaParam
(ida
,keep
,inherited
), (Left eb
)::ebs
->
1692 (* todo: use quaopt, hasreg ? *)
1694 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_param eb
) in
1695 X.envf keep inherited
(ida
,Ast_c.MetaParamVal eb
,max_min) (fun () ->
1696 X.distrf_param ida eb
1697 ) >>= (fun ida eb
->
1698 parameters_bis
eas ebs
>>= (fun eas ebs
->
1700 (A.MetaParam
(ida
,keep
,inherited
))+> A.rewrap ea
::eas,
1705 | A.Param
(typa
, idaopt
), (Left eb
)::ebs
->
1706 (*this should succeed if the C code has a name, and fail otherwise*)
1707 parameter
(idaopt
, typa
) eb
>>= (fun (idaopt
, typa
) eb
->
1708 parameters_bis
eas ebs
>>= (fun eas ebs
->
1710 (A.Param
(typa
, idaopt
))+> A.rewrap ea
:: eas,
1714 | _unwrapx
, (Right y
)::ys
-> raise Impossible
1715 | _unwrapx
, [] -> fail
1721 let split_register_param = fun (hasreg, idb, ii_b_s) ->
1722 match hasreg, idb, ii_b_s with
1723 | false, Some s, [i1] -> Left (s, [], i1)
1724 | true, Some s, [i1;i2] -> Left (s, [i1], i2)
1725 | _, None, ii -> Right ii
1726 | _ -> raise Impossible
1730 and parameter
= fun (idaopt
, typa
) paramb
->
1732 let {B.p_register
= (hasreg
,iihasreg
);
1733 p_namei
= nameidbopt
;
1734 p_type
= typb
;} = paramb
in
1736 fullType typa typb
>>= (fun typa typb
->
1737 match idaopt
, nameidbopt
with
1738 | Some ida
, Some nameidb
->
1739 (* todo: if minus on ida, should also minus the iihasreg ? *)
1740 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1743 {B.p_register
= (hasreg
, iihasreg
);
1744 p_namei
= Some
(nameidb
);
1751 {B.p_register
=(hasreg
,iihasreg
);
1757 (* why handle this case ? because of transform_proto ? we may not
1758 * have an ident in the proto.
1759 * If have some plus on ida ? do nothing about ida ?
1761 (* not anymore !!! now that julia is handling the proto.
1762 | _, Right iihasreg ->
1765 ((hasreg, None, typb), iihasreg)
1769 | Some _
, None
-> fail
1770 | None
, Some _
-> fail
1776 (* ------------------------------------------------------------------------- *)
1777 and (declaration
: (A.mcodekind * bool * A.declaration
,B.declaration
) matcher
) =
1778 fun (mckstart
, allminus
, decla
) declb
->
1779 X.all_bound
(A.get_inherited decla
) >&&>
1780 match A.unwrap decla
, declb
with
1782 (* Un MetaDecl est introduit dans l'asttoctl pour sauter au dessus
1783 * de toutes les declarations qui sont au debut d'un fonction et
1784 * commencer le reste du match au premier statement. Alors, ca matche
1785 * n'importe quelle declaration. On n'a pas besoin d'ajouter
1786 * quoi que ce soit dans l'environnement. C'est une sorte de DDots.
1788 * When the SP want to remove the whole function, the minus is not
1789 * on the MetaDecl but on the MetaRuleElem. So there should
1790 * be no transform of MetaDecl, just matching are allowed.
1793 | A.MetaDecl
(ida
,_keep
,_inherited
), _
-> (* keep ? inherited ? *)
1794 (* todo: should not happen in transform mode *)
1795 return ((mckstart
, allminus
, decla
), declb
)
1799 | _
, (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
)) ->
1800 onedecl allminus decla
(var
,iiptvirgb
,iisto
) >>=
1801 (fun decla
(var
,iiptvirgb
,iisto
)->
1802 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1804 (mckstart
, allminus
, decla
),
1805 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1808 | _
, (B.DeclList
(xs
, iiptvirgb
::iifakestart
::iisto
)) ->
1809 if X.mode
=*= PatternMode
1811 xs
+> List.fold_left
(fun acc var
->
1813 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1814 onedecl allminus decla
(var
, iiptvirgb
, iisto
) >>=
1815 (fun decla
(var
, iiptvirgb
, iisto
) ->
1817 (mckstart
, allminus
, decla
),
1818 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1822 failwith
"More that one variable in decl. Have to split to transform."
1824 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
), B.MacroDecl
((sb
,ebs
),ii
) ->
1825 let (iisb
, lpb
, rpb
, iiendb
, iifakestart
, iistob
) =
1827 | iisb
::lpb
::rpb
::iiendb
::iifakestart
::iisto
->
1828 (iisb
,lpb
,rpb
,iiendb
, iifakestart
,iisto
)
1829 | _
-> raise Impossible
1832 then minusize_list iistob
1833 else return ((), iistob
)
1834 ) >>= (fun () iistob
->
1836 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1837 ident DontKnow sa
(sb
, iisb
) >>= (fun sa
(sb
, iisb
) ->
1838 tokenf lpa lpb
>>= (fun lpa lpb
->
1839 tokenf rpa rpb
>>= (fun rpa rpb
->
1840 tokenf enda iiendb
>>= (fun enda iiendb
->
1841 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
1842 let eas = redots
eas easundots
in
1845 (mckstart
, allminus
,
1846 (A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
)) +> A.rewrap decla
),
1847 (B.MacroDecl
((sb
,ebs
),
1848 [iisb
;lpb
;rpb
;iiendb
;iifakestart
] ++ iistob
))
1851 | _
, (B.MacroDecl _
|B.DeclList _
) -> fail
1854 and onedecl
= fun allminus decla
(declb
, iiptvirgb
, iistob
) ->
1855 X.all_bound
(A.get_inherited decla
) >&&>
1856 match A.unwrap decla
, declb
with
1858 (* kind of typedef iso, we must unfold, it's for the case
1859 * T { }; that we want to match against typedef struct { } xx_t;
1861 | A.TyDecl
(tya0
, ptvirga
),
1862 ({B.v_namei
= Some
(nameidb
, None
);
1864 B.v_storage
= (B.StoTypedef
, inl
);
1867 B.v_type_bis
= typb0bis
;
1870 (match A.unwrap tya0
, typb0
with
1871 | A.Type
(cv1
,tya1
), ((qu
,il
),typb1
) ->
1873 (match A.unwrap tya1
, typb1
with
1874 | A.StructUnionDef
(tya2
, lba
, declsa
, rba
),
1875 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
1877 let (iisub
, iisbopt
, lbb
, rbb
) =
1880 let (iisub
, lbb
, rbb
) = tuple_of_list3 ii
in
1881 (iisub
, [], lbb
, rbb
)
1884 "warning: both a typedef (%s) and struct name introduction (%s)"
1885 (Ast_c.str_of_name nameidb
) s
1887 pr2 "warning: I will consider only the typedef";
1888 let (iisub
, iisb
, lbb
, rbb
) = tuple_of_list4 ii
in
1889 (iisub
, [iisb
], lbb
, rbb
)
1892 structdef_to_struct_name
1893 (Ast_c.nQ
, (B.StructUnion
(sub
, sbopt
, declsb
), ii
))
1896 Ast_c.nQ
,((B.TypeName
(nameidb
, Some
1897 (Lib_parsing_c.al_type
structnameb))), [])
1900 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1901 tokenf lba lbb
>>= (fun lba lbb
->
1902 tokenf rba rbb
>>= (fun rba rbb
->
1903 struct_fields
(A.undots declsa
) declsb
>>=(fun undeclsa declsb
->
1904 let declsa = redots
declsa undeclsa
in
1906 (match A.unwrap tya2
with
1907 | A.Type
(cv3
, tya3
) ->
1908 (match A.unwrap tya3
with
1909 | A.MetaType
(ida
,keep
, inherited
) ->
1911 fullType tya2
fake_typeb >>= (fun tya2
fake_typeb ->
1913 A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1 in
1914 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1917 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1918 [iisub
] @ iisbopt
@ [lbb
;rbb
] in
1919 let typb0 = ((qu
, il
), typb1) in
1921 match fake_typeb with
1922 | _nQ
, ((B.TypeName
(nameidb
, _typ
)),[]) ->
1925 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1926 (({B.v_namei
= Some
(nameidb
, None
);
1928 B.v_storage
= (B.StoTypedef
, inl
);
1931 B.v_type_bis
= typb0bis
;
1933 iivirg
),iiptvirgb
,iistob
)
1935 | _
-> raise Impossible
1938 | A.StructUnionName
(sua
, sa
) ->
1940 fullType tya2
structnameb >>= (fun tya2
structnameb ->
1942 let tya1 = A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1
1944 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1946 match structnameb with
1947 | _nQ
, (B.StructUnionName
(sub
, s), [iisub
;iisbopt
]) ->
1949 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1950 [iisub
;iisbopt
;lbb
;rbb
] in
1951 let typb0 = ((qu
, il
), typb1) in
1954 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1955 (({B.v_namei
= Some
(nameidb
, None
);
1957 B.v_storage
= (B.StoTypedef
, inl
);
1960 B.v_type_bis
= typb0bis
;
1962 iivirg
),iiptvirgb
,iistob
)
1964 | _
-> raise Impossible
1966 | _
-> raise Impossible
1975 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1976 ({B.v_namei
= Some
(nameidb
, _
);B.v_storage
= (B.StoTypedef
,_
);}, iivirg
)
1979 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1980 ({B.v_namei
=Some
(nameidb
, _
);B.v_storage
=(B.StoTypedef
,_
);}, iivirg
)
1985 (* could handle iso here but handled in standard.iso *)
1986 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1987 ({B.v_namei
= Some
(nameidb
, None
);
1992 B.v_type_bis
= typbbis
;
1995 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1996 fullType typa typb
>>= (fun typa typb
->
1997 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1998 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1999 (fun stoa
(stob
, iistob
) ->
2001 (A.UnInit
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
2002 (({B.v_namei
= Some
(nameidb
, None
);
2007 B.v_type_bis
= typbbis
;
2012 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
2013 ({B.v_namei
= Some
(nameidb
, Some
(iieqb
, inib
));
2018 B.v_type_bis
= typbbis
;
2021 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2022 tokenf eqa iieqb
>>= (fun eqa iieqb
->
2023 fullType typa typb
>>= (fun typa typb
->
2024 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
2025 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
2026 (fun stoa
(stob
, iistob
) ->
2027 initialiser inia inib
>>= (fun inia inib
->
2029 (A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
)) +> A.rewrap decla
,
2030 (({B.v_namei
= Some
(nameidb
, Some
(iieqb
, inib
));
2035 B.v_type_bis
= typbbis
;
2040 (* do iso-by-absence here ? allow typedecl and var ? *)
2041 | A.TyDecl
(typa
, ptvirga
),
2042 ({B.v_namei
= None
; B.v_type
= typb
;
2046 B.v_type_bis
= typbbis
;
2049 if stob
=*= (B.NoSto
, false)
2051 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2052 fullType typa typb
>>= (fun typa typb
->
2054 (A.TyDecl
(typa
, ptvirga
)) +> A.rewrap decla
,
2055 (({B.v_namei
= None
;
2060 B.v_type_bis
= typbbis
;
2061 }, iivirg
), iiptvirgb
, iistob
)
2066 | A.Typedef
(stoa
, typa
, ida
, ptvirga
),
2067 ({B.v_namei
= Some
(nameidb
, None
);
2069 B.v_storage
= (B.StoTypedef
,inline
);
2072 B.v_type_bis
= typbbis
;
2075 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2076 fullType typa typb
>>= (fun typa typb
->
2079 tokenf stoa iitypedef
>>= (fun stoa iitypedef
->
2080 return (stoa
, [iitypedef
])
2082 | _
-> failwith
"weird, have both typedef and inline or nothing";
2083 ) >>= (fun stoa iistob
->
2084 (match A.unwrap ida
with
2085 | A.MetaType
(_
,_
,_
) ->
2088 Ast_c.nQ
, ((B.TypeName
(nameidb
, Ast_c.noTypedefDef
())), [])
2090 fullTypebis ida
fake_typeb >>= (fun ida
fake_typeb ->
2091 match fake_typeb with
2092 | _nQ
, ((B.TypeName
(nameidb
, _typ
)), []) ->
2093 return (ida
, nameidb
)
2094 | _
-> raise Impossible
2099 | B.RegularName
(sb
, iidb
) ->
2100 let iidb1 = tuple_of_list1 iidb
in
2104 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
2106 (A.TypeName sa
) +> A.rewrap ida
,
2107 B.RegularName
(sb
, [iidb1])
2111 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
2115 | _
-> raise Impossible
2117 ) >>= (fun ida nameidb
->
2119 (A.Typedef
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
2120 (({B.v_namei
= Some
(nameidb
, None
);
2122 B.v_storage
= (B.StoTypedef
,inline
);
2125 B.v_type_bis
= typbbis
;
2133 | _
, ({B.v_namei
= None
;}, _
) ->
2134 (* old: failwith "no variable in this declaration, weird" *)
2139 | A.DisjDecl declas
, declb
->
2140 declas
+> List.fold_left
(fun acc decla
->
2142 (* (declaration (mckstart, allminus, decla) declb) *)
2143 (onedecl allminus decla
(declb
,iiptvirgb
, iistob
))
2148 (* only in struct type decls *)
2149 | A.Ddots
(dots
,whencode
), _
->
2152 | A.OptDecl _
, _
| A.UniqueDecl _
, _
->
2153 failwith
"not handling Opt/Unique Decl"
2155 | _
, ({B.v_namei
=Some _
}, _
) ->
2161 (* ------------------------------------------------------------------------- *)
2163 and (initialiser
: (A.initialiser
, Ast_c.initialiser
) matcher
) = fun ia ib
->
2164 X.all_bound
(A.get_inherited ia
) >&&>
2165 match (A.unwrap ia
,ib
) with
2167 | (A.MetaInit
(ida
,keep
,inherited
), ib
) ->
2169 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_ini ib
) in
2170 X.envf keep inherited
(ida
, Ast_c.MetaInitVal ib
, max_min)
2172 X.distrf_ini ida ib
>>= (fun ida ib
->
2174 A.MetaInit
(ida
,keep
,inherited
) +> A.rewrap ia
,
2179 | (A.InitExpr expa
, ib
) ->
2180 (match A.unwrap expa
, ib
with
2181 | A.Edots
(mcode, None
), ib
->
2182 X.distrf_ini
(dots2metavar mcode) ib
>>= (fun mcode ib
->
2185 (A.Edots
(metavar2dots mcode, None
) +> A.rewrap expa
)
2190 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
2192 | _
, (B.InitExpr expb
, ii
) ->
2194 expression expa expb
>>= (fun expa expb
->
2196 (A.InitExpr expa
) +> A.rewrap ia
,
2197 (B.InitExpr expb
, ii
)
2202 | (A.InitList
(ia1
, ias
, ia2
, []), (B.InitList ibs
, ii
)) ->
2204 | ib1::ib2
::iicommaopt
->
2205 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2206 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2207 initialisers ias
(ibs
, iicommaopt
) >>= (fun ias
(ibs
,iicommaopt
) ->
2209 (A.InitList
(ia1
, ias
, ia2
, [])) +> A.rewrap ia
,
2210 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2213 | _
-> raise Impossible
2216 | (A.InitList
(i1
, ias
, i2
, whencode
),(B.InitList ibs
, _ii
)) ->
2217 failwith
"TODO: not handling whencode in initialisers"
2220 | (A.InitGccExt
(designatorsa
, ia2
, inia
),
2221 (B.InitDesignators
(designatorsb
, inib
), ii2
))->
2223 let iieq = tuple_of_list1 ii2
in
2225 tokenf ia2
iieq >>= (fun ia2
iieq ->
2226 designators designatorsa designatorsb
>>=
2227 (fun designatorsa designatorsb
->
2228 initialiser inia inib
>>= (fun inia inib
->
2230 (A.InitGccExt
(designatorsa
, ia2
, inia
)) +> A.rewrap ia
,
2231 (B.InitDesignators
(designatorsb
, inib
), [iieq])
2237 | (A.InitGccName
(ida
, ia1
, inia
), (B.InitFieldOld
(idb
, inib
), ii
)) ->
2240 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2241 initialiser inia inib
>>= (fun inia inib
->
2242 tokenf ia1 iicolon
>>= (fun ia1 iicolon
->
2244 (A.InitGccName
(ida
, ia1
, inia
)) +> A.rewrap ia
,
2245 (B.InitFieldOld
(idb
, inib
), [iidb
;iicolon
])
2252 | A.IComma
(comma
), _
->
2255 | A.UniqueIni _
,_
| A.OptIni _
,_
->
2256 failwith
"not handling Opt/Unique on initialisers"
2258 | _
, (B.InitIndexOld
(_
, _
), _
) -> fail
2259 | _
, (B.InitFieldOld
(_
, _
), _
) -> fail
2261 | _
, ((B.InitDesignators
(_
, _
)|B.InitList _
|B.InitExpr _
), _
)
2264 and designators dla dlb
=
2265 match (dla
,dlb
) with
2266 ([],[]) -> return ([], [])
2267 | ([],_
) | (_
,[]) -> fail
2268 | (da
::dla
,db
::dlb
) ->
2269 designator da db
>>= (fun da db
->
2270 designators dla dlb
>>= (fun dla dlb
->
2271 return (da
::dla
, db
::dlb
)))
2273 and designator da db
=
2275 (A.DesignatorField
(ia1
, ida
), (B.DesignatorField idb
,ii1
)) ->
2277 let (iidot
, iidb
) = tuple_of_list2 ii1
in
2278 tokenf ia1 iidot
>>= (fun ia1 iidot
->
2279 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2281 A.DesignatorField
(ia1
, ida
),
2282 (B.DesignatorField idb
, [iidot
;iidb
])
2285 | (A.DesignatorIndex
(ia1
,ea
,ia2
), (B.DesignatorIndex eb
, ii1
)) ->
2287 let (ib1, ib2
) = tuple_of_list2 ii1
in
2288 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2289 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2290 expression ea eb
>>= (fun ea eb
->
2292 A.DesignatorIndex
(ia1
,ea
,ia2
),
2293 (B.DesignatorIndex eb
, [ib1;ib2
])
2296 | (A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2297 (B.DesignatorRange
(e1b
, e2b
), ii1
)) ->
2299 let (ib1, ib2
, ib3
) = tuple_of_list3 ii1
in
2300 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2301 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2302 tokenf ia3 ib3
>>= (fun ia3 ib3
->
2303 expression e1a e1b
>>= (fun e1a e1b
->
2304 expression e2a e2b
>>= (fun e2a e2b
->
2306 A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2307 (B.DesignatorRange
(e1b
, e2b
), [ib1;ib2
;ib3
])
2309 | (_
, ((B.DesignatorField _
|B.DesignatorIndex _
|B.DesignatorRange _
), _
)) ->
2313 and initialisers
= fun ias
(ibs
, iicomma
) ->
2314 let ias_unsplit = unsplit_icomma ias
in
2315 let ibs_split = resplit_initialiser ibs iicomma
in
2318 if need_unordered_initialisers ibs
2319 then initialisers_unordered2
2320 else initialisers_ordered2
2322 f ias_unsplit ibs_split >>=
2323 (fun ias_unsplit ibs_split ->
2325 split_icomma ias_unsplit,
2326 unsplit_initialiser ibs_split
2330 (* todo: one day julia will reput a IDots *)
2331 and initialisers_ordered2
= fun ias ibs
->
2333 | [], [] -> return ([], [])
2334 | (x
, xcomma
)::xs
, (y
, commay
)::ys
->
2335 (match A.unwrap xcomma
with
2336 | A.IComma commax
->
2337 tokenf commax commay
>>= (fun commax commay
->
2338 initialiser x y
>>= (fun x y
->
2339 initialisers_ordered2 xs ys
>>= (fun xs ys
->
2341 (x
, (A.IComma commax
) +> A.rewrap xcomma
)::xs
,
2345 | _
-> raise Impossible
(* unsplit_iicomma wrong *)
2351 and initialisers_unordered2
= fun ias ibs
->
2354 | [], ys
-> return ([], ys
)
2355 | (x
,xcomma
)::xs
, ys
->
2357 let permut = Common.uncons_permut_lazy ys
in
2358 permut +> List.fold_left
(fun acc
((e
, pos
), rest
) ->
2361 (match A.unwrap xcomma
, e
with
2362 | A.IComma commax
, (y
, commay
) ->
2363 tokenf commax commay
>>= (fun commax commay
->
2364 initialiser x y
>>= (fun x y
->
2366 (x
, (A.IComma commax
) +> A.rewrap xcomma
),
2370 | _
-> raise Impossible
(* unsplit_iicomma wrong *)
2373 let rest = Lazy.force
rest in
2374 initialisers_unordered2 xs
rest >>= (fun xs
rest ->
2377 Common.insert_elem_pos
(e
, pos
) rest
2382 (* ------------------------------------------------------------------------- *)
2383 and (struct_fields
: (A.declaration list
, B.field list
) matcher
) =
2386 | [], [] -> return ([], [])
2387 | [], eb
::ebs
-> fail
2389 X.all_bound
(A.get_inherited ea
) >&&>
2390 (match A.unwrap ea
, ebs
with
2391 | A.Ddots
(mcode, optwhen
), ys
->
2392 if optwhen
<> None
then failwith
"not handling when in argument";
2394 (* '...' can take more or less the beginnings of the arguments *)
2397 then [(ys
,[])] (* hack! the only one that can work *)
2398 else Common.zip
(Common.inits ys
) (Common.tails ys
) in
2399 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
2404 if mcode_contain_plus (mcodekind mcode)
2406 (* failwith "I have no token that I could accroche myself on" *)
2407 else return (dots2metavar mcode, [])
2410 X.distrf_struct_fields
(dots2metavar mcode) startxs
2411 ) >>= (fun mcode startxs ->
2412 let mcode = metavar2dots mcode in
2413 struct_fields
eas endxs
>>= (fun eas endxs
->
2415 (A.Ddots
(mcode, optwhen
) +> A.rewrap ea
) ::eas,
2420 | _unwrapx
, eb
::ebs
->
2421 struct_field ea eb
>>= (fun ea eb
->
2422 struct_fields
eas ebs
>>= (fun eas ebs
->
2423 return (ea
::eas, eb
::ebs
)
2426 | _unwrapx
, [] -> fail
2429 and (struct_field
: (A.declaration
, B.field
) matcher
) = fun fa fb
->
2432 | B.DeclarationField
(B.FieldDeclList
(onefield_multivars
,iiptvirg
)) ->
2434 let iiptvirgb = tuple_of_list1 iiptvirg
in
2436 (match onefield_multivars
with
2437 | [] -> raise Impossible
2438 | [onevar
,iivirg
] ->
2439 assert (null iivirg
);
2441 | B.BitField
(sopt
, typb
, _
, expr
) ->
2442 pr2_once
"warning: bitfield not handled by ast_cocci";
2444 | B.Simple
(None
, typb
) ->
2445 pr2_once
"warning: unamed struct field not handled by ast_cocci";
2447 | B.Simple
(Some nameidb
, typb
) ->
2449 (* build a declaration from a struct field *)
2450 let allminus = false in
2452 let stob = B.NoSto
, false in
2454 ({B.v_namei
= Some
(nameidb
, None
);
2457 B.v_local
= Ast_c.NotLocalDecl
;
2458 B.v_attr
= Ast_c.noattr
;
2459 B.v_type_bis
= ref None
;
2460 (* the struct field should also get expanded ? no it's not
2461 * important here, we will rematch very soon *)
2465 onedecl
allminus fa
(fake_var,iiptvirgb,iisto) >>=
2466 (fun fa
(var
,iiptvirgb,iisto) ->
2469 | ({B.v_namei
= Some
(nameidb
, None
);
2474 let onevar = B.Simple
(Some nameidb
, typb
) in
2478 ((B.DeclarationField
2479 (B.FieldDeclList
([onevar, iivirg
], [iiptvirgb])))
2482 | _
-> raise Impossible
2487 pr2_once
"PB: More that one variable in decl. Have to split";
2490 | B.EmptyField _iifield
->
2493 | B.MacroDeclField
((sb
,ebs
),ii
) ->
2494 (match A.unwrap fa
with
2495 A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
) -> raise Todo
2498 | B.CppDirectiveStruct directive
-> fail
2499 | B.IfdefStruct directive
-> fail
2503 (* ------------------------------------------------------------------------- *)
2504 and (fullType
: (A.fullType
, Ast_c.fullType
) matcher
) =
2506 X.optional_qualifier_flag
(fun optional_qualifier
->
2507 X.all_bound
(A.get_inherited typa
) >&&>
2508 match A.unwrap typa
, typb
with
2509 | A.Type
(cv
,ty1
), ((qu
,il
),ty2
) ->
2511 if qu
.B.const
&& qu
.B.volatile
2514 ("warning: the type is both const & volatile but cocci " ^
2515 "does not handle that");
2517 (* Drop out the const/volatile part that has been matched.
2518 * This is because a SP can contain const T v; in which case
2519 * later in match_t_t when we encounter a T, we must not add in
2520 * the environment the whole type.
2525 (* "iso-by-absence" *)
2528 fullTypebis ty1
((qu
,il
), ty2
) >>= (fun ty1 fullty2
->
2530 (A.Type
(None
, ty1
)) +> A.rewrap typa
,
2534 (match optional_qualifier
, qu
.B.const
|| qu
.B.volatile
with
2535 | false, false -> do_stuff ()
2536 | false, true -> fail
2537 | true, false -> do_stuff ()
2540 then pr2_once
"USING optional_qualifier builtin isomorphism";
2546 (* todo: can be __const__ ? can be const & volatile so
2547 * should filter instead ?
2549 (match term x
, il
with
2550 | A.Const
, [i1
] when qu
.B.const
->
2552 tokenf x i1
>>= (fun x i1
->
2553 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2555 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2559 | A.Volatile
, [i1
] when qu
.B.volatile
->
2560 tokenf x i1
>>= (fun x i1
->
2561 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2563 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2571 | A.DisjType typas
, typb
->
2573 List.fold_left
(fun acc typa
-> acc
>|+|> (fullType typa typb
)) fail
2575 | A.OptType
(_
), _
| A.UniqueType
(_
), _
2576 -> failwith
"not handling Opt/Unique on type"
2581 * Why not (A.typeC, Ast_c.typeC) matcher ?
2582 * because when there is MetaType, we want that T record the whole type,
2583 * including the qualifier, and so this type (and the new_il function in
2584 * preceding function).
2587 and (fullTypebis
: (A.typeC
, Ast_c.fullType
) matcher
) =
2589 X.all_bound
(A.get_inherited ta
) >&&>
2590 match A.unwrap ta
, tb
with
2593 | A.MetaType
(ida
,keep
, inherited
), typb
->
2595 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
2596 X.envf keep inherited
(ida
, B.MetaTypeVal typb
, max_min) (fun () ->
2597 X.distrf_type ida typb
>>= (fun ida typb
->
2599 A.MetaType
(ida
,keep
, inherited
) +> A.rewrap ta
,
2603 | unwrap
, (qub
, typb
) ->
2604 typeC ta typb
>>= (fun ta typb
->
2605 return (ta
, (qub
, typb
))
2608 and simulate_signed ta basea stringsa signaopt tb baseb ii rebuilda
=
2609 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2610 * And even if in baseb we have a Signed Int, that does not mean
2611 * that ii is of length 2, cos Signed is the default, so if in signa
2612 * we have Signed explicitely ? we cant "accrocher" this mcode to
2613 * something :( So for the moment when there is signed in cocci,
2614 * we force that there is a signed in c too (done in pattern.ml).
2616 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2619 (* handle some iso on type ? (cf complex C rule for possible implicit
2621 match basea
, baseb
with
2622 | A.VoidType
, B.Void
2623 | A.FloatType
, B.FloatType
(B.CFloat
)
2624 | A.DoubleType
, B.FloatType
(B.CDouble
) ->
2625 assert (signaopt
=*= None
);
2626 let stringa = tuple_of_list1 stringsa
in
2627 let (ibaseb
) = tuple_of_list1 ii
in
2628 tokenf stringa ibaseb
>>= (fun stringa ibaseb
->
2630 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2631 (B.BaseType baseb
, [ibaseb
])
2634 | A.CharType
, B.IntType
B.CChar
when signaopt
=*= None
->
2635 let stringa = tuple_of_list1 stringsa
in
2636 let ibaseb = tuple_of_list1 ii
in
2637 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2639 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2640 (B.BaseType
(B.IntType
B.CChar
), [ibaseb])
2643 | A.CharType
,B.IntType
(B.Si
(_sign
, B.CChar2
)) when signaopt
<> None
->
2644 let stringa = tuple_of_list1 stringsa
in
2645 let ibaseb = tuple_of_list1 iibaseb
in
2646 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2647 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2649 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2650 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2653 | A.ShortType
, B.IntType
(B.Si
(_
, B.CShort
))
2654 | A.IntType
, B.IntType
(B.Si
(_
, B.CInt
))
2655 | A.LongType
, B.IntType
(B.Si
(_
, B.CLong
)) ->
2656 let stringa = tuple_of_list1 stringsa
in
2659 (* iso-by-presence ? *)
2660 (* when unsigned int in SP, allow have just unsigned in C ? *)
2661 if mcode_contain_plus (mcodekind stringa)
2665 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2667 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2668 (B.BaseType
(baseb
), iisignbopt
++ [])
2674 "warning: long int or short int not handled by ast_cocci";
2678 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2679 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2681 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2682 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2684 | _
-> raise Impossible
2689 | A.LongLongType
, B.IntType
(B.Si
(_
, B.CLongLong
)) ->
2690 let (string1a
,string2a
) = tuple_of_list2 stringsa
in
2692 [ibase1b
;ibase2b
] ->
2693 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2694 tokenf string1a ibase1b
>>= (fun base1a ibase1b
->
2695 tokenf string2a ibase2b
>>= (fun base2a ibase2b
->
2697 (rebuilda
([base1a
;base2a
], signaopt
)) +> A.rewrap ta
,
2698 (B.BaseType
(baseb
), iisignbopt
++ [ibase1b
;ibase2b
])
2700 | [] -> fail (* should something be done in this case? *)
2701 | _
-> raise Impossible
)
2704 | _
, B.FloatType
B.CLongDouble
2707 "warning: long double not handled by ast_cocci";
2710 | _
, (B.Void
|B.FloatType _
|B.IntType _
) -> fail
2712 and simulate_signed_meta ta basea signaopt tb baseb ii rebuilda
=
2713 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2714 * And even if in baseb we have a Signed Int, that does not mean
2715 * that ii is of length 2, cos Signed is the default, so if in signa
2716 * we have Signed explicitely ? we cant "accrocher" this mcode to
2717 * something :( So for the moment when there is signed in cocci,
2718 * we force that there is a signed in c too (done in pattern.ml).
2720 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2722 let match_to_type rebaseb
=
2723 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2724 let fta = A.rewrap basea
(A.Type
(None
,basea
)) in
2725 let ftb = Ast_c.nQ
,(B.BaseType
(rebaseb
), iibaseb
) in
2726 fullType
fta ftb >>= (fun fta (_
,tb
) ->
2727 (match A.unwrap
fta,tb
with
2728 A.Type
(_
,basea
), (B.BaseType baseb
, ii
) ->
2730 (rebuilda
(basea
, signaopt
)) +> A.rewrap ta
,
2731 (B.BaseType
(baseb
), iisignbopt
++ ii
)
2733 | _
-> failwith
"not possible"))) in
2735 (* handle some iso on type ? (cf complex C rule for possible implicit
2738 | B.IntType
(B.Si
(_sign
, B.CChar2
)) ->
2739 match_to_type (B.IntType
B.CChar
)
2741 | B.IntType
(B.Si
(_
, ty
)) ->
2743 | [] -> fail (* metavariable has to match something *)
2745 | _
-> match_to_type (B.IntType
(B.Si
(B.Signed
, ty
)))
2749 | (B.Void
|B.FloatType _
|B.IntType _
) -> fail
2751 and (typeC
: (A.typeC
, Ast_c.typeC
) matcher
) =
2753 match A.unwrap ta
, tb
with
2754 | A.BaseType
(basea
,stringsa
), (B.BaseType baseb
, ii
) ->
2755 simulate_signed ta basea stringsa None tb baseb ii
2756 (function (stringsa
, signaopt
) -> A.BaseType
(basea
,stringsa
))
2757 | A.SignedT
(signaopt
, Some basea
), (B.BaseType baseb
, ii
) ->
2758 (match A.unwrap basea
with
2759 A.BaseType
(basea1
,strings1
) ->
2760 simulate_signed ta basea1 strings1
(Some signaopt
) tb baseb ii
2761 (function (strings1
, Some signaopt
) ->
2764 Some
(A.rewrap basea
(A.BaseType
(basea1
,strings1
))))
2765 | _
-> failwith
"not possible")
2766 | A.MetaType
(ida
,keep
,inherited
) ->
2767 simulate_signed_meta ta basea
(Some signaopt
) tb baseb ii
2768 (function (basea
, Some signaopt
) ->
2769 A.SignedT
(signaopt
,Some basea
)
2770 | _
-> failwith
"not possible")
2771 | _
-> failwith
"not possible")
2772 | A.SignedT
(signa
,None
), (B.BaseType baseb
, ii
) ->
2773 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2774 (match iibaseb
, baseb
with
2775 | [], B.IntType
(B.Si
(_sign
, B.CInt
)) ->
2776 sign
(Some signa
) signbopt >>= (fun signaopt iisignbopt
->
2778 | None
-> raise Impossible
2781 (A.SignedT
(signa
,None
)) +> A.rewrap ta
,
2782 (B.BaseType baseb
, iisignbopt
)
2790 (* todo? iso with array *)
2791 | A.Pointer
(typa
, iamult
), (B.Pointer typb
, ii
) ->
2792 let (ibmult
) = tuple_of_list1 ii
in
2793 fullType typa typb
>>= (fun typa typb
->
2794 tokenf iamult ibmult
>>= (fun iamult ibmult
->
2796 (A.Pointer
(typa
, iamult
)) +> A.rewrap ta
,
2797 (B.Pointer typb
, [ibmult
])
2800 | A.FunctionType
(allminus,tyaopt
,lpa
,paramsa
,rpa
),
2801 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
) ->
2803 let (lpb
, rpb
) = tuple_of_list2 ii
in
2807 ("Not handling well variable length arguments func. "^
2808 "You have been warned");
2809 tokenf lpa lpb
>>= (fun lpa lpb
->
2810 tokenf rpa rpb
>>= (fun rpa rpb
->
2811 fullType_optional_allminus
allminus tyaopt tyb
>>= (fun tyaopt tyb
->
2812 parameters
(seqstyle paramsa
) (A.undots paramsa
) paramsb
>>=
2813 (fun paramsaundots paramsb
->
2814 let paramsa = redots
paramsa paramsaundots
in
2816 (A.FunctionType
(allminus,tyaopt
,lpa
,paramsa,rpa
) +> A.rewrap ta
,
2817 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), [lpb
;rpb
])
2825 | A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
),
2826 (B.ParenType t1
, ii
) ->
2827 let (lp1b
, rp1b
) = tuple_of_list2 ii
in
2828 let (qu1b
, t1b
) = t1
in
2830 | B.Pointer t2
, ii
->
2831 let (starb
) = tuple_of_list1 ii
in
2832 let (qu2b
, t2b
) = t2
in
2834 | B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
->
2835 let (lp2b
, rp2b
) = tuple_of_list2 ii
in
2840 ("Not handling well variable length arguments func. "^
2841 "You have been warned");
2843 fullType tya tyb
>>= (fun tya tyb
->
2844 tokenf lp1a lp1b
>>= (fun lp1a lp1b
->
2845 tokenf rp1a rp1b
>>= (fun rp1a rp1b
->
2846 tokenf lp2a lp2b
>>= (fun lp2a lp2b
->
2847 tokenf rp2a rp2b
>>= (fun rp2a rp2b
->
2848 tokenf stara starb
>>= (fun stara starb
->
2849 parameters
(seqstyle paramsa) (A.undots
paramsa) paramsb
>>=
2850 (fun paramsaundots paramsb
->
2851 let paramsa = redots
paramsa paramsaundots
in
2855 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))),
2860 (B.Pointer
t2, [starb
]))
2864 (A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
))
2866 (B.ParenType
t1, [lp1b
;rp1b
])
2879 (* todo: handle the iso on optionnal size specifification ? *)
2880 | A.Array
(typa
, ia1
, eaopt
, ia2
), (B.Array
(ebopt
, typb
), ii
) ->
2881 let (ib1, ib2
) = tuple_of_list2 ii
in
2882 fullType typa typb
>>= (fun typa typb
->
2883 option expression eaopt ebopt
>>= (fun eaopt ebopt
->
2884 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2885 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2887 (A.Array
(typa
, ia1
, eaopt
, ia2
)) +> A.rewrap ta
,
2888 (B.Array
(ebopt
, typb
), [ib1;ib2
])
2892 (* todo: could also match a Struct that has provided a name *)
2893 (* This is for the case where the SmPL code contains "struct x", without
2894 a definition. In this case, the name field is always present.
2895 This case is also called from the case for A.StructUnionDef when
2896 a name is present in the C code. *)
2897 | A.StructUnionName
(sua
, Some sa
), (B.StructUnionName
(sub
, sb
), ii
) ->
2898 (* sa is now an ident, not an mcode, old: ... && (term sa) =$= sb *)
2899 let (ib1, ib2
) = tuple_of_list2 ii
in
2900 if equal_structUnion (term sua
) sub
2902 ident DontKnow sa
(sb
, ib2
) >>= (fun sa
(sb
, ib2
) ->
2903 tokenf sua
ib1 >>= (fun sua
ib1 ->
2905 (A.StructUnionName
(sua
, Some sa
)) +> A.rewrap ta
,
2906 (B.StructUnionName
(sub
, sb
), [ib1;ib2
])
2911 | A.StructUnionDef
(ty
, lba
, declsa, rba
),
2912 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
2914 let (ii_sub_sb
, lbb
, rbb
) =
2916 [iisub
; lbb
; rbb
] -> (Common.Left iisub
,lbb
,rbb
)
2917 | [iisub
; iisb
; lbb
; rbb
] -> (Common.Right
(iisub
,iisb
),lbb
,rbb
)
2918 | _
-> failwith
"list of length 3 or 4 expected" in
2921 match (sbopt
,ii_sub_sb
) with
2922 (None
,Common.Left iisub
) ->
2923 (* the following doesn't reconstruct the complete SP code, just
2924 the part that matched *)
2926 match A.unwrap
s with
2928 (match A.unwrap ty
with
2929 A.StructUnionName
(sua
, None
) ->
2930 tokenf sua iisub
>>= (fun sua iisub
->
2933 A.StructUnionName
(sua
, None
) +> A.rewrap
ty)
2935 return (ty,[iisub
]))
2937 | A.DisjType
(disjs
) ->
2939 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
2943 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
2945 (* build a StructUnionName from a StructUnion *)
2946 let fake_su = B.nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) in
2948 fullType
ty fake_su >>= (fun ty fake_su ->
2950 | _nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) ->
2951 return (ty, [iisub
; iisb
])
2952 | _
-> raise Impossible
)
2956 >>= (fun ty ii_sub_sb
->
2958 tokenf lba lbb
>>= (fun lba lbb
->
2959 tokenf rba rbb
>>= (fun rba rbb
->
2960 struct_fields
(A.undots
declsa) declsb
>>=(fun undeclsa declsb
->
2961 let declsa = redots
declsa undeclsa
in
2964 (A.StructUnionDef
(ty, lba
, declsa, rba
)) +> A.rewrap ta
,
2965 (B.StructUnion
(sub
, sbopt
, declsb
),ii_sub_sb
@[lbb
;rbb
])
2969 (* todo? handle isomorphisms ? because Unsigned Int can be match on a
2970 * uint in the C code. But some CEs consists in renaming some types,
2971 * so we don't want apply isomorphisms every time.
2973 | A.TypeName sa
, (B.TypeName
(nameb
, typb
), noii
) ->
2977 | B.RegularName
(sb
, iidb
) ->
2978 let iidb1 = tuple_of_list1 iidb
in
2982 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
2984 (A.TypeName sa
) +> A.rewrap ta
,
2985 (B.TypeName
(B.RegularName
(sb
, [iidb1]), typb
), noii
)
2989 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
2994 | _
, (B.TypeOfExpr e
, ii
) -> fail
2995 | _
, (B.TypeOfType e
, ii
) -> fail
2997 | _
, (B.ParenType e
, ii
) -> fail (* todo ?*)
2998 | A.EnumName
(en
,namea
), (B.EnumName nameb
, ii
) ->
2999 let (ib1,ib2
) = tuple_of_list2 ii
in
3000 ident DontKnow namea
(nameb
, ib2
) >>= (fun namea
(nameb
, ib2
) ->
3001 tokenf en
ib1 >>= (fun en
ib1 ->
3003 (A.EnumName
(en
, namea
)) +> A.rewrap ta
,
3004 (B.EnumName nameb
, [ib1;ib2
])
3007 | _
, (B.Enum _
, _
) -> fail (* todo cocci ?*)
3010 ((B.TypeName _
| B.StructUnionName
(_
, _
) | B.EnumName _
|
3011 B.StructUnion
(_
, _
, _
) |
3012 B.FunctionType _
| B.Array
(_
, _
) | B.Pointer _
|
3018 (* todo: iso on sign, if not mentioned then free. tochange?
3019 * but that require to know if signed int because explicit
3020 * signed int, or because implicit signed int.
3023 and sign signa signb
=
3024 match signa
, signb
with
3025 | None
, None
-> return (None
, [])
3026 | Some signa
, Some
(signb
, ib
) ->
3027 if equal_sign (term signa
) signb
3028 then tokenf signa ib
>>= (fun signa ib
->
3029 return (Some signa
, [ib
])
3035 and minusize_list iixs
=
3036 iixs
+> List.fold_left
(fun acc ii
->
3037 acc
>>= (fun xs ys
->
3038 tokenf minusizer ii
>>= (fun minus ii
->
3039 return (minus
::xs
, ii
::ys
)
3040 ))) (return ([],[]))
3041 >>= (fun _xsminys ys
->
3042 return ((), List.rev ys
)
3045 and storage_optional_allminus
allminus stoa
(stob, iistob
) =
3046 (* "iso-by-absence" for storage, and return type. *)
3047 X.optional_storage_flag
(fun optional_storage
->
3048 match stoa
, stob with
3049 | None
, (stobis
, inline
) ->
3053 minusize_list iistob
>>= (fun () iistob
->
3054 return (None
, (stob, iistob
))
3056 else return (None
, (stob, iistob
))
3059 (match optional_storage
, stobis
with
3060 | false, B.NoSto
-> do_minus ()
3062 | true, B.NoSto
-> do_minus ()
3065 then pr2_once
"USING optional_storage builtin isomorphism";
3069 | Some x
, ((stobis
, inline
)) ->
3070 if equal_storage (term x
) stobis
3072 let rec loop acc
= function
3076 tokenf x i1
>>= (fun x i1
->
3077 let rebuilt = (List.rev acc
) @ i1
:: iistob
in
3078 return (Some x
, ((stobis
, inline
), rebuilt))) in
3079 let try2 x
= loop (i1
::acc
) iistob x
in (* x for laziness *)
3085 and fullType_optional_allminus
allminus tya retb
=
3090 X.distrf_type
minusizer retb
>>= (fun _x retb
->
3094 else return (None
, retb
)
3096 fullType tya retb
>>= (fun tya retb
->
3097 return (Some tya
, retb
)
3102 (*---------------------------------------------------------------------------*)
3104 and compatible_base_type a signa b
=
3105 let ok = return ((),()) in
3108 | Type_cocci.VoidType
, B.Void
->
3109 assert (signa
=*= None
);
3111 | Type_cocci.CharType
, B.IntType
B.CChar
when signa
=*= None
->
3113 | Type_cocci.CharType
, B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3114 compatible_sign signa signb
3115 | Type_cocci.ShortType
, B.IntType
(B.Si
(signb
, B.CShort
)) ->
3116 compatible_sign signa signb
3117 | Type_cocci.IntType
, B.IntType
(B.Si
(signb
, B.CInt
)) ->
3118 compatible_sign signa signb
3119 | Type_cocci.LongType
, B.IntType
(B.Si
(signb
, B.CLong
)) ->
3120 compatible_sign signa signb
3121 | _
, B.IntType
(B.Si
(signb
, B.CLongLong
)) ->
3122 pr2_once
"no longlong in cocci";
3124 | Type_cocci.FloatType
, B.FloatType
B.CFloat
->
3125 assert (signa
=*= None
);
3127 | Type_cocci.DoubleType
, B.FloatType
B.CDouble
->
3128 assert (signa
=*= None
);
3130 | _
, B.FloatType
B.CLongDouble
->
3131 pr2_once
"no longdouble in cocci";
3133 | Type_cocci.BoolType
, _
-> failwith
"no booltype in C"
3135 | _
, (B.Void
|B.FloatType _
|B.IntType _
) -> fail
3137 and compatible_base_type_meta a signa qua b ii
local =
3139 | Type_cocci.MetaType
(ida
,keep
,inherited
),
3140 B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3141 compatible_sign signa signb
>>= fun _ _
->
3142 let newb = ((qua
, (B.BaseType
(B.IntType
B.CChar
),ii
)),local) in
3143 compatible_type a
newb
3144 | Type_cocci.MetaType
(ida
,keep
,inherited
), B.IntType
(B.Si
(signb
, ty)) ->
3145 compatible_sign signa signb
>>= fun _ _
->
3147 ((qua
, (B.BaseType
(B.IntType
(B.Si
(B.Signed
, ty))),ii
)),local) in
3148 compatible_type a
newb
3149 | _
, B.FloatType
B.CLongDouble
->
3150 pr2_once
"no longdouble in cocci";
3153 | _
, (B.Void
|B.FloatType _
|B.IntType _
) -> fail
3156 and compatible_type a
(b
,local) =
3157 let ok = return ((),()) in
3159 let rec loop = function
3160 | Type_cocci.BaseType a
, (qua
, (B.BaseType b
,ii
)) ->
3161 compatible_base_type a None b
3163 | Type_cocci.SignedT
(signa
,None
), (qua
, (B.BaseType b
,ii
)) ->
3164 compatible_base_type
Type_cocci.IntType
(Some signa
) b
3166 | Type_cocci.SignedT
(signa
,Some
ty), (qua
, (B.BaseType b
,ii
)) ->
3168 Type_cocci.BaseType
ty ->
3169 compatible_base_type
ty (Some signa
) b
3170 | Type_cocci.MetaType
(ida
,keep
,inherited
) ->
3171 compatible_base_type_meta
ty (Some signa
) qua b ii
local
3172 | _
-> failwith
"not possible")
3174 | Type_cocci.Pointer a
, (qub
, (B.Pointer b
, ii
)) ->
3176 | Type_cocci.FunctionPointer a
, _
->
3178 "TODO: function pointer type doesn't store enough information to determine compatability"
3179 | Type_cocci.Array a
, (qub
, (B.Array
(eopt
, b
),ii
)) ->
3180 (* no size info for cocci *)
3182 | Type_cocci.StructUnionName
(sua
, _
, sa
),
3183 (qub
, (B.StructUnionName
(sub
, sb
),ii
)) ->
3184 if equal_structUnion_type_cocci sua sub
&& sa
=$
= sb
3187 | Type_cocci.EnumName
(_
, sa
),
3188 (qub
, (B.EnumName
(sb
),ii
)) ->
3192 | Type_cocci.TypeName sa
, (qub
, (B.TypeName
(namesb
, _typb
),noii
)) ->
3193 let sb = Ast_c.str_of_name namesb
in
3198 | Type_cocci.ConstVol
(qua
, a
), (qub
, b
) ->
3199 if (fst qub
).B.const
&& (fst qub
).B.volatile
3202 pr2_once
("warning: the type is both const & volatile but cocci " ^
3203 "does not handle that");
3209 | Type_cocci.Const
-> (fst qub
).B.const
3210 | Type_cocci.Volatile
-> (fst qub
).B.volatile
3212 then loop (a
,(Ast_c.nQ
, b
))
3215 | Type_cocci.MetaType
(ida
,keep
,inherited
), typb
->
3217 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
3218 X.envf keep inherited
(A.make_mcode ida
, B.MetaTypeVal typb
, max_min)
3222 (* subtil: must be after the MetaType case *)
3223 | a
, (qub
, (B.TypeName
(_namesb
, Some b
), noii
)) ->
3224 (* kind of typedef iso *)
3231 (* for metavariables of type expression *^* *)
3232 | Type_cocci.Unknown
, _
-> ok
3237 B.TypeOfType _
|B.TypeOfExpr _
|B.ParenType _
|
3238 B.EnumName _
|B.StructUnion
(_
, _
, _
)|B.Enum
(_
, _
)
3245 B.StructUnionName
(_
, _
)|
3247 B.Array
(_
, _
)|B.Pointer _
|B.TypeName _
|
3256 and compatible_sign signa signb
=
3257 let ok = return ((),()) in
3258 match signa
, signb
with
3260 | Some
Type_cocci.Signed
, B.Signed
3261 | Some
Type_cocci.Unsigned
, B.UnSigned
3266 and equal_structUnion_type_cocci a b
=
3268 | Type_cocci.Struct
, B.Struct
-> true
3269 | Type_cocci.Union
, B.Union
-> true
3270 | _
, (B.Struct
| B.Union
) -> false
3274 (*---------------------------------------------------------------------------*)
3275 and inc_file
(a
, before_after
) (b
, h_rel_pos
) =
3277 let rec aux_inc (ass
, bss
) passed
=
3281 let passed = List.rev
passed in
3283 (match before_after
, !h_rel_pos
with
3284 | IncludeNothing
, _
-> true
3285 | IncludeMcodeBefore
, Some x
->
3286 List.mem
passed (x
.Ast_c.first_of
)
3288 | IncludeMcodeAfter
, Some x
->
3289 List.mem
passed (x
.Ast_c.last_of
)
3291 (* no info, maybe cos of a #include <xx.h> that was already in a .h *)
3295 | (A.IncPath x
)::xs
, y
::ys
-> x
=$
= y
&& aux_inc (xs
, ys
) (x
::passed)
3296 | _
-> failwith
"IncDots not in last place or other pb"
3301 | A.Local ass
, B.Local bss
->
3302 aux_inc (ass
, bss
) []
3303 | A.NonLocal ass
, B.NonLocal bss
->
3304 aux_inc (ass
, bss
) []
3309 (*---------------------------------------------------------------------------*)
3311 and (define_params
: sequence
->
3312 (A.define_param list
, (string B.wrap
) B.wrap2 list
) matcher
) =
3313 fun seqstyle eas ebs
->
3315 | Unordered
-> failwith
"not handling ooo"
3317 define_paramsbis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
3318 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
3321 (* todo? facto code with argument and parameters ? *)
3322 and define_paramsbis
= fun eas ebs
->
3324 | [], [] -> return ([], [])
3325 | [], eb
::ebs
-> fail
3327 X.all_bound
(A.get_inherited ea
) >&&>
3328 (match A.unwrap ea
, ebs
with
3329 | A.DPdots
(mcode), ys
->
3331 (* '...' can take more or less the beginnings of the arguments *)
3332 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
3333 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
3338 if mcode_contain_plus (mcodekind mcode)
3340 (* failwith "I have no token that I could accroche myself on" *)
3341 else return (dots2metavar mcode, [])
3343 (match Common.last
startxs with
3346 X.distrf_define_params
(dots2metavar mcode) startxs
3348 ) >>= (fun mcode startxs ->
3349 let mcode = metavar2dots mcode in
3350 define_paramsbis
eas endxs
>>= (fun eas endxs
->
3352 (A.DPdots
(mcode) +> A.rewrap ea
) ::eas,
3358 | A.DPComma ia1
, Right ii
::ebs
->
3359 let ib1 = tuple_of_list1 ii
in
3360 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3361 define_paramsbis
eas ebs
>>= (fun eas ebs
->
3363 (A.DPComma ia1
+> A.rewrap ea
)::eas,
3368 | A.DPComma ia1
, ebs
->
3369 if mcode_contain_plus (mcodekind ia1
)
3372 (define_paramsbis
eas ebs
) (* try optional comma trick *)
3374 | (A.OptDParam _
| A.UniqueDParam _
), _
->
3375 failwith
"handling Opt/Unique for define parameters"
3377 | A.DPcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
3379 | A.DParam ida
, (Left
(idb
, ii
))::ebs
->
3380 let ib1 = tuple_of_list1 ii
in
3381 ident DontKnow ida
(idb
, ib1) >>= (fun ida
(idb
, ib1) ->
3382 define_paramsbis
eas ebs
>>= (fun eas ebs
->
3384 (A.DParam ida
)+> A.rewrap ea
:: eas,
3385 (Left
(idb
, [ib1]))::ebs
3388 | _unwrapx
, (Right y
)::ys
-> raise Impossible
3389 | _unwrapx
, [] -> fail
3394 (*****************************************************************************)
3396 (*****************************************************************************)
3398 (* no global solution for positions here, because for a statement metavariable
3399 we want a MetaStmtVal, and for the others, it's not clear what we want *)
3401 let rec (rule_elem_node
: (A.rule_elem
, Control_flow_c.node
) matcher
) =
3404 x
>>= (fun a b
-> return (A.rewrap re a
, F.rewrap node b
))
3406 X.all_bound
(A.get_inherited re
) >&&>
3409 match A.unwrap re
, F.unwrap node
with
3411 (* note: the order of the clauses is important. *)
3413 | _
, F.Enter
| _
, F.Exit
| _
, F.ErrorExit
-> fail2()
3415 (* the metaRuleElem contains just '-' information. We dont need to add
3416 * stuff in the environment. If we need stuff in environment, because
3417 * there is a + S somewhere, then this will be done via MetaStmt, not
3419 * Can match TrueNode/FalseNode/... so must be placed before those cases.
3422 | A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
->
3423 let default = A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
in
3424 (match unwrap_node
with
3426 | F.TrueNode
| F.FalseNode
| F.AfterNode
3427 | F.LoopFallThroughNode
| F.FallThroughNode
3429 if X.mode
=*= PatternMode
3432 if mcode_contain_plus (mcodekind mcode)
3433 then failwith
"try add stuff on fake node"
3434 (* minusize or contextize a fake node is ok *)
3437 | F.EndStatement None
->
3438 if X.mode
=*= PatternMode
then return default
3440 (* DEAD CODE NOW ? only useful in -no_cocci_vs_c_3 ?
3441 if mcode_contain_plus (mcodekind mcode)
3443 let fake_info = Ast_c.fakeInfo() in
3444 distrf distrf_node (mcodekind mcode)
3445 (F.EndStatement (Some fake_info))
3446 else return unwrap_node
3450 | F.EndStatement
(Some i1
) ->
3451 tokenf mcode i1
>>= (fun mcode i1
->
3453 A.MetaRuleElem
(mcode,keep
, inherited
),
3454 F.EndStatement
(Some i1
)
3458 if X.mode
=*= PatternMode
then return default
3459 else failwith
"a MetaRuleElem can't transform a headfunc"
3461 if X.mode
=*= PatternMode
then return default
3463 X.distrf_node
(generalize_mcode mcode) node
>>= (fun mcode node
->
3465 A.MetaRuleElem
(mcode,keep
, inherited
),
3471 (* rene cant have found that a state containing a fake/exit/... should be
3473 * TODO: and F.Fake ?
3475 | _
, F.EndStatement _
| _
, F.CaseNode _
3476 | _
, F.TrueNode
| _
, F.FalseNode
| _
, F.AfterNode
3477 | _
, F.FallThroughNode
| _
, F.LoopFallThroughNode
3481 (* really ? diff between pattern.ml and transformation.ml *)
3482 | _
, F.Fake
-> fail2()
3485 (* cas general: a Meta can match everything. It matches only
3486 * "header"-statement. We transform only MetaRuleElem, not MetaStmt.
3487 * So can't have been called in transform.
3489 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), F.Decl
(_
) -> fail
3491 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), unwrap_node
->
3492 (* todo: should not happen in transform mode *)
3494 (match Control_flow_c.extract_fullstatement node
with
3497 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_stmt stb
) in
3498 X.envf keep inherited
(ida
, Ast_c.MetaStmtVal stb
, max_min)
3500 (* no need tag ida, we can't be called in transform-mode *)
3502 A.MetaStmt
(ida
, keep
, metainfoMaybeTodo
, inherited
),
3510 | A.MetaStmtList _
, _
->
3511 failwith
"not handling MetaStmtList"
3513 | A.TopExp ea
, F.DefineExpr eb
->
3514 expression ea eb
>>= (fun ea eb
->
3520 | A.TopExp ea
, F.DefineType eb
->
3521 (match A.unwrap ea
with
3523 fullType ft eb
>>= (fun ft eb
->
3525 A.TopExp
(A.rewrap ea
(A.TypeExp
(ft
))),
3532 (* It is important to put this case before the one that fails because
3533 * of the lack of the counter part of a C construct in SmPL (for instance
3534 * there is not yet a CaseRange in SmPL). Even if SmPL don't handle
3535 * yet certain constructs, those constructs may contain expression
3536 * that we still want and can transform.
3539 | A.Exp exp
, nodeb
->
3541 (* kind of iso, initialisation vs affectation *)
3543 match A.unwrap exp
, nodeb
with
3544 | A.Assignment
(ea
, op
, eb
, true), F.Decl decl
->
3545 initialisation_to_affectation decl
+> F.rewrap node
3550 (* Now keep fullstatement inside the control flow node,
3551 * so that can then get in a MetaStmtVar the fullstatement to later
3552 * pp back when the S is in a +. But that means that
3553 * Exp will match an Ifnode even if there is no such exp
3554 * inside the condition of the Ifnode (because the exp may
3555 * be deeper, in the then branch). So have to not visit
3556 * all inside a node anymore.
3558 * update: j'ai choisi d'accrocher au noeud du CFG Ã la
3559 * fois le fullstatement et le partialstatement et appeler le
3560 * visiteur que sur le partialstatement.
3563 match Ast_cocci.get_pos re
with
3564 | None
-> expression
3568 Lib_parsing_c.max_min_by_pos
(Lib_parsing_c.ii_of_expr eb
) in
3569 let keep = Type_cocci.Unitary
in
3570 let inherited = false in
3571 let max_min _
= failwith
"no pos" in
3572 X.envf
keep inherited (pos
, B.MetaPosVal
(min
,max
), max_min)
3578 X.cocciExp
expfn exp
node >>= (fun exp
node ->
3586 X.cocciTy fullType
ty node >>= (fun ty node ->
3593 | A.TopInit init
, nodeb
->
3594 X.cocciInit initialiser init
node >>= (fun init
node ->
3602 | A.FunHeader
(mckstart
, allminus, fninfoa
, ida
, oparen
, paramsa, cparen
),
3603 F.FunHeader
({B.f_name
= nameidb
;
3604 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3608 f_old_c_style
= oldstyle
;
3613 then pr2 "OLD STYLE DECL NOT WELL SUPPORTED";
3616 (* fninfoa records the order in which the SP specified the various
3617 information, but this isn't taken into account in the matching.
3618 Could this be a problem for transformation? *)
3621 List.filter
(function A.FStorage
(s) -> true | _
-> false) fninfoa
3622 with [A.FStorage
(s)] -> Some
s | _
-> None
in
3624 match List.filter
(function A.FType
(s) -> true | _
-> false) fninfoa
3625 with [A.FType
(t
)] -> Some t
| _
-> None
in
3627 (match List.filter
(function A.FInline
(i
) -> true | _
-> false) fninfoa
3628 with [A.FInline
(i
)] -> failwith
"not checking inline" | _
-> ());
3630 (match List.filter
(function A.FAttr
(a
) -> true | _
-> false) fninfoa
3631 with [A.FAttr
(a
)] -> failwith
"not checking attributes" | _
-> ());
3634 | ioparenb
::icparenb
::iifakestart
::iistob
->
3636 (* maybe important to put ident as the first tokens to transform.
3637 * It's related to transform_proto. So don't change order
3640 ident_cpp LocalFunction ida nameidb
>>= (fun ida nameidb
->
3641 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
3642 tokenf oparen ioparenb
>>= (fun oparen ioparenb
->
3643 tokenf cparen icparenb
>>= (fun cparen icparenb
->
3644 parameters
(seqstyle paramsa)
3645 (A.undots
paramsa) paramsb
>>=
3646 (fun paramsaundots paramsb
->
3647 let paramsa = redots
paramsa paramsaundots
in
3648 storage_optional_allminus
allminus
3649 stoa (stob, iistob
) >>= (fun stoa (stob, iistob
) ->
3654 ("Not handling well variable length arguments func. "^
3655 "You have been warned");
3657 then minusize_list iidotsb
3658 else return ((),iidotsb
)
3659 ) >>= (fun () iidotsb
->
3661 fullType_optional_allminus
allminus tya retb
>>= (fun tya retb
->
3664 (match stoa with Some st
-> [A.FStorage st
] | None
-> []) ++
3665 (match tya with Some t
-> [A.FType t
] | None
-> [])
3670 A.FunHeader
(mckstart
,allminus,fninfoa,ida
,oparen
,
3672 F.FunHeader
({B.f_name
= nameidb
;
3673 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3677 f_old_c_style
= oldstyle
; (* TODO *)
3679 ioparenb
::icparenb
::iifakestart
::iistob
)
3682 | _
-> raise Impossible
3690 | A.Decl
(mckstart
,allminus,decla
), F.Decl declb
->
3691 declaration
(mckstart
,allminus,decla
) declb
>>=
3692 (fun (mckstart
,allminus,decla
) declb
->
3694 A.Decl
(mckstart
,allminus,decla
),
3699 | A.SeqStart
mcode, F.SeqStart
(st
, level
, i1
) ->
3700 tokenf mcode i1
>>= (fun mcode i1
->
3703 F.SeqStart
(st
, level
, i1
)
3706 | A.SeqEnd
mcode, F.SeqEnd
(level
, i1
) ->
3707 tokenf mcode i1
>>= (fun mcode i1
->
3710 F.SeqEnd
(level
, i1
)
3713 | A.ExprStatement
(ea
, ia1
), F.ExprStatement
(st
, (Some eb
, ii
)) ->
3714 let ib1 = tuple_of_list1 ii
in
3715 expression ea eb
>>= (fun ea eb
->
3716 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3718 A.ExprStatement
(ea
, ia1
),
3719 F.ExprStatement
(st
, (Some eb
, [ib1]))
3724 | A.IfHeader
(ia1
,ia2
, ea
, ia3
), F.IfHeader
(st
, (eb
,ii
)) ->
3725 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3726 expression ea eb
>>= (fun ea eb
->
3727 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3728 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3729 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3731 A.IfHeader
(ia1
, ia2
, ea
, ia3
),
3732 F.IfHeader
(st
, (eb
,[ib1;ib2
;ib3
]))
3735 | A.Else ia
, F.Else ib
->
3736 tokenf ia ib
>>= (fun ia ib
->
3737 return (A.Else ia
, F.Else ib
)
3740 | A.WhileHeader
(ia1
, ia2
, ea
, ia3
), F.WhileHeader
(st
, (eb
, ii
)) ->
3741 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3742 expression ea eb
>>= (fun ea eb
->
3743 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3744 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3745 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3747 A.WhileHeader
(ia1
, ia2
, ea
, ia3
),
3748 F.WhileHeader
(st
, (eb
, [ib1;ib2
;ib3
]))
3751 | A.DoHeader ia
, F.DoHeader
(st
, ib
) ->
3752 tokenf ia ib
>>= (fun ia ib
->
3757 | A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
), F.DoWhileTail
(eb
, ii
) ->
3758 let (ib1, ib2
, ib3
, ib4
) = tuple_of_list4 ii
in
3759 expression ea eb
>>= (fun ea eb
->
3760 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3761 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3762 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3763 tokenf ia4 ib4
>>= (fun ia4 ib4
->
3765 A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
),
3766 F.DoWhileTail
(eb
, [ib1;ib2
;ib3
;ib4
])
3768 | A.IteratorHeader
(ia1
, ia2
, eas, ia3
), F.MacroIterHeader
(st
, ((s,ebs
),ii
))
3770 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3772 ident DontKnow ia1
(s, ib1) >>= (fun ia1
(s, ib1) ->
3773 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3774 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3775 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
3776 let eas = redots
eas easundots
in
3778 A.IteratorHeader
(ia1
, ia2
, eas, ia3
),
3779 F.MacroIterHeader
(st
, ((s,ebs
), [ib1;ib2
;ib3
]))
3784 | A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3785 F.ForHeader
(st
, (((eb1opt
,ib3s
), (eb2opt
,ib4s
), (eb3opt
,ib4vide
)), ii
))
3787 assert (null ib4vide
);
3788 let (ib1, ib2
, ib5
) = tuple_of_list3 ii
in
3789 let ib3 = tuple_of_list1 ib3s
in
3790 let ib4 = tuple_of_list1 ib4s
in
3792 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3793 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3794 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3795 tokenf ia4
ib4 >>= (fun ia4
ib4 ->
3796 tokenf ia5 ib5
>>= (fun ia5 ib5
->
3797 option expression ea1opt eb1opt
>>= (fun ea1opt eb1opt
->
3798 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
3799 option expression ea3opt eb3opt
>>= (fun ea3opt eb3opt
->
3801 A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3802 F.ForHeader
(st
, (((eb1opt
,[ib3]), (eb2opt
,[ib4]), (eb3opt
,[])),
3808 | A.SwitchHeader
(ia1
,ia2
,ea
,ia3
), F.SwitchHeader
(st
, (eb
,ii
)) ->
3809 let (ib1, ib2
, ib3) = tuple_of_list3 ii
in
3810 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3811 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3812 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3813 expression ea eb
>>= (fun ea eb
->
3815 A.SwitchHeader
(ia1
,ia2
,ea
,ia3
),
3816 F.SwitchHeader
(st
, (eb
,[ib1;ib2
;ib3]))
3819 | A.Break
(ia1
, ia2
), F.Break
(st
, ((),ii
)) ->
3820 let (ib1, ib2
) = tuple_of_list2 ii
in
3821 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3822 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3825 F.Break
(st
, ((),[ib1;ib2
]))
3828 | A.Continue
(ia1
, ia2
), F.Continue
(st
, ((),ii
)) ->
3829 let (ib1, ib2
) = tuple_of_list2 ii
in
3830 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3831 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3833 A.Continue
(ia1
, ia2
),
3834 F.Continue
(st
, ((),[ib1;ib2
]))
3837 | A.Return
(ia1
, ia2
), F.Return
(st
, ((),ii
)) ->
3838 let (ib1, ib2
) = tuple_of_list2 ii
in
3839 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3840 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3842 A.Return
(ia1
, ia2
),
3843 F.Return
(st
, ((),[ib1;ib2
]))
3846 | A.ReturnExpr
(ia1
, ea
, ia2
), F.ReturnExpr
(st
, (eb
, ii
)) ->
3847 let (ib1, ib2
) = tuple_of_list2 ii
in
3848 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3849 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3850 expression ea eb
>>= (fun ea eb
->
3852 A.ReturnExpr
(ia1
, ea
, ia2
),
3853 F.ReturnExpr
(st
, (eb
, [ib1;ib2
]))
3858 | A.Include
(incla
,filea
),
3859 F.Include
{B.i_include
= (fileb
, ii
);
3860 B.i_rel_pos
= h_rel_pos
;
3861 B.i_is_in_ifdef
= inifdef
;
3864 assert (copt
=*= None
);
3866 let include_requirment =
3867 match mcodekind incla
, mcodekind filea
with
3868 | A.CONTEXT
(_
, A.BEFORE _
), _
->
3870 | _
, A.CONTEXT
(_
, A.AFTER _
) ->
3876 let (inclb
, iifileb
) = tuple_of_list2 ii
in
3877 if inc_file
(term filea
, include_requirment) (fileb
, h_rel_pos
)
3879 tokenf incla inclb
>>= (fun incla inclb
->
3880 tokenf filea iifileb
>>= (fun filea iifileb
->
3882 A.Include
(incla
, filea
),
3883 F.Include
{B.i_include
= (fileb
, [inclb
;iifileb
]);
3884 B.i_rel_pos
= h_rel_pos
;
3885 B.i_is_in_ifdef
= inifdef
;
3893 | A.DefineHeader
(definea
,ida
,params
), F.DefineHeader
((idb
, ii
), defkind
) ->
3894 let (defineb
, iidb
, ieol
) = tuple_of_list3 ii
in
3895 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
3896 tokenf definea defineb
>>= (fun definea defineb
->
3897 (match A.unwrap params
, defkind
with
3898 | A.NoParams
, B.DefineVar
->
3900 A.NoParams
+> A.rewrap params
,
3903 | A.DParams
(lpa
,eas,rpa
), (B.DefineFunc
(ebs
, ii
)) ->
3904 let (lpb
, rpb
) = tuple_of_list2 ii
in
3905 tokenf lpa lpb
>>= (fun lpa lpb
->
3906 tokenf rpa rpb
>>= (fun rpa rpb
->
3908 define_params
(seqstyle eas) (A.undots
eas) ebs
>>=
3909 (fun easundots ebs
->
3910 let eas = redots
eas easundots
in
3912 A.DParams
(lpa
,eas,rpa
) +> A.rewrap params
,
3913 B.DefineFunc
(ebs
,[lpb
;rpb
])
3917 ) >>= (fun params defkind
->
3919 A.DefineHeader
(definea
, ida
, params
),
3920 F.DefineHeader
((idb
,[defineb
;iidb
;ieol
]),defkind
)
3925 | A.Default
(def
,colon
), F.Default
(st
, ((),ii
)) ->
3926 let (ib1, ib2
) = tuple_of_list2 ii
in
3927 tokenf def
ib1 >>= (fun def
ib1 ->
3928 tokenf colon ib2
>>= (fun colon ib2
->
3930 A.Default
(def
,colon
),
3931 F.Default
(st
, ((),[ib1;ib2
]))
3936 | A.Case
(case
,ea
,colon
), F.Case
(st
, (eb
,ii
)) ->
3937 let (ib1, ib2
) = tuple_of_list2 ii
in
3938 tokenf case
ib1 >>= (fun case
ib1 ->
3939 expression ea eb
>>= (fun ea eb
->
3940 tokenf colon ib2
>>= (fun colon ib2
->
3942 A.Case
(case
,ea
,colon
),
3943 F.Case
(st
, (eb
,[ib1;ib2
]))
3946 (* only occurs in the predicates generated by asttomember *)
3947 | A.DisjRuleElem
eas, _
->
3949 List.fold_left
(fun acc ea
-> acc
>|+|> (rule_elem_node ea
node)) fail)
3950 >>= (fun ea eb
-> return (A.unwrap ea
,F.unwrap eb
))
3952 | _
, F.ExprStatement
(_
, (None
, ii
)) -> fail (* happen ? *)
3954 | A.Label
(id
,dd
), F.Label
(st
, nameb
, ((),ii
)) ->
3955 let (ib2
) = tuple_of_list1 ii
in
3956 ident_cpp DontKnow id nameb
>>= (fun ida nameb
->
3957 tokenf dd ib2
>>= (fun dd ib2
->
3960 F.Label
(st
,nameb
, ((),[ib2
]))
3963 | A.Goto
(goto
,id
,sem
), F.Goto
(st
,nameb
, ((),ii
)) ->
3964 let (ib1,ib3) = tuple_of_list2 ii
in
3965 tokenf goto
ib1 >>= (fun goto
ib1 ->
3966 ident_cpp DontKnow id nameb
>>= (fun id nameb
->
3967 tokenf sem
ib3 >>= (fun sem
ib3 ->
3969 A.Goto
(goto
,id
,sem
),
3970 F.Goto
(st
,nameb
, ((),[ib1;ib3]))
3973 (* have not a counter part in coccinelle, for the moment *)
3974 (* todo?: print a warning at least ? *)
3980 | _
, (F.IfdefEndif _
|F.IfdefElse _
|F.IfdefHeader _
)
3984 (F.MacroStmt
(_
, _
)| F.DefineDoWhileZeroHeader _
| F.EndNode
|F.TopNode
)
3987 (F.Label
(_
, _
, _
)|F.Break
(_
, _
)|F.Continue
(_
, _
)|F.Default
(_
, _
)|
3988 F.Case
(_
, _
)|F.Include _
|F.Goto _
|F.ExprStatement _
|
3989 F.DefineType _
|F.DefineExpr _
|F.DefineTodo
|
3990 F.DefineHeader
(_
, _
)|F.ReturnExpr
(_
, _
)|F.Return
(_
, _
)|F.MacroIterHeader
(_
, _
)|
3991 F.SwitchHeader
(_
, _
)|F.ForHeader
(_
, _
)|F.DoWhileTail _
|F.DoHeader
(_
, _
)|
3992 F.WhileHeader
(_
, _
)|F.Else _
|F.IfHeader
(_
, _
)|
3993 F.SeqEnd
(_
, _
)|F.SeqStart
(_
, _
, _
)|
3994 F.Decl _
|F.FunHeader _
)