2 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
3 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
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.
26 module F
= Control_flow_c
28 module Flag
= Flag_matcher
30 (*****************************************************************************)
32 (*****************************************************************************)
33 let pr2, pr2_once
= Common.mk_pr2_wrappers
Flag_matcher.verbose_matcher
35 (*****************************************************************************)
37 (*****************************************************************************)
39 type sequence
= Ordered
| Unordered
42 match A.unwrap eas
with
44 | A.CIRCLES _
-> Unordered
45 | A.STARS _
-> failwith
"not handling stars"
47 let (redots
: 'a
A.dots
-> 'a list
-> 'a
A.dots
)=fun eas easundots
->
49 match A.unwrap eas
with
50 | A.DOTS _
-> A.DOTS easundots
51 | A.CIRCLES _
-> A.CIRCLES easundots
52 | A.STARS _
-> A.STARS easundots
56 let (need_unordered_initialisers
: B.initialiser
B.wrap2 list
-> bool) =
58 ibs
+> List.exists
(fun (ib
, icomma
) ->
59 match B.unwrap ib
with
69 (* For the #include <linux/...> in the .cocci, need to find where is
70 * the '+' attached to this element, to later find the first concrete
71 * #include <linux/xxx.h> or last one in the serie of #includes in the
74 type include_requirement
=
81 (* todo? put in semantic_c.ml *)
84 | LocalFunction
(* entails Function *)
88 let term mc
= A.unwrap_mcode mc
89 let mcodekind mc
= A.get_mcodekind mc
92 let mcode_contain_plus = function
93 | A.CONTEXT
(_
,A.NOTHING
) -> false
95 | A.MINUS
(_
,_
,_
,[]) -> false
96 | A.MINUS
(_
,_
,_
,x
::xs
) -> true
97 | A.PLUS
-> raise Impossible
99 let mcode_simple_minus = function
100 | A.MINUS
(_
,_
,_
,[]) -> true
104 (* In transformation.ml sometime I build some mcodekind myself and
105 * julia has put None for the pos. But there is no possible raise
106 * NoMatch in those cases because it is for the minusall trick or for
107 * the distribute, so either have to build those pos, in fact a range,
108 * because for the distribute have to erase a fullType with one
109 * mcodekind, or add an argument to tag_with_mck such as "safe" that
110 * don't do the check_pos. Hence this DontCarePos constructor. *)
114 {A.line
= 0; A.column
=0; A.strbef
=[]; A.straft
=[];},
115 (A.MINUS
(A.DontCarePos
,[],-1,[])),
118 let generalize_mcode ia
=
119 let (s1
, i
, mck
, pos
) = ia
in
122 | A.PLUS
-> raise Impossible
123 | A.CONTEXT
(A.NoPos
,x
) ->
124 A.CONTEXT
(A.DontCarePos
,x
)
125 | A.MINUS
(A.NoPos
,inst
,adj
,x
) ->
126 A.MINUS
(A.DontCarePos
,inst
,adj
,x
)
128 | A.CONTEXT
((A.FixPos _
|A.DontCarePos
), _
)
129 | A.MINUS
((A.FixPos _
|A.DontCarePos
), _
, _
, _
)
133 (s1
, i
, new_mck, pos
)
137 (*---------------------------------------------------------------------------*)
139 (* 0x0 is equivalent to 0, value format isomorphism *)
140 let equal_c_int s1 s2
=
142 int_of_string s1
=|= int_of_string s2
143 with Failure
("int_of_string") ->
148 (*---------------------------------------------------------------------------*)
149 (* Normally A should reuse some types of Ast_c, so those
150 * functions should not exist.
152 * update: but now Ast_c depends on A, so can't make too
153 * A depends on Ast_c, so have to stay with those equal_xxx
157 let equal_unaryOp a b
=
159 | A.GetRef
, B.GetRef
-> true
160 | A.DeRef
, B.DeRef
-> true
161 | A.UnPlus
, B.UnPlus
-> true
162 | A.UnMinus
, B.UnMinus
-> true
163 | A.Tilde
, B.Tilde
-> true
164 | A.Not
, B.Not
-> true
165 | _
, B.GetRefLabel
-> false (* todo cocci? *)
166 | _
, (B.Not
|B.Tilde
|B.UnMinus
|B.UnPlus
|B.DeRef
|B.GetRef
) -> false
170 let equal_arithOp a b
=
172 | A.Plus
, B.Plus
-> true
173 | A.Minus
, B.Minus
-> true
174 | A.Mul
, B.Mul
-> true
175 | A.Div
, B.Div
-> true
176 | A.Mod
, B.Mod
-> true
177 | A.DecLeft
, B.DecLeft
-> true
178 | A.DecRight
, B.DecRight
-> true
179 | A.And
, B.And
-> true
180 | A.Or
, B.Or
-> true
181 | A.Xor
, B.Xor
-> true
182 | _
, (B.Xor
|B.Or
|B.And
|B.DecRight
|B.DecLeft
|B.Mod
|B.Div
|B.Mul
|B.Minus
|B.Plus
)
185 let equal_logicalOp a b
=
187 | A.Inf
, B.Inf
-> true
188 | A.Sup
, B.Sup
-> true
189 | A.InfEq
, B.InfEq
-> true
190 | A.SupEq
, B.SupEq
-> true
191 | A.Eq
, B.Eq
-> true
192 | A.NotEq
, B.NotEq
-> true
193 | A.AndLog
, B.AndLog
-> true
194 | A.OrLog
, B.OrLog
-> true
195 | _
, (B.OrLog
|B.AndLog
|B.NotEq
|B.Eq
|B.SupEq
|B.InfEq
|B.Sup
|B.Inf
)
198 let equal_assignOp a b
=
200 | A.SimpleAssign
, B.SimpleAssign
-> true
201 | A.OpAssign a
, B.OpAssign b
-> equal_arithOp a b
202 | _
, (B.OpAssign _
|B.SimpleAssign
) -> false
204 let equal_fixOp a b
=
206 | A.Dec
, B.Dec
-> true
207 | A.Inc
, B.Inc
-> true
208 | _
, (B.Inc
|B.Dec
) -> false
210 let equal_binaryOp a b
=
212 | A.Arith a
, B.Arith b
-> equal_arithOp a b
213 | A.Logical a
, B.Logical b
-> equal_logicalOp a b
214 | _
, (B.Logical _
| B.Arith _
) -> false
216 let equal_structUnion a b
=
218 | A.Struct
, B.Struct
-> true
219 | A.Union
, B.Union
-> true
220 | _
, (B.Struct
|B.Union
) -> false
224 | A.Signed
, B.Signed
-> true
225 | A.Unsigned
, B.UnSigned
-> true
226 | _
, (B.UnSigned
|B.Signed
) -> false
228 let equal_storage a b
=
230 | A.Static
, B.Sto
B.Static
231 | A.Auto
, B.Sto
B.Auto
232 | A.Register
, B.Sto
B.Register
233 | A.Extern
, B.Sto
B.Extern
235 | _
, (B.NoSto
| B.StoTypedef
) -> false
236 | _
, (B.Sto
(B.Register
|B.Static
|B.Auto
|B.Extern
)) -> false
239 (*---------------------------------------------------------------------------*)
241 let equal_metavarval valu valu'
=
242 match valu
, valu'
with
243 | Ast_c.MetaIdVal a
, Ast_c.MetaIdVal b
-> a
=$
= b
244 | Ast_c.MetaFuncVal a
, Ast_c.MetaFuncVal b
-> a
=$
= b
245 | Ast_c.MetaLocalFuncVal a
, Ast_c.MetaLocalFuncVal b
->
246 (* do something more ? *)
249 (* al_expr before comparing !!! and accept when they match.
250 * Note that here we have Astc._expression, so it is a match
251 * modulo isomorphism (there is no metavariable involved here,
252 * just isomorphisms). => TODO call isomorphism_c_c instead of
253 * =*=. Maybe would be easier to transform ast_c in ast_cocci
254 * and call the iso engine of julia. *)
255 | Ast_c.MetaExprVal a
, Ast_c.MetaExprVal b
->
256 Lib_parsing_c.al_expr a
=*= Lib_parsing_c.al_expr b
257 | Ast_c.MetaExprListVal a
, Ast_c.MetaExprListVal b
->
258 Lib_parsing_c.al_arguments a
=*= Lib_parsing_c.al_arguments b
260 | Ast_c.MetaStmtVal a
, Ast_c.MetaStmtVal b
->
261 Lib_parsing_c.al_statement a
=*= Lib_parsing_c.al_statement b
262 | Ast_c.MetaInitVal a
, Ast_c.MetaInitVal b
->
263 Lib_parsing_c.al_init a
=*= Lib_parsing_c.al_init b
264 | Ast_c.MetaTypeVal a
, Ast_c.MetaTypeVal b
->
265 (* old: Lib_parsing_c.al_type a =*= Lib_parsing_c.al_type b *)
268 | Ast_c.MetaListlenVal a
, Ast_c.MetaListlenVal b
-> a
=|= b
270 | Ast_c.MetaParamVal a
, Ast_c.MetaParamVal b
->
271 Lib_parsing_c.al_param a
=*= Lib_parsing_c.al_param b
272 | Ast_c.MetaParamListVal a
, Ast_c.MetaParamListVal b
->
273 Lib_parsing_c.al_params a
=*= Lib_parsing_c.al_params b
275 | Ast_c.MetaPosVal
(posa1
,posa2
), Ast_c.MetaPosVal
(posb1
,posb2
) ->
276 Ast_cocci.equal_pos posa1 posb1
&& Ast_cocci.equal_pos posa2 posb2
278 | Ast_c.MetaPosValList l1
, Ast_c.MetaPosValList l2
->
280 (function (fla
,cea
,posa1
,posa2
) ->
282 (function (flb
,ceb
,posb1
,posb2
) ->
283 fla
=$
= flb
&& cea
=$
= ceb
&&
284 Ast_c.equal_posl posa1 posb1
&& Ast_c.equal_posl posa2 posb2
)
288 | (B.MetaPosValList _
|B.MetaListlenVal _
|B.MetaPosVal _
|B.MetaStmtVal _
289 |B.MetaTypeVal _
|B.MetaInitVal _
290 |B.MetaParamListVal _
|B.MetaParamVal _
|B.MetaExprListVal _
291 |B.MetaExprVal _
|B.MetaLocalFuncVal _
|B.MetaFuncVal _
|B.MetaIdVal _
295 (* probably only one argument needs to be stripped, because inherited
296 metavariables containing expressions are stripped in advance. But don't
297 know which one is which... *)
298 let equal_inh_metavarval valu valu'
=
299 match valu
, valu'
with
300 | Ast_c.MetaIdVal a
, Ast_c.MetaIdVal b
-> a
=$
= b
301 | Ast_c.MetaFuncVal a
, Ast_c.MetaFuncVal b
-> a
=$
= b
302 | Ast_c.MetaLocalFuncVal a
, Ast_c.MetaLocalFuncVal b
->
303 (* do something more ? *)
306 (* al_expr before comparing !!! and accept when they match.
307 * Note that here we have Astc._expression, so it is a match
308 * modulo isomorphism (there is no metavariable involved here,
309 * just isomorphisms). => TODO call isomorphism_c_c instead of
310 * =*=. Maybe would be easier to transform ast_c in ast_cocci
311 * and call the iso engine of julia. *)
312 | Ast_c.MetaExprVal a
, Ast_c.MetaExprVal b
->
313 Lib_parsing_c.al_inh_expr a
=*= Lib_parsing_c.al_inh_expr b
314 | Ast_c.MetaExprListVal a
, Ast_c.MetaExprListVal b
->
315 Lib_parsing_c.al_inh_arguments a
=*= Lib_parsing_c.al_inh_arguments b
317 | Ast_c.MetaStmtVal a
, Ast_c.MetaStmtVal b
->
318 Lib_parsing_c.al_inh_statement a
=*= Lib_parsing_c.al_inh_statement b
319 | Ast_c.MetaInitVal a
, Ast_c.MetaInitVal b
->
320 Lib_parsing_c.al_inh_init a
=*= Lib_parsing_c.al_inh_init b
321 | Ast_c.MetaTypeVal a
, Ast_c.MetaTypeVal b
->
322 (* old: Lib_parsing_c.al_inh_type a =*= Lib_parsing_c.al_inh_type b *)
325 | Ast_c.MetaListlenVal a
, Ast_c.MetaListlenVal b
-> a
=|= b
327 | Ast_c.MetaParamVal a
, Ast_c.MetaParamVal b
->
328 Lib_parsing_c.al_param a
=*= Lib_parsing_c.al_param b
329 | Ast_c.MetaParamListVal a
, Ast_c.MetaParamListVal b
->
330 Lib_parsing_c.al_params a
=*= Lib_parsing_c.al_params b
332 | Ast_c.MetaPosVal
(posa1
,posa2
), Ast_c.MetaPosVal
(posb1
,posb2
) ->
333 Ast_cocci.equal_pos posa1 posb1
&& Ast_cocci.equal_pos posa2 posb2
335 | Ast_c.MetaPosValList l1
, Ast_c.MetaPosValList l2
->
337 (function (fla
,cea
,posa1
,posa2
) ->
339 (function (flb
,ceb
,posb1
,posb2
) ->
340 fla
=$
= flb
&& cea
=$
= ceb
&&
341 Ast_c.equal_posl posa1 posb1
&& Ast_c.equal_posl posa2 posb2
)
345 | (B.MetaPosValList _
|B.MetaListlenVal _
|B.MetaPosVal _
|B.MetaStmtVal _
346 |B.MetaTypeVal _
|B.MetaInitVal _
347 |B.MetaParamListVal _
|B.MetaParamVal _
|B.MetaExprListVal _
348 |B.MetaExprVal _
|B.MetaLocalFuncVal _
|B.MetaFuncVal _
|B.MetaIdVal _
353 (*---------------------------------------------------------------------------*)
354 (* could put in ast_c.ml, next to the split/unsplit_comma *)
355 let split_signb_baseb_ii (baseb
, ii
) =
356 let iis = ii
+> List.map
(fun info
-> (B.str_of_info info
), info
) in
357 match baseb
, iis with
359 | B.Void
, ["void",i1
] -> None
, [i1
]
361 | B.FloatType
(B.CFloat
),["float",i1
] -> None
, [i1
]
362 | B.FloatType
(B.CDouble
),["double",i1
] -> None
, [i1
]
363 | B.FloatType
(B.CLongDouble
),["long",i1
;"double",i2
] -> None
,[i1
;i2
]
365 | B.IntType
(B.CChar
), ["char",i1
] -> None
, [i1
]
368 | B.IntType
(B.Si
(sign
, base
)), xs
->
372 | (B.Signed
,(("signed",i1
)::rest
)) -> (Some
(B.Signed
,i1
),rest
)
373 | (B.Signed
,rest
) -> (None
,rest
)
374 | (B.UnSigned
,(("unsigned",i1
)::rest
)) -> (Some
(B.UnSigned
,i1
),rest
)
375 | (B.UnSigned
,rest
) -> (* is this case possible? *) (None
,rest
) in
376 (* The original code only allowed explicit signed and unsigned for char,
377 while this code allows char by itself. Not sure that needs to be
378 checked for here. If it does, then add a special case. *)
380 match (base
,rest
) with
381 B.CInt
, ["int",i1
] -> [i1
]
384 | B.CInt
, ["",i1
] -> (* no type is specified at all *)
385 (match i1
.B.pinfo
with
387 | _
-> failwith
("unrecognized signed int: "^
388 (String.concat
" "(List.map fst
iis))))
390 | B.CChar2
, ["char",i2
] -> [i2
]
392 | B.CShort
, ["short",i1
] -> [i1
]
393 | B.CShort
, ["short",i1
;"int",i2
] -> [i1
;i2
]
395 | B.CLong
, ["long",i1
] -> [i1
]
396 | B.CLong
, ["long",i1
;"int",i2
] -> [i1
;i2
]
398 | B.CLongLong
, ["long",i1
;"long",i2
] -> [i1
;i2
]
399 | B.CLongLong
, ["long",i1
;"long",i2
;"int",i3
] -> [i1
;i2
;i3
]
402 failwith
("strange type1, maybe because of weird order: "^
403 (String.concat
" " (List.map fst
iis))) in
405 | _
-> failwith
("strange type2, maybe because of weird order: "^
406 (String.concat
" " (List.map fst
iis)))
408 (*---------------------------------------------------------------------------*)
410 let rec unsplit_icomma xs
=
414 (match A.unwrap y
with
416 (x
, y
)::unsplit_icomma xs
417 | _
-> failwith
"wrong ast_cocci in initializer"
420 failwith
("wrong ast_cocci in initializer, should have pair " ^
425 let resplit_initialiser ibs iicomma
=
426 match iicomma
, ibs
with
429 failwith
"should have a iicomma, do you generate fakeInfo in parser?"
431 failwith
"shouldn't have a iicomma"
432 | [iicomma
], x
::xs
->
433 let elems = List.map fst
(x
::xs
) in
434 let commas = List.map snd
(x
::xs
) +> List.flatten
in
435 let commas = commas @ [iicomma
] in
437 | _
-> raise Impossible
441 let rec split_icomma xs
=
444 | (x
,y
)::xs
-> x
::y
::split_icomma xs
446 let rec unsplit_initialiser ibs_unsplit
=
447 match ibs_unsplit
with
448 | [] -> [], [] (* empty iicomma *)
450 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
451 (x
, [])::xs
, lastcomma
453 and unsplit_initialiser_bis comma_before
= function
454 | [] -> [], [comma_before
]
456 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
457 (x
, [comma_before
])::xs
, lastcomma
462 (*---------------------------------------------------------------------------*)
463 (* coupling: same in type_annotater_c.ml *)
464 let structdef_to_struct_name ty
=
466 | qu
, (B.StructUnion
(su
, sopt
, fields
), iis) ->
468 | Some s
, [i1
;i2
;i3
;i4
] ->
469 qu
, (B.StructUnionName
(su
, s
), [i1
;i2
])
473 | x
-> raise Impossible
475 | _
-> raise Impossible
477 (*---------------------------------------------------------------------------*)
478 let initialisation_to_affectation decl
=
480 | B.MacroDecl _
-> F.Decl decl
481 | B.DeclList
(xs
, iis) ->
483 (* todo?: should not do that if the variable is an array cos
484 * will have x[] = , mais de toute facon ca sera pas un InitExp
487 | [] -> raise Impossible
489 let ({B.v_namei
= var
;
490 B.v_type
= returnType
;
491 B.v_type_bis
= tybis
;
492 B.v_storage
= storage
;
499 | Some
(name
, iniopt
) ->
501 | Some
(iini
, (B.InitExpr e
, ii_empty2
)) ->
505 Ast_c.NotLocalDecl
-> Ast_c.NotLocalVar
507 Ast_c.LocalVar
(Ast_c.info_of_type returnType
) in
510 (* old: Lib_parsing_c.al_type returnType
511 * but this type has not the typename completed so
512 * instead try to use tybis
515 | Some ty_with_typename_completed
->
516 ty_with_typename_completed
517 | None
-> raise Impossible
521 ref (Some
(typexp,local),
525 Ast_c.mk_e_bis
(B.Ident
(ident)) typ Ast_c.noii
529 (B.Assignment
(idexpr,B.SimpleAssign
, e
)) [iini
] in
537 pr2_once
"TODO: initialisation_to_affectation for multi vars";
538 (* todo? do a fold_left and generate 'x = a, y = b' etc, use
539 * the Sequence expression operator of C and make an
540 * ExprStatement from that.
549 (*****************************************************************************)
550 (* Functor parameter combinators *)
551 (*****************************************************************************)
553 * src: papers on parser combinators in haskell (cf a pearl by meijer in ICFP)
555 * version0: was not tagging the SP, so just tag the C
557 * (tin -> 'c tout) -> ('c -> (tin -> 'b tout)) -> (tin -> 'b tout)
558 * val return : 'b -> tin -> 'b tout
559 * val fail : tin -> 'b tout
561 * version1: now also tag the SP so return a ('a * 'b)
564 type mode
= PatternMode
| TransformMode
572 type ('a
, 'b
) matcher
= 'a
-> 'b
-> tin
-> ('a
* 'b
) tout
577 (tin
-> ('a
* 'b
) tout
) ->
578 ('a
-> 'b
-> (tin
-> ('c
* 'd
) tout
)) ->
579 (tin
-> ('c
* 'd
) tout
)
581 val return
: ('a
* 'b
) -> tin
-> ('a
*'b
) tout
582 val fail
: tin
-> ('a
* 'b
) tout
594 val (>&&>) : (tin
-> bool) -> (tin
-> 'x tout
) -> (tin
-> 'x tout
)
596 val tokenf
: ('a
A.mcode
, B.info
) matcher
597 val tokenf_mck
: (A.mcodekind, B.info
) matcher
600 (A.meta_name
A.mcode
, B.expression
) matcher
602 (A.meta_name
A.mcode
, (Ast_c.argument
, Ast_c.il
) either list
) matcher
604 (A.meta_name
A.mcode
, Ast_c.fullType
) matcher
606 (A.meta_name
A.mcode
,
607 (Ast_c.parameterType
, Ast_c.il
) either list
) matcher
609 (A.meta_name
A.mcode
, Ast_c.parameterType
) matcher
611 (A.meta_name
A.mcode
, Ast_c.initialiser
) matcher
613 (A.meta_name
A.mcode
, Control_flow_c.node
) matcher
615 val distrf_define_params
:
616 (A.meta_name
A.mcode
, (string Ast_c.wrap
, Ast_c.il
) either list
)
619 val distrf_struct_fields
:
620 (A.meta_name
A.mcode
, B.field list
) matcher
623 (A.meta_name
A.mcode
, (B.constant
, string) either
B.wrap
) matcher
626 (A.expression
, B.expression
) matcher
-> (A.expression
, F.node
) matcher
629 (A.expression
, B.expression
) matcher
->
630 (A.expression
, B.expression
) matcher
633 (A.fullType
, B.fullType
) matcher
-> (A.fullType
, F.node
) matcher
636 (A.initialiser
, B.initialiser
) matcher
-> (A.initialiser
, F.node
) matcher
639 A.keep_binding
-> A.inherited
->
640 A.meta_name
A.mcode
* Ast_c.metavar_binding_kind
*
641 (unit -> Common.filename
* string * Ast_c.posl
* Ast_c.posl
) ->
642 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
644 val check_constraints
:
645 ('a
, 'b
) matcher
-> 'a list
-> 'b
->
646 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
648 val all_bound
: A.meta_name list
-> (tin
-> bool)
650 val optional_storage_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
651 val optional_qualifier_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
652 val value_format_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
657 (*****************************************************************************)
658 (* Functor code, "Cocci vs C" *)
659 (*****************************************************************************)
662 functor (X
: PARAM
) ->
665 type ('a
, 'b
) matcher
= 'a
-> 'b
-> X.tin
-> ('a
* 'b
) X.tout
668 let return = X.return
671 let (>||>) = X.(>||>)
672 let (>|+|>) = X.(>|+|>)
673 let (>&&>) = X.(>&&>)
675 let tokenf = X.tokenf
677 (* should be raise Impossible when called from transformation.ml *)
680 | PatternMode
-> fail
681 | TransformMode
-> raise Impossible
684 let (option: ('a
,'b
) matcher
-> ('a
option,'b
option) matcher
)= fun f t1 t2
->
686 | (Some t1
, Some t2
) ->
687 f t1 t2
>>= (fun t1 t2
->
688 return (Some t1
, Some t2
)
690 | (None
, None
) -> return (None
, None
)
693 (* Dots are sometimes used as metavariables, since like metavariables they
694 can match other things. But they no longer have the same type. Perhaps these
695 functions could be avoided by introducing an appropriate level of polymorphism,
696 but I don't know how to declare polymorphism across functors *)
697 let dots2metavar (_
,info
,mcodekind,pos
) = (("","..."),info
,mcodekind,pos
)
698 let metavar2dots (_
,info
,mcodekind,pos
) = ("...",info
,mcodekind,pos
)
700 (*---------------------------------------------------------------------------*)
712 (*---------------------------------------------------------------------------*)
713 let rec (expression
: (A.expression
, Ast_c.expression
) matcher
) =
715 X.all_bound
(A.get_inherited ea
) >&&>
716 let wa x
= A.rewrap ea x
in
717 match A.unwrap ea
, eb
with
719 (* general case: a MetaExpr can match everything *)
720 | A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
),
721 (((expr
, opttypb
), ii
) as expb
) ->
723 (* old: before have a MetaConst. Now we factorize and use 'form' to
724 * differentiate between different cases *)
725 let rec matches_id = function
726 B.Ident
(name
) -> true
727 | B.Cast
(ty
,e
) -> matches_id (B.unwrap_expr e
)
730 match (form
,expr
) with
733 let rec matches = function
734 B.Constant
(c
) -> true
735 | B.Ident
(nameidb
) ->
736 let s = Ast_c.str_of_name nameidb
in
737 if s =~
"^[A-Z_][A-Z_0-9]*$"
739 pr2_once
("warning: " ^
s ^
" treated as a constant");
743 | B.Cast
(ty
,e
) -> matches (B.unwrap_expr e
)
744 | B.Unary
(e
,B.UnMinus
) -> matches (B.unwrap_expr e
)
745 | B.SizeOfExpr
(exp
) -> true
746 | B.SizeOfType
(ty
) -> true
752 (Some
(_
,Ast_c.LocalVar _
),_
) -> true
754 | (A.ID
,e
) -> matches_id e
in
758 (let (opttypb
,_testb
) = !opttypb
in
759 match opttypa
, opttypb
with
760 | None
, _
-> return ((),())
762 pr2_once
("Missing type information. Certainly a pb in " ^
763 "annotate_typer.ml");
766 | Some tas
, Some tb
->
767 tas
+> List.fold_left
(fun acc ta
->
768 acc
>|+|> compatible_type ta tb
) fail
771 X.check_constraints expression constraints eb
774 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_expr expb
) in
775 X.envf keep inherited
(ida
, Ast_c.MetaExprVal expb
, max_min)
777 X.distrf_e ida expb
>>= (fun ida expb
->
779 A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
)+>
787 * | A.MetaExpr(ida,false,opttypa,_inherited), expb ->
788 * D.distribute_mck (mcodekind ida) D.distribute_mck_e expb binding
790 * but bug! because if have not tagged SP, then transform without doing
791 * any checks. Hopefully now have tagged SP technique.
796 * | A.Edots _, _ -> raise Impossible.
798 * In fact now can also have the Edots inside normal expression, not
799 * just in arg lists. in 'x[...];' less: in if(<... x ... y ...>)
801 | A.Edots
(mcode
, None
), expb
->
802 X.distrf_e
(dots2metavar mcode
) expb
>>= (fun mcode expb
->
804 A.Edots
(metavar2dots mcode
, None
) +> A.rewrap ea
,
809 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
812 | A.Ident ida
, ((B.Ident
(nameidb
), typ),noii
) ->
814 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
816 ((A.Ident ida
)) +> wa,
817 ((B.Ident
(nameidb
), typ),Ast_c.noii
)
823 | A.MetaErr _
, _
-> failwith
"not handling MetaErr"
825 (* todo?: handle some isomorphisms in int/float ? can have different
826 * format : 1l can match a 1.
828 * todo: normally string can contain some metavar too, so should
829 * recurse on the string
831 | A.Constant
(ia1
), ((B.Constant
(ib
) , typ),ii
) ->
832 (* for everything except the String case where can have multi elems *)
834 let ib1 = tuple_of_list1 ii
in
835 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
837 ((A.Constant ia1
)) +> wa,
838 ((B.Constant
(ib
), typ),[ib1])
841 (match term ia1
, ib
with
842 | A.Int x
, B.Int
(y
,_
) ->
843 X.value_format_flag
(fun use_value_equivalence
->
844 if use_value_equivalence
854 | A.Char x
, B.Char
(y
,_
) when x
=$
= y
(* todo: use kind ? *)
856 | A.Float x
, B.Float
(y
,_
) when x
=$
= y
(* todo: use floatType ? *)
859 | A.String sa
, B.String
(sb
,_kind
) when sa
=$
= sb
->
862 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
864 ((A.Constant ia1
)) +> wa,
865 ((B.Constant
(ib
), typ),[ib1])
867 | _
-> fail (* multi string, not handled *)
870 | _
, B.MultiString _
-> (* todo cocci? *) fail
871 | _
, (B.String _
| B.Float _
| B.Char _
| B.Int _
) -> fail
875 | A.FunCall
(ea
, ia1
, eas
, ia2
), ((B.FunCall
(eb
, ebs
), typ),ii
) ->
876 (* todo: do special case to allow IdMetaFunc, cos doing the
877 * recursive call will be too late, match_ident will not have the
878 * info whether it was a function. todo: but how detect when do
879 * x.field = f; how know that f is a Func ? By having computed
880 * some information before the matching!
882 * Allow match with FunCall containing types. Now ast_cocci allow
883 * type in parameter, and morover ast_cocci allow f(...) and those
884 * ... could match type.
886 let (ib1, ib2
) = tuple_of_list2 ii
in
887 expression ea eb
>>= (fun ea eb
->
888 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
889 tokenf ia2 ib2
>>= (fun ia2 ib2
->
890 arguments
(seqstyle eas
) (A.undots eas
) ebs
>>= (fun easundots ebs
->
891 let eas = redots
eas easundots
in
893 ((A.FunCall
(ea
, ia1
, eas, ia2
)) +> wa,
894 ((B.FunCall
(eb
, ebs
),typ), [ib1;ib2
])
900 | A.Assignment
(ea1
, opa
, ea2
, simple
),
901 ((B.Assignment
(eb1
, opb
, eb2
), typ),ii
) ->
902 let (opbi
) = tuple_of_list1 ii
in
903 if equal_assignOp (term opa
) opb
905 expression ea1 eb1
>>= (fun ea1 eb1
->
906 expression ea2 eb2
>>= (fun ea2 eb2
->
907 tokenf opa opbi
>>= (fun opa opbi
->
909 ((A.Assignment
(ea1
, opa
, ea2
, simple
))) +> wa,
910 ((B.Assignment
(eb1
, opb
, eb2
), typ), [opbi
])
914 | A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
),((B.CondExpr
(eb1
,eb2opt
,eb3
),typ),ii
) ->
915 let (ib1, ib2
) = tuple_of_list2 ii
in
916 expression ea1 eb1
>>= (fun ea1 eb1
->
917 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
918 expression ea3 eb3
>>= (fun ea3 eb3
->
919 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
920 tokenf ia2 ib2
>>= (fun ia2 ib2
->
922 ((A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
))) +> wa,
923 ((B.CondExpr
(eb1
, eb2opt
, eb3
),typ), [ib1;ib2
])
926 (* todo?: handle some isomorphisms here ? *)
927 | A.Postfix
(ea
, opa
), ((B.Postfix
(eb
, opb
), typ),ii
) ->
928 let opbi = tuple_of_list1 ii
in
929 if equal_fixOp (term opa
) opb
931 expression ea eb
>>= (fun ea eb
->
932 tokenf opa
opbi >>= (fun opa
opbi ->
934 ((A.Postfix
(ea
, opa
))) +> wa,
935 ((B.Postfix
(eb
, opb
), typ),[opbi])
940 | A.Infix
(ea
, opa
), ((B.Infix
(eb
, opb
), typ),ii
) ->
941 let opbi = tuple_of_list1 ii
in
942 if equal_fixOp (term opa
) opb
944 expression ea eb
>>= (fun ea eb
->
945 tokenf opa
opbi >>= (fun opa
opbi ->
947 ((A.Infix
(ea
, opa
))) +> wa,
948 ((B.Infix
(eb
, opb
), typ),[opbi])
952 | A.Unary
(ea
, opa
), ((B.Unary
(eb
, opb
), typ),ii
) ->
953 let opbi = tuple_of_list1 ii
in
954 if equal_unaryOp (term opa
) opb
956 expression ea eb
>>= (fun ea eb
->
957 tokenf opa
opbi >>= (fun opa
opbi ->
959 ((A.Unary
(ea
, opa
))) +> wa,
960 ((B.Unary
(eb
, opb
), typ),[opbi])
964 | A.Binary
(ea1
, opa
, ea2
), ((B.Binary
(eb1
, opb
, eb2
), typ),ii
) ->
965 let opbi = tuple_of_list1 ii
in
966 if equal_binaryOp (term opa
) opb
968 expression ea1 eb1
>>= (fun ea1 eb1
->
969 expression ea2 eb2
>>= (fun ea2 eb2
->
970 tokenf opa
opbi >>= (fun opa
opbi ->
972 ((A.Binary
(ea1
, opa
, ea2
))) +> wa,
973 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
977 | A.Nested
(ea1
, opa
, ea2
), eb
->
979 (if A.get_test_exp ea1
&& not
(Ast_c.is_test eb
) then fail
980 else expression ea1 eb
) >|+|>
982 ((B.Binary
(eb1
, opb
, eb2
), typ),ii
)
983 when equal_binaryOp (term opa
) opb
->
984 let opbi = tuple_of_list1 ii
in
986 (expression ea1 eb1
>>= (fun ea1 eb1
->
987 expression ea2 eb2
>>= (fun ea2 eb2
->
988 tokenf opa
opbi >>= (fun opa
opbi ->
990 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
991 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
994 (expression ea2 eb1
>>= (fun ea2 eb1
->
995 expression ea1 eb2
>>= (fun ea1 eb2
->
996 tokenf opa
opbi >>= (fun opa
opbi ->
998 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
999 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1002 (loop eb1
>>= (fun ea1 eb1
->
1003 expression ea2 eb2
>>= (fun ea2 eb2
->
1004 tokenf opa
opbi >>= (fun opa
opbi ->
1006 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1007 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1010 (expression ea2 eb1
>>= (fun ea2 eb1
->
1011 loop eb2
>>= (fun ea1 eb2
->
1012 tokenf opa
opbi >>= (fun opa
opbi ->
1014 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1015 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1017 left_to_right >|+|> right_to_left >|+|> in_left >|+|> in_right
1021 (* todo?: handle some isomorphisms here ? (with pointers = Unary Deref) *)
1022 | A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
),((B.ArrayAccess
(eb1
, eb2
), typ),ii
) ->
1023 let (ib1, ib2
) = tuple_of_list2 ii
in
1024 expression ea1 eb1
>>= (fun ea1 eb1
->
1025 expression ea2 eb2
>>= (fun ea2 eb2
->
1026 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1027 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1029 ((A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
))) +> wa,
1030 ((B.ArrayAccess
(eb1
, eb2
),typ), [ib1;ib2
])
1033 (* todo?: handle some isomorphisms here ? *)
1034 | A.RecordAccess
(ea
, ia1
, ida
), ((B.RecordAccess
(eb
, idb
), typ),ii
) ->
1035 let (ib1) = tuple_of_list1 ii
in
1036 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
1037 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1038 expression ea eb
>>= (fun ea eb
->
1040 ((A.RecordAccess
(ea
, ia1
, ida
))) +> wa,
1041 ((B.RecordAccess
(eb
, idb
), typ), [ib1])
1046 | A.RecordPtAccess
(ea
,ia1
,ida
),((B.RecordPtAccess
(eb
, idb
), typ), ii
) ->
1047 let (ib1) = tuple_of_list1 ii
in
1048 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
1049 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1050 expression ea eb
>>= (fun ea eb
->
1052 ((A.RecordPtAccess
(ea
, ia1
, ida
))) +> wa,
1053 ((B.RecordPtAccess
(eb
, idb
), typ), [ib1])
1057 (* todo?: handle some isomorphisms here ?
1058 * todo?: do some iso-by-absence on cast ?
1059 * by trying | ea, B.Case (typb, eb) -> match_e_e ea eb ?
1062 | A.Cast
(ia1
, typa
, ia2
, ea
), ((B.Cast
(typb
, eb
), typ),ii
) ->
1063 let (ib1, ib2
) = tuple_of_list2 ii
in
1064 fullType typa typb
>>= (fun typa typb
->
1065 expression ea eb
>>= (fun ea eb
->
1066 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1067 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1069 ((A.Cast
(ia1
, typa
, ia2
, ea
))) +> wa,
1070 ((B.Cast
(typb
, eb
),typ),[ib1;ib2
])
1073 | A.SizeOfExpr
(ia1
, ea
), ((B.SizeOfExpr
(eb
), typ),ii
) ->
1074 let ib1 = tuple_of_list1 ii
in
1075 expression ea eb
>>= (fun ea eb
->
1076 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1078 ((A.SizeOfExpr
(ia1
, ea
))) +> wa,
1079 ((B.SizeOfExpr
(eb
), typ),[ib1])
1082 | A.SizeOfType
(ia1
, ia2
, typa
, ia3
), ((B.SizeOfType typb
, typ),ii
) ->
1083 let (ib1,ib2
,ib3
) = tuple_of_list3 ii
in
1084 fullType typa typb
>>= (fun typa typb
->
1085 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1086 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1087 tokenf ia3 ib3
>>= (fun ia3 ib3
->
1089 ((A.SizeOfType
(ia1
, ia2
, typa
, ia3
))) +> wa,
1090 ((B.SizeOfType
(typb
),typ),[ib1;ib2
;ib3
])
1094 (* todo? iso ? allow all the combinations ? *)
1095 | A.Paren
(ia1
, ea
, ia2
), ((B.ParenExpr
(eb
), typ),ii
) ->
1096 let (ib1, ib2
) = tuple_of_list2 ii
in
1097 expression ea eb
>>= (fun ea eb
->
1098 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1099 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1101 ((A.Paren
(ia1
, ea
, ia2
))) +> wa,
1102 ((B.ParenExpr
(eb
), typ), [ib1;ib2
])
1105 | A.NestExpr
(exps
,None
,true), eb
->
1106 (match A.unwrap exps
with
1108 X.cocciExpExp expression exp eb
>>= (fun exp eb
->
1110 (A.NestExpr
(A.rewrap exps
(A.DOTS
[exp
]),None
,true)) +> wa,
1116 "for nestexpr, only handling the case with dots and only one exp")
1118 | A.NestExpr _
, _
->
1119 failwith
"only handling multi and no when code in a nest expr"
1121 (* only in arg lists or in define body *)
1122 | A.TypeExp _
, _
-> fail
1124 (* only in arg lists *)
1125 | A.MetaExprList _
, _
1132 | A.DisjExpr
eas, eb
->
1133 eas +> List.fold_left
(fun acc ea
-> acc
>|+|> (expression ea eb
)) fail
1135 | A.UniqueExp _
,_
| A.OptExp _
,_
->
1136 failwith
"not handling Opt/Unique/Multi on expr"
1138 (* Because of Exp cant put a raise Impossible; have to put a fail *)
1140 (* have not a counter part in coccinelle, for the moment *)
1141 | _
, ((B.Sequence _
,_
),_
)
1142 | _
, ((B.StatementExpr _
,_
),_
)
1143 | _
, ((B.Constructor _
,_
),_
)
1148 (((B.Cast
(_
, _
)|B.ParenExpr _
|B.SizeOfType _
|B.SizeOfExpr _
|
1149 B.RecordPtAccess
(_
, _
)|
1150 B.RecordAccess
(_
, _
)|B.ArrayAccess
(_
, _
)|
1151 B.Binary
(_
, _
, _
)|B.Unary
(_
, _
)|
1152 B.Infix
(_
, _
)|B.Postfix
(_
, _
)|
1153 B.Assignment
(_
, _
, _
)|B.CondExpr
(_
, _
, _
)|
1154 B.FunCall
(_
, _
)|B.Constant _
|B.Ident _
),
1162 (* ------------------------------------------------------------------------- *)
1163 and (ident_cpp
: info_ident
-> (A.ident, B.name
) matcher
) =
1164 fun infoidb ida idb
->
1166 | B.RegularName
(s, iis) ->
1167 let iis = tuple_of_list1
iis in
1168 ident infoidb ida
(s, iis) >>= (fun ida
(s,iis) ->
1171 (B.RegularName
(s, [iis]))
1173 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
1175 (* This should be moved to the Id case of ident. Metavariables
1176 should be allowed to be bound to such variables. But doing so
1177 would require implementing an appropriate distr function *)
1180 and (ident: info_ident
-> (A.ident, string * Ast_c.info
) matcher
) =
1181 fun infoidb ida
((idb
, iib
) as ib
) ->
1182 X.all_bound
(A.get_inherited ida
) >&&>
1183 match A.unwrap ida
with
1185 if (term sa
) =$
= idb
then
1186 tokenf sa iib
>>= (fun sa iib
->
1188 ((A.Id sa
)) +> A.rewrap ida
,
1194 | A.MetaId
(mida
,constraints
,keep
,inherited
) ->
1195 X.check_constraints
(ident infoidb
) constraints ib
1197 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1198 (* use drop_pos for ids so that the pos is not added a second time in
1199 the call to tokenf *)
1200 X.envf keep inherited
(A.drop_pos mida
, Ast_c.MetaIdVal
(idb
), max_min)
1202 tokenf mida iib
>>= (fun mida iib
->
1204 ((A.MetaId
(mida
, constraints
, keep
, inherited
)) +> A.rewrap ida
,
1209 | A.MetaFunc
(mida
,constraints
,keep
,inherited
) ->
1211 X.check_constraints
(ident infoidb
) constraints ib
1213 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1214 X.envf keep inherited
(A.drop_pos mida
,Ast_c.MetaFuncVal idb
,max_min)
1216 tokenf mida iib
>>= (fun mida iib
->
1218 ((A.MetaFunc
(mida
,constraints
,keep
,inherited
)))+>A.rewrap ida
,
1223 | LocalFunction
| Function
-> is_function()
1225 failwith
"MetaFunc, need more semantic info about id"
1226 (* the following implementation could possibly be useful, if one
1227 follows the convention that a macro is always in capital letters
1228 and that a macro is not a function.
1229 (if idb =~ "^[A-Z_][A-Z_0-9]*$" then fail else is_function())*)
1232 | A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
) ->
1235 X.check_constraints
(ident infoidb
) constraints ib
1237 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1238 X.envf keep inherited
1239 (A.drop_pos mida
,Ast_c.MetaLocalFuncVal idb
, max_min)
1241 tokenf mida iib
>>= (fun mida iib
->
1243 ((A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
)))
1249 | DontKnow
-> failwith
"MetaLocalFunc, need more semantic info about id"
1252 | A.OptIdent _
| A.UniqueIdent _
->
1253 failwith
"not handling Opt/Unique for ident"
1257 (* ------------------------------------------------------------------------- *)
1258 and (arguments
: sequence
->
1259 (A.expression list
, Ast_c.argument
Ast_c.wrap2 list
) matcher
) =
1260 fun seqstyle eas ebs
->
1262 | Unordered
-> failwith
"not handling ooo"
1264 arguments_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1265 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1267 (* because '...' can match nothing, need to take care when have
1268 * ', ...' or '...,' as in f(..., X, Y, ...). It must match
1269 * f(1,2) for instance.
1270 * So I have added special cases such as (if startxs = []) and code
1271 * in the Ecomma matching rule.
1273 * old: Must do some try, for instance when f(...,X,Y,...) have to
1274 * test the transfo for all the combinaitions and if multiple transfo
1275 * possible ? pb ? => the type is to return a expression option ? use
1276 * some combinators to help ?
1277 * update: with the tag-SP approach, no more a problem.
1280 and arguments_bis
= fun eas ebs
->
1282 | [], [] -> return ([], [])
1283 | [], eb
::ebs
-> fail
1285 X.all_bound
(A.get_inherited ea
) >&&>
1286 (match A.unwrap ea
, ebs
with
1287 | A.Edots
(mcode
, optexpr
), ys
->
1288 (* todo: if optexpr, then a WHEN and so may have to filter yys *)
1289 if optexpr
<> None
then failwith
"not handling when in argument";
1291 (* '...' can take more or less the beginnings of the arguments *)
1292 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1293 startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
1296 (* allow '...', and maybe its associated ',' to match nothing.
1297 * for the associated ',' see below how we handle the EComma
1302 if mcode_contain_plus (mcodekind mcode
)
1304 (* failwith "I have no token that I could accroche myself on" *)
1305 else return (dots2metavar mcode
, [])
1307 (* subtil: we dont want the '...' to match until the
1308 * comma. cf -test pb_params_iso. We would get at
1309 * "already tagged" error.
1310 * this is because both f (... x, ...) and f (..., x, ...)
1311 * would match a f(x,3) with our "optional-comma" strategy.
1313 (match Common.last startxs
with
1316 X.distrf_args
(dots2metavar mcode
) startxs
1319 >>= (fun mcode startxs
->
1320 let mcode = metavar2dots mcode in
1321 arguments_bis
eas endxs
>>= (fun eas endxs
->
1323 (A.Edots
(mcode, optexpr
) +> A.rewrap ea
) ::eas,
1329 | A.EComma ia1
, Right ii
::ebs
->
1330 let ib1 = tuple_of_list1 ii
in
1331 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1332 arguments_bis
eas ebs
>>= (fun eas ebs
->
1334 (A.EComma ia1
+> A.rewrap ea
)::eas,
1338 | A.EComma ia1
, ebs
->
1339 (* allow ',' to maching nothing. optional comma trick *)
1340 if mcode_contain_plus (mcodekind ia1
)
1342 else arguments_bis
eas ebs
1344 | A.MetaExprList
(ida
,leninfo
,keep
,inherited
),ys
->
1345 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1346 startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
1351 if mcode_contain_plus (mcodekind ida
)
1353 (* failwith "no token that I could accroche myself on" *)
1356 (match Common.last startxs
with
1364 let startxs'
= Ast_c.unsplit_comma
startxs in
1365 let len = List.length
startxs'
in
1368 | Some
(lenname
,lenkeep
,leninherited
) ->
1369 let max_min _
= failwith
"no pos" in
1370 X.envf lenkeep leninherited
1371 (lenname
, Ast_c.MetaListlenVal
(len), max_min)
1372 | None
-> function f
-> f
()
1376 Lib_parsing_c.lin_col_by_pos
1377 (Lib_parsing_c.ii_of_args
startxs) in
1378 X.envf keep inherited
1379 (ida
, Ast_c.MetaExprListVal
startxs'
, max_min)
1382 then return (ida
, [])
1383 else X.distrf_args ida
(Ast_c.split_comma
startxs'
)
1385 >>= (fun ida
startxs ->
1386 arguments_bis
eas endxs
>>= (fun eas endxs
->
1388 (A.MetaExprList
(ida
,leninfo
,keep
,inherited
))
1389 +> A.rewrap ea
::eas,
1397 | _unwrapx
, (Left eb
)::ebs
->
1398 argument ea eb
>>= (fun ea eb
->
1399 arguments_bis
eas ebs
>>= (fun eas ebs
->
1400 return (ea
::eas, Left eb
::ebs
)
1402 | _unwrapx
, (Right y
)::ys
-> raise Impossible
1403 | _unwrapx
, [] -> fail
1407 and argument arga argb
=
1408 X.all_bound
(A.get_inherited arga
) >&&>
1409 match A.unwrap arga
, argb
with
1411 Right
(B.ArgType
{B.p_register
=b
,iib
; p_namei
=sopt
;p_type
=tyb
}) ->
1413 if b
|| sopt
<> None
1415 (* failwith "the argument have a storage and ast_cocci does not have"*)
1418 (* b = false and sopt = None *)
1419 fullType tya tyb
>>= (fun tya tyb
->
1421 (A.TypeExp tya
) +> A.rewrap arga
,
1422 (Right
(B.ArgType
{B.p_register
=(b
,iib
);
1427 | A.TypeExp tya
, _
-> fail
1428 | _
, Right
(B.ArgType _
) -> fail
1430 expression arga argb
>>= (fun arga argb
->
1431 return (arga
, Left argb
)
1433 | _
, Right
(B.ArgAction y
) -> fail
1436 (* ------------------------------------------------------------------------- *)
1437 (* todo? facto code with argument ? *)
1438 and (parameters
: sequence
->
1439 (A.parameterTypeDef list
, Ast_c.parameterType
Ast_c.wrap2 list
)
1441 fun seqstyle eas ebs
->
1443 | Unordered
-> failwith
"not handling ooo"
1445 parameters_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1446 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1450 and parameters_bis
eas ebs
=
1452 | [], [] -> return ([], [])
1453 | [], eb
::ebs
-> fail
1455 (* the management of positions is inlined into each case, because
1456 sometimes there is a Param and sometimes a ParamList *)
1457 X.all_bound
(A.get_inherited ea
) >&&>
1458 (match A.unwrap ea
, ebs
with
1459 | A.Pdots
(mcode), ys
->
1461 (* '...' can take more or less the beginnings of the arguments *)
1462 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1463 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
1468 if mcode_contain_plus (mcodekind mcode)
1470 (* failwith "I have no token that I could accroche myself on"*)
1471 else return (dots2metavar mcode, [])
1473 (match Common.last
startxs with
1476 X.distrf_params
(dots2metavar mcode) startxs
1478 ) >>= (fun mcode startxs ->
1479 let mcode = metavar2dots mcode in
1480 parameters_bis
eas endxs
>>= (fun eas endxs
->
1482 (A.Pdots
(mcode) +> A.rewrap ea
) ::eas,
1488 | A.PComma ia1
, Right ii
::ebs
->
1489 let ib1 = tuple_of_list1 ii
in
1490 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1491 parameters_bis
eas ebs
>>= (fun eas ebs
->
1493 (A.PComma ia1
+> A.rewrap ea
)::eas,
1498 | A.PComma ia1
, ebs
->
1499 (* try optional comma trick *)
1500 if mcode_contain_plus (mcodekind ia1
)
1502 else parameters_bis
eas ebs
1505 | A.MetaParamList
(ida
,leninfo
,keep
,inherited
),ys
->
1506 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1507 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
1512 if mcode_contain_plus (mcodekind ida
)
1514 (* failwith "I have no token that I could accroche myself on" *)
1517 (match Common.last
startxs with
1525 let startxs'
= Ast_c.unsplit_comma
startxs in
1526 let len = List.length
startxs'
in
1529 Some
(lenname
,lenkeep
,leninherited
) ->
1530 let max_min _
= failwith
"no pos" in
1531 X.envf lenkeep leninherited
1532 (lenname
, Ast_c.MetaListlenVal
(len), max_min)
1533 | None
-> function f
-> f
()
1537 Lib_parsing_c.lin_col_by_pos
1538 (Lib_parsing_c.ii_of_params
startxs) in
1539 X.envf keep inherited
1540 (ida
, Ast_c.MetaParamListVal
startxs'
, max_min)
1543 then return (ida
, [])
1544 else X.distrf_params ida
(Ast_c.split_comma
startxs'
)
1545 ) >>= (fun ida
startxs ->
1546 parameters_bis
eas endxs
>>= (fun eas endxs
->
1548 (A.MetaParamList
(ida
,leninfo
,keep
,inherited
))
1549 +> A.rewrap ea
::eas,
1557 | A.VoidParam ta
, ys
->
1558 (match eas, ebs
with
1560 let {B.p_register
=(hasreg
,iihasreg
);
1562 p_type
=tb
; } = eb
in
1564 if idbopt
=*= None
&& not hasreg
1567 | (qub
, (B.BaseType
B.Void
,_
)) ->
1568 fullType ta tb
>>= (fun ta tb
->
1570 [(A.VoidParam ta
) +> A.rewrap ea
],
1571 [Left
{B.p_register
=(hasreg
, iihasreg
);
1580 | (A.OptParam _
| A.UniqueParam _
), _
->
1581 failwith
"handling Opt/Unique for Param"
1583 | A.Pcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
1586 | A.MetaParam
(ida
,keep
,inherited
), (Left eb
)::ebs
->
1587 (* todo: use quaopt, hasreg ? *)
1589 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_param eb
) in
1590 X.envf keep inherited
(ida
,Ast_c.MetaParamVal eb
,max_min) (fun () ->
1591 X.distrf_param ida eb
1592 ) >>= (fun ida eb
->
1593 parameters_bis
eas ebs
>>= (fun eas ebs
->
1595 (A.MetaParam
(ida
,keep
,inherited
))+> A.rewrap ea
::eas,
1600 | A.Param
(typa
, idaopt
), (Left eb
)::ebs
->
1601 (*this should succeed if the C code has a name, and fail otherwise*)
1602 parameter
(idaopt
, typa
) eb
>>= (fun (idaopt
, typa
) eb
->
1603 parameters_bis
eas ebs
>>= (fun eas ebs
->
1605 (A.Param
(typa
, idaopt
))+> A.rewrap ea
:: eas,
1609 | _unwrapx
, (Right y
)::ys
-> raise Impossible
1610 | _unwrapx
, [] -> fail
1616 let split_register_param = fun (hasreg, idb, ii_b_s) ->
1617 match hasreg, idb, ii_b_s with
1618 | false, Some s, [i1] -> Left (s, [], i1)
1619 | true, Some s, [i1;i2] -> Left (s, [i1], i2)
1620 | _, None, ii -> Right ii
1621 | _ -> raise Impossible
1625 and parameter
= fun (idaopt
, typa
) paramb
->
1627 let {B.p_register
= (hasreg
,iihasreg
);
1628 p_namei
= nameidbopt
;
1629 p_type
= typb
;} = paramb
in
1631 fullType typa typb
>>= (fun typa typb
->
1632 match idaopt
, nameidbopt
with
1633 | Some ida
, Some nameidb
->
1634 (* todo: if minus on ida, should also minus the iihasreg ? *)
1635 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1638 {B.p_register
= (hasreg
, iihasreg
);
1639 p_namei
= Some
(nameidb
);
1646 {B.p_register
=(hasreg
,iihasreg
);
1652 (* why handle this case ? because of transform_proto ? we may not
1653 * have an ident in the proto.
1654 * If have some plus on ida ? do nothing about ida ?
1656 (* not anymore !!! now that julia is handling the proto.
1657 | _, Right iihasreg ->
1660 ((hasreg, None, typb), iihasreg)
1664 | Some _
, None
-> fail
1665 | None
, Some _
-> fail
1671 (* ------------------------------------------------------------------------- *)
1672 and (declaration
: (A.mcodekind * bool * A.declaration
,B.declaration
) matcher
) =
1673 fun (mckstart
, allminus
, decla
) declb
->
1674 X.all_bound
(A.get_inherited decla
) >&&>
1675 match A.unwrap decla
, declb
with
1677 (* Un MetaDecl est introduit dans l'asttoctl pour sauter au dessus
1678 * de toutes les declarations qui sont au debut d'un fonction et
1679 * commencer le reste du match au premier statement. Alors, ca matche
1680 * n'importe quelle declaration. On n'a pas besoin d'ajouter
1681 * quoi que ce soit dans l'environnement. C'est une sorte de DDots.
1683 * When the SP want to remove the whole function, the minus is not
1684 * on the MetaDecl but on the MetaRuleElem. So there should
1685 * be no transform of MetaDecl, just matching are allowed.
1688 | A.MetaDecl
(ida
,_keep
,_inherited
), _
-> (* keep ? inherited ? *)
1689 (* todo: should not happen in transform mode *)
1690 return ((mckstart
, allminus
, decla
), declb
)
1694 | _
, (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
)) ->
1695 onedecl allminus decla
(var
,iiptvirgb
,iisto
) >>=
1696 (fun decla
(var
,iiptvirgb
,iisto
)->
1697 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1699 (mckstart
, allminus
, decla
),
1700 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1703 | _
, (B.DeclList
(xs
, iiptvirgb
::iifakestart
::iisto
)) ->
1704 if X.mode
=*= PatternMode
1706 xs
+> List.fold_left
(fun acc var
->
1708 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1709 onedecl allminus decla
(var
, iiptvirgb
, iisto
) >>=
1710 (fun decla
(var
, iiptvirgb
, iisto
) ->
1712 (mckstart
, allminus
, decla
),
1713 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1717 failwith
"More that one variable in decl. Have to split to transform."
1719 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
), B.MacroDecl
((sb
,ebs
),ii
) ->
1720 let (iisb
, lpb
, rpb
, iiendb
, iifakestart
, iistob
) =
1722 | iisb
::lpb
::rpb
::iiendb
::iifakestart
::iisto
->
1723 (iisb
,lpb
,rpb
,iiendb
, iifakestart
,iisto
)
1724 | _
-> raise Impossible
1727 then minusize_list iistob
1728 else return ((), iistob
)
1729 ) >>= (fun () iistob
->
1731 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1732 ident DontKnow sa
(sb
, iisb
) >>= (fun sa
(sb
, iisb
) ->
1733 tokenf lpa lpb
>>= (fun lpa lpb
->
1734 tokenf rpa rpb
>>= (fun rpa rpb
->
1735 tokenf enda iiendb
>>= (fun enda iiendb
->
1736 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
1737 let eas = redots
eas easundots
in
1740 (mckstart
, allminus
,
1741 (A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
)) +> A.rewrap decla
),
1742 (B.MacroDecl
((sb
,ebs
),
1743 [iisb
;lpb
;rpb
;iiendb
;iifakestart
] ++ iistob
))
1746 | _
, (B.MacroDecl _
|B.DeclList _
) -> fail
1750 and onedecl
= fun allminus decla
(declb
, iiptvirgb
, iistob
) ->
1751 X.all_bound
(A.get_inherited decla
) >&&>
1752 match A.unwrap decla
, declb
with
1754 (* kind of typedef iso, we must unfold, it's for the case
1755 * T { }; that we want to match against typedef struct { } xx_t;
1757 | A.TyDecl
(tya0
, ptvirga
),
1758 ({B.v_namei
= Some
(nameidb
, None
);
1760 B.v_storage
= (B.StoTypedef
, inl
);
1763 B.v_type_bis
= typb0bis
;
1766 (match A.unwrap tya0
, typb0
with
1767 | A.Type
(cv1
,tya1
), ((qu
,il
),typb1
) ->
1769 (match A.unwrap tya1
, typb1
with
1770 | A.StructUnionDef
(tya2
, lba
, declsa
, rba
),
1771 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
1773 let (iisub
, iisbopt
, lbb
, rbb
) =
1776 let (iisub
, lbb
, rbb
) = tuple_of_list3 ii
in
1777 (iisub
, [], lbb
, rbb
)
1780 "warning: both a typedef (%s) and struct name introduction (%s)"
1781 (Ast_c.str_of_name nameidb
) s
1783 pr2 "warning: I will consider only the typedef";
1784 let (iisub
, iisb
, lbb
, rbb
) = tuple_of_list4 ii
in
1785 (iisub
, [iisb
], lbb
, rbb
)
1788 structdef_to_struct_name
1789 (Ast_c.nQ
, (B.StructUnion
(sub
, sbopt
, declsb
), ii
))
1792 Ast_c.nQ
,((B.TypeName
(nameidb
, Some
1793 (Lib_parsing_c.al_type
structnameb))), [])
1796 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1797 tokenf lba lbb
>>= (fun lba lbb
->
1798 tokenf rba rbb
>>= (fun rba rbb
->
1799 struct_fields
(A.undots declsa
) declsb
>>=(fun undeclsa declsb
->
1800 let declsa = redots
declsa undeclsa
in
1802 (match A.unwrap tya2
with
1803 | A.Type
(cv3
, tya3
) ->
1804 (match A.unwrap tya3
with
1805 | A.MetaType
(ida
,keep
, inherited
) ->
1807 fullType tya2
fake_typeb >>= (fun tya2
fake_typeb ->
1809 A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1 in
1810 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1813 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1814 [iisub
] @ iisbopt
@ [lbb
;rbb
] in
1815 let typb0 = ((qu
, il
), typb1) in
1817 match fake_typeb with
1818 | _nQ
, ((B.TypeName
(nameidb
, _typ
)),[]) ->
1821 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1822 (({B.v_namei
= Some
(nameidb
, None
);
1824 B.v_storage
= (B.StoTypedef
, inl
);
1827 B.v_type_bis
= typb0bis
;
1829 iivirg
),iiptvirgb
,iistob
)
1831 | _
-> raise Impossible
1834 | A.StructUnionName
(sua
, sa
) ->
1836 fullType tya2
structnameb >>= (fun tya2
structnameb ->
1838 let tya1 = A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1
1840 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1842 match structnameb with
1843 | _nQ
, (B.StructUnionName
(sub
, s), [iisub
;iisbopt
]) ->
1845 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1846 [iisub
;iisbopt
;lbb
;rbb
] in
1847 let typb0 = ((qu
, il
), typb1) in
1850 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1851 (({B.v_namei
= Some
(nameidb
, None
);
1853 B.v_storage
= (B.StoTypedef
, inl
);
1856 B.v_type_bis
= typb0bis
;
1858 iivirg
),iiptvirgb
,iistob
)
1860 | _
-> raise Impossible
1862 | _
-> raise Impossible
1871 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1872 ({B.v_namei
= Some
(nameidb
, _
);B.v_storage
= (B.StoTypedef
,_
);}, iivirg
)
1875 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1876 ({B.v_namei
=Some
(nameidb
, _
);B.v_storage
=(B.StoTypedef
,_
);}, iivirg
)
1881 (* could handle iso here but handled in standard.iso *)
1882 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1883 ({B.v_namei
= Some
(nameidb
, None
);
1888 B.v_type_bis
= typbbis
;
1891 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1892 fullType typa typb
>>= (fun typa typb
->
1893 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1894 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1895 (fun stoa
(stob
, iistob
) ->
1897 (A.UnInit
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
1898 (({B.v_namei
= Some
(nameidb
, None
);
1903 B.v_type_bis
= typbbis
;
1908 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1909 ({B.v_namei
= Some
(nameidb
, Some
(iieqb
, inib
));
1914 B.v_type_bis
= typbbis
;
1917 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1918 tokenf eqa iieqb
>>= (fun eqa iieqb
->
1919 fullType typa typb
>>= (fun typa typb
->
1920 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1921 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1922 (fun stoa
(stob
, iistob
) ->
1923 initialiser inia inib
>>= (fun inia inib
->
1925 (A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
)) +> A.rewrap decla
,
1926 (({B.v_namei
= Some
(nameidb
, Some
(iieqb
, inib
));
1931 B.v_type_bis
= typbbis
;
1936 (* do iso-by-absence here ? allow typedecl and var ? *)
1937 | A.TyDecl
(typa
, ptvirga
),
1938 ({B.v_namei
= None
; B.v_type
= typb
;
1942 B.v_type_bis
= typbbis
;
1945 if stob
=*= (B.NoSto
, false)
1947 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1948 fullType typa typb
>>= (fun typa typb
->
1950 (A.TyDecl
(typa
, ptvirga
)) +> A.rewrap decla
,
1951 (({B.v_namei
= None
;
1956 B.v_type_bis
= typbbis
;
1957 }, iivirg
), iiptvirgb
, iistob
)
1962 | A.Typedef
(stoa
, typa
, ida
, ptvirga
),
1963 ({B.v_namei
= Some
(nameidb
, None
);
1965 B.v_storage
= (B.StoTypedef
,inline
);
1968 B.v_type_bis
= typbbis
;
1971 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1972 fullType typa typb
>>= (fun typa typb
->
1975 tokenf stoa iitypedef
>>= (fun stoa iitypedef
->
1976 return (stoa
, [iitypedef
])
1978 | _
-> failwith
"weird, have both typedef and inline or nothing";
1979 ) >>= (fun stoa iistob
->
1980 (match A.unwrap ida
with
1981 | A.MetaType
(_
,_
,_
) ->
1984 Ast_c.nQ
, ((B.TypeName
(nameidb
, Ast_c.noTypedefDef
())), [])
1986 fullTypebis ida
fake_typeb >>= (fun ida
fake_typeb ->
1987 match fake_typeb with
1988 | _nQ
, ((B.TypeName
(nameidb
, _typ
)), []) ->
1989 return (ida
, nameidb
)
1990 | _
-> raise Impossible
1995 | B.RegularName
(sb
, iidb
) ->
1996 let iidb1 = tuple_of_list1 iidb
in
2000 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
2002 (A.TypeName sa
) +> A.rewrap ida
,
2003 B.RegularName
(sb
, [iidb1])
2007 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
2011 | _
-> raise Impossible
2013 ) >>= (fun ida nameidb
->
2015 (A.Typedef
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
2016 (({B.v_namei
= Some
(nameidb
, None
);
2018 B.v_storage
= (B.StoTypedef
,inline
);
2021 B.v_type_bis
= typbbis
;
2029 | _
, ({B.v_namei
= None
;}, _
) ->
2030 (* old: failwith "no variable in this declaration, weird" *)
2035 | A.DisjDecl declas
, declb
->
2036 declas
+> List.fold_left
(fun acc decla
->
2038 (* (declaration (mckstart, allminus, decla) declb) *)
2039 (onedecl allminus decla
(declb
,iiptvirgb
, iistob
))
2044 (* only in struct type decls *)
2045 | A.Ddots
(dots
,whencode
), _
->
2048 | A.OptDecl _
, _
| A.UniqueDecl _
, _
->
2049 failwith
"not handling Opt/Unique Decl"
2051 | _
, ({B.v_namei
=Some _
}, _
) ->
2057 (* ------------------------------------------------------------------------- *)
2059 and (initialiser
: (A.initialiser
, Ast_c.initialiser
) matcher
) = fun ia ib
->
2060 X.all_bound
(A.get_inherited ia
) >&&>
2061 match (A.unwrap ia
,ib
) with
2063 | (A.MetaInit
(ida
,keep
,inherited
), ib
) ->
2065 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_ini ib
) in
2066 X.envf keep inherited
(ida
, Ast_c.MetaInitVal ib
, max_min)
2068 X.distrf_ini ida ib
>>= (fun ida ib
->
2070 A.MetaInit
(ida
,keep
,inherited
) +> A.rewrap ia
,
2075 | (A.InitExpr expa
, ib
) ->
2076 (match A.unwrap expa
, ib
with
2077 | A.Edots
(mcode, None
), ib
->
2078 X.distrf_ini
(dots2metavar mcode) ib
>>= (fun mcode ib
->
2081 (A.Edots
(metavar2dots mcode, None
) +> A.rewrap expa
)
2086 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
2088 | _
, (B.InitExpr expb
, ii
) ->
2090 expression expa expb
>>= (fun expa expb
->
2092 (A.InitExpr expa
) +> A.rewrap ia
,
2093 (B.InitExpr expb
, ii
)
2098 | (A.InitList
(ia1
, ias
, ia2
, []), (B.InitList ibs
, ii
)) ->
2100 | ib1::ib2
::iicommaopt
->
2101 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2102 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2103 initialisers ias
(ibs
, iicommaopt
) >>= (fun ias
(ibs
,iicommaopt
) ->
2105 (A.InitList
(ia1
, ias
, ia2
, [])) +> A.rewrap ia
,
2106 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2109 | _
-> raise Impossible
2112 | (A.InitList
(i1
, ias
, i2
, whencode
),(B.InitList ibs
, _ii
)) ->
2113 failwith
"TODO: not handling whencode in initialisers"
2116 | (A.InitGccExt
(designatorsa
, ia2
, inia
),
2117 (B.InitDesignators
(designatorsb
, inib
), ii2
))->
2119 let iieq = tuple_of_list1 ii2
in
2121 tokenf ia2
iieq >>= (fun ia2
iieq ->
2122 designators designatorsa designatorsb
>>=
2123 (fun designatorsa designatorsb
->
2124 initialiser inia inib
>>= (fun inia inib
->
2126 (A.InitGccExt
(designatorsa
, ia2
, inia
)) +> A.rewrap ia
,
2127 (B.InitDesignators
(designatorsb
, inib
), [iieq])
2133 | (A.InitGccName
(ida
, ia1
, inia
), (B.InitFieldOld
(idb
, inib
), ii
)) ->
2136 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2137 initialiser inia inib
>>= (fun inia inib
->
2138 tokenf ia1 iicolon
>>= (fun ia1 iicolon
->
2140 (A.InitGccName
(ida
, ia1
, inia
)) +> A.rewrap ia
,
2141 (B.InitFieldOld
(idb
, inib
), [iidb
;iicolon
])
2148 | A.IComma
(comma
), _
->
2151 | A.UniqueIni _
,_
| A.OptIni _
,_
->
2152 failwith
"not handling Opt/Unique on initialisers"
2154 | _
, (B.InitIndexOld
(_
, _
), _
) -> fail
2155 | _
, (B.InitFieldOld
(_
, _
), _
) -> fail
2157 | _
, ((B.InitDesignators
(_
, _
)|B.InitList _
|B.InitExpr _
), _
)
2160 and designators dla dlb
=
2161 match (dla
,dlb
) with
2162 ([],[]) -> return ([], [])
2163 | ([],_
) | (_
,[]) -> fail
2164 | (da
::dla
,db
::dlb
) ->
2165 designator da db
>>= (fun da db
->
2166 designators dla dlb
>>= (fun dla dlb
->
2167 return (da
::dla
, db
::dlb
)))
2169 and designator da db
=
2171 (A.DesignatorField
(ia1
, ida
), (B.DesignatorField idb
,ii1
)) ->
2173 let (iidot
, iidb
) = tuple_of_list2 ii1
in
2174 tokenf ia1 iidot
>>= (fun ia1 iidot
->
2175 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2177 A.DesignatorField
(ia1
, ida
),
2178 (B.DesignatorField idb
, [iidot
;iidb
])
2181 | (A.DesignatorIndex
(ia1
,ea
,ia2
), (B.DesignatorIndex eb
, ii1
)) ->
2183 let (ib1, ib2
) = tuple_of_list2 ii1
in
2184 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2185 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2186 expression ea eb
>>= (fun ea eb
->
2188 A.DesignatorIndex
(ia1
,ea
,ia2
),
2189 (B.DesignatorIndex eb
, [ib1;ib2
])
2192 | (A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2193 (B.DesignatorRange
(e1b
, e2b
), ii1
)) ->
2195 let (ib1, ib2
, ib3
) = tuple_of_list3 ii1
in
2196 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2197 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2198 tokenf ia3 ib3
>>= (fun ia3 ib3
->
2199 expression e1a e1b
>>= (fun e1a e1b
->
2200 expression e2a e2b
>>= (fun e2a e2b
->
2202 A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2203 (B.DesignatorRange
(e1b
, e2b
), [ib1;ib2
;ib3
])
2205 | (_
, ((B.DesignatorField _
|B.DesignatorIndex _
|B.DesignatorRange _
), _
)) ->
2209 and initialisers
= fun ias
(ibs
, iicomma
) ->
2210 let ias_unsplit = unsplit_icomma ias
in
2211 let ibs_split = resplit_initialiser ibs iicomma
in
2214 if need_unordered_initialisers ibs
2215 then initialisers_unordered2
2216 else initialisers_ordered2
2218 f ias_unsplit ibs_split >>=
2219 (fun ias_unsplit ibs_split ->
2221 split_icomma ias_unsplit,
2222 unsplit_initialiser ibs_split
2226 (* todo: one day julia will reput a IDots *)
2227 and initialisers_ordered2
= fun ias ibs
->
2229 | [], [] -> return ([], [])
2230 | (x
, xcomma
)::xs
, (y
, commay
)::ys
->
2231 (match A.unwrap xcomma
with
2232 | A.IComma commax
->
2233 tokenf commax commay
>>= (fun commax commay
->
2234 initialiser x y
>>= (fun x y
->
2235 initialisers_ordered2 xs ys
>>= (fun xs ys
->
2237 (x
, (A.IComma commax
) +> A.rewrap xcomma
)::xs
,
2241 | _
-> raise Impossible
(* unsplit_iicomma wrong *)
2247 and initialisers_unordered2
= fun ias ibs
->
2250 | [], ys
-> return ([], ys
)
2251 | (x
,xcomma
)::xs
, ys
->
2253 let permut = Common.uncons_permut_lazy ys
in
2254 permut +> List.fold_left
(fun acc
((e
, pos
), rest
) ->
2257 (match A.unwrap xcomma
, e
with
2258 | A.IComma commax
, (y
, commay
) ->
2259 tokenf commax commay
>>= (fun commax commay
->
2260 initialiser x y
>>= (fun x y
->
2262 (x
, (A.IComma commax
) +> A.rewrap xcomma
),
2266 | _
-> raise Impossible
(* unsplit_iicomma wrong *)
2269 let rest = Lazy.force
rest in
2270 initialisers_unordered2 xs
rest >>= (fun xs
rest ->
2273 Common.insert_elem_pos
(e
, pos
) rest
2278 (* ------------------------------------------------------------------------- *)
2279 and (struct_fields
: (A.declaration list
, B.field list
) matcher
) =
2282 | [], [] -> return ([], [])
2283 | [], eb
::ebs
-> fail
2285 X.all_bound
(A.get_inherited ea
) >&&>
2286 (match A.unwrap ea
, ebs
with
2287 | A.Ddots
(mcode, optwhen
), ys
->
2288 if optwhen
<> None
then failwith
"not handling when in argument";
2290 (* '...' can take more or less the beginnings of the arguments *)
2291 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
2292 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
2297 if mcode_contain_plus (mcodekind mcode)
2299 (* failwith "I have no token that I could accroche myself on" *)
2300 else return (dots2metavar mcode, [])
2303 X.distrf_struct_fields
(dots2metavar mcode) startxs
2304 ) >>= (fun mcode startxs ->
2305 let mcode = metavar2dots mcode in
2306 struct_fields
eas endxs
>>= (fun eas endxs
->
2308 (A.Ddots
(mcode, optwhen
) +> A.rewrap ea
) ::eas,
2313 | _unwrapx
, eb
::ebs
->
2314 struct_field ea eb
>>= (fun ea eb
->
2315 struct_fields
eas ebs
>>= (fun eas ebs
->
2316 return (ea
::eas, eb
::ebs
)
2319 | _unwrapx
, [] -> fail
2322 and (struct_field
: (A.declaration
, B.field
) matcher
) = fun fa fb
->
2325 | B.DeclarationField
(B.FieldDeclList
(onefield_multivars
,iiptvirg
)) ->
2327 let iiptvirgb = tuple_of_list1 iiptvirg
in
2329 (match onefield_multivars
with
2330 | [] -> raise Impossible
2331 | [onevar
,iivirg
] ->
2332 assert (null iivirg
);
2334 | B.BitField
(sopt
, typb
, _
, expr
) ->
2335 pr2_once
"warning: bitfield not handled by ast_cocci";
2337 | B.Simple
(None
, typb
) ->
2338 pr2_once
"warning: unamed struct field not handled by ast_cocci";
2340 | B.Simple
(Some nameidb
, typb
) ->
2342 (* build a declaration from a struct field *)
2343 let allminus = false in
2345 let stob = B.NoSto
, false in
2347 ({B.v_namei
= Some
(nameidb
, None
);
2350 B.v_local
= Ast_c.NotLocalDecl
;
2351 B.v_attr
= Ast_c.noattr
;
2352 B.v_type_bis
= ref None
;
2353 (* the struct field should also get expanded ? no it's not
2354 * important here, we will rematch very soon *)
2358 onedecl
allminus fa
(fake_var,iiptvirgb,iisto) >>=
2359 (fun fa
(var
,iiptvirgb,iisto) ->
2362 | ({B.v_namei
= Some
(nameidb
, None
);
2367 let onevar = B.Simple
(Some nameidb
, typb
) in
2371 ((B.DeclarationField
2372 (B.FieldDeclList
([onevar, iivirg
], [iiptvirgb])))
2375 | _
-> raise Impossible
2380 pr2_once
"PB: More that one variable in decl. Have to split";
2383 | B.EmptyField _iifield
->
2386 | B.MacroDeclField _
->
2389 | B.CppDirectiveStruct directive
-> fail
2390 | B.IfdefStruct directive
-> fail
2394 (* ------------------------------------------------------------------------- *)
2395 and (fullType
: (A.fullType
, Ast_c.fullType
) matcher
) =
2397 X.optional_qualifier_flag
(fun optional_qualifier
->
2398 X.all_bound
(A.get_inherited typa
) >&&>
2399 match A.unwrap typa
, typb
with
2400 | A.Type
(cv
,ty1
), ((qu
,il
),ty2
) ->
2402 if qu
.B.const
&& qu
.B.volatile
2405 ("warning: the type is both const & volatile but cocci " ^
2406 "does not handle that");
2408 (* Drop out the const/volatile part that has been matched.
2409 * This is because a SP can contain const T v; in which case
2410 * later in match_t_t when we encounter a T, we must not add in
2411 * the environment the whole type.
2416 (* "iso-by-absence" *)
2419 fullTypebis ty1
((qu
,il
), ty2
) >>= (fun ty1 fullty2
->
2421 (A.Type
(None
, ty1
)) +> A.rewrap typa
,
2425 (match optional_qualifier
, qu
.B.const
|| qu
.B.volatile
with
2426 | false, false -> do_stuff ()
2427 | false, true -> fail
2428 | true, false -> do_stuff ()
2431 then pr2_once
"USING optional_qualifier builtin isomorphism";
2437 (* todo: can be __const__ ? can be const & volatile so
2438 * should filter instead ?
2440 (match term x
, il
with
2441 | A.Const
, [i1
] when qu
.B.const
->
2443 tokenf x i1
>>= (fun x i1
->
2444 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2446 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2450 | A.Volatile
, [i1
] when qu
.B.volatile
->
2451 tokenf x i1
>>= (fun x i1
->
2452 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2454 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2462 | A.DisjType typas
, typb
->
2464 List.fold_left
(fun acc typa
-> acc
>|+|> (fullType typa typb
)) fail
2466 | A.OptType
(_
), _
| A.UniqueType
(_
), _
2467 -> failwith
"not handling Opt/Unique on type"
2472 * Why not (A.typeC, Ast_c.typeC) matcher ?
2473 * because when there is MetaType, we want that T record the whole type,
2474 * including the qualifier, and so this type (and the new_il function in
2475 * preceding function).
2478 and (fullTypebis
: (A.typeC
, Ast_c.fullType
) matcher
) =
2480 X.all_bound
(A.get_inherited ta
) >&&>
2481 match A.unwrap ta
, tb
with
2484 | A.MetaType
(ida
,keep
, inherited
), typb
->
2486 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
2487 X.envf keep inherited
(ida
, B.MetaTypeVal typb
, max_min) (fun () ->
2488 X.distrf_type ida typb
>>= (fun ida typb
->
2490 A.MetaType
(ida
,keep
, inherited
) +> A.rewrap ta
,
2494 | unwrap
, (qub
, typb
) ->
2495 typeC ta typb
>>= (fun ta typb
->
2496 return (ta
, (qub
, typb
))
2499 and simulate_signed ta basea stringsa signaopt tb baseb ii rebuilda
=
2500 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2501 * And even if in baseb we have a Signed Int, that does not mean
2502 * that ii is of length 2, cos Signed is the default, so if in signa
2503 * we have Signed explicitely ? we cant "accrocher" this mcode to
2504 * something :( So for the moment when there is signed in cocci,
2505 * we force that there is a signed in c too (done in pattern.ml).
2507 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2510 (* handle some iso on type ? (cf complex C rule for possible implicit
2512 match basea
, baseb
with
2513 | A.VoidType
, B.Void
2514 | A.FloatType
, B.FloatType
(B.CFloat
)
2515 | A.DoubleType
, B.FloatType
(B.CDouble
) ->
2516 assert (signaopt
=*= None
);
2517 let stringa = tuple_of_list1 stringsa
in
2518 let (ibaseb
) = tuple_of_list1 ii
in
2519 tokenf stringa ibaseb
>>= (fun stringa ibaseb
->
2521 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2522 (B.BaseType baseb
, [ibaseb
])
2525 | A.CharType
, B.IntType
B.CChar
when signaopt
=*= None
->
2526 let stringa = tuple_of_list1 stringsa
in
2527 let ibaseb = tuple_of_list1 ii
in
2528 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2530 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2531 (B.BaseType
(B.IntType
B.CChar
), [ibaseb])
2534 | A.CharType
,B.IntType
(B.Si
(_sign
, B.CChar2
)) when signaopt
<> None
->
2535 let stringa = tuple_of_list1 stringsa
in
2536 let ibaseb = tuple_of_list1 iibaseb
in
2537 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2538 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2540 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2541 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2544 | A.ShortType
, B.IntType
(B.Si
(_
, B.CShort
))
2545 | A.IntType
, B.IntType
(B.Si
(_
, B.CInt
))
2546 | A.LongType
, B.IntType
(B.Si
(_
, B.CLong
)) ->
2547 let stringa = tuple_of_list1 stringsa
in
2550 (* iso-by-presence ? *)
2551 (* when unsigned int in SP, allow have just unsigned in C ? *)
2552 if mcode_contain_plus (mcodekind stringa)
2556 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2558 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2559 (B.BaseType
(baseb
), iisignbopt
++ [])
2565 "warning: long int or short int not handled by ast_cocci";
2569 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2570 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2572 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2573 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2575 | _
-> raise Impossible
2580 | A.LongLongType
, B.IntType
(B.Si
(_
, B.CLongLong
)) ->
2581 let (string1a
,string2a
) = tuple_of_list2 stringsa
in
2583 [ibase1b
;ibase2b
] ->
2584 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2585 tokenf string1a ibase1b
>>= (fun base1a ibase1b
->
2586 tokenf string2a ibase2b
>>= (fun base2a ibase2b
->
2588 (rebuilda
([base1a
;base2a
], signaopt
)) +> A.rewrap ta
,
2589 (B.BaseType
(baseb
), iisignbopt
++ [ibase1b
;ibase2b
])
2591 | [] -> fail (* should something be done in this case? *)
2592 | _
-> raise Impossible
)
2595 | _
, B.FloatType
B.CLongDouble
2598 "warning: long double not handled by ast_cocci";
2601 | _
, (B.Void
|B.FloatType _
|B.IntType _
) -> fail
2603 and simulate_signed_meta ta basea signaopt tb baseb ii rebuilda
=
2604 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2605 * And even if in baseb we have a Signed Int, that does not mean
2606 * that ii is of length 2, cos Signed is the default, so if in signa
2607 * we have Signed explicitely ? we cant "accrocher" this mcode to
2608 * something :( So for the moment when there is signed in cocci,
2609 * we force that there is a signed in c too (done in pattern.ml).
2611 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2613 let match_to_type rebaseb
=
2614 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2615 let fta = A.rewrap basea
(A.Type
(None
,basea
)) in
2616 let ftb = Ast_c.nQ
,(B.BaseType
(rebaseb
), iibaseb
) in
2617 fullType
fta ftb >>= (fun fta (_
,tb
) ->
2618 (match A.unwrap
fta,tb
with
2619 A.Type
(_
,basea
), (B.BaseType baseb
, ii
) ->
2621 (rebuilda
(basea
, signaopt
)) +> A.rewrap ta
,
2622 (B.BaseType
(baseb
), iisignbopt
++ ii
)
2624 | _
-> failwith
"not possible"))) in
2626 (* handle some iso on type ? (cf complex C rule for possible implicit
2629 | B.IntType
(B.Si
(_sign
, B.CChar2
)) ->
2630 match_to_type (B.IntType
B.CChar
)
2632 | B.IntType
(B.Si
(_
, ty
)) ->
2634 | [] -> fail (* metavariable has to match something *)
2636 | _
-> match_to_type (B.IntType
(B.Si
(B.Signed
, ty
)))
2640 | (B.Void
|B.FloatType _
|B.IntType _
) -> fail
2642 and (typeC
: (A.typeC
, Ast_c.typeC
) matcher
) =
2644 match A.unwrap ta
, tb
with
2645 | A.BaseType
(basea
,stringsa
), (B.BaseType baseb
, ii
) ->
2646 simulate_signed ta basea stringsa None tb baseb ii
2647 (function (stringsa
, signaopt
) -> A.BaseType
(basea
,stringsa
))
2648 | A.SignedT
(signaopt
, Some basea
), (B.BaseType baseb
, ii
) ->
2649 (match A.unwrap basea
with
2650 A.BaseType
(basea1
,strings1
) ->
2651 simulate_signed ta basea1 strings1
(Some signaopt
) tb baseb ii
2652 (function (strings1
, Some signaopt
) ->
2655 Some
(A.rewrap basea
(A.BaseType
(basea1
,strings1
))))
2656 | _
-> failwith
"not possible")
2657 | A.MetaType
(ida
,keep
,inherited
) ->
2658 simulate_signed_meta ta basea
(Some signaopt
) tb baseb ii
2659 (function (basea
, Some signaopt
) ->
2660 A.SignedT
(signaopt
,Some basea
)
2661 | _
-> failwith
"not possible")
2662 | _
-> failwith
"not possible")
2663 | A.SignedT
(signa
,None
), (B.BaseType baseb
, ii
) ->
2664 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2665 (match iibaseb
, baseb
with
2666 | [], B.IntType
(B.Si
(_sign
, B.CInt
)) ->
2667 sign
(Some signa
) signbopt >>= (fun signaopt iisignbopt
->
2669 | None
-> raise Impossible
2672 (A.SignedT
(signa
,None
)) +> A.rewrap ta
,
2673 (B.BaseType baseb
, iisignbopt
)
2681 (* todo? iso with array *)
2682 | A.Pointer
(typa
, iamult
), (B.Pointer typb
, ii
) ->
2683 let (ibmult
) = tuple_of_list1 ii
in
2684 fullType typa typb
>>= (fun typa typb
->
2685 tokenf iamult ibmult
>>= (fun iamult ibmult
->
2687 (A.Pointer
(typa
, iamult
)) +> A.rewrap ta
,
2688 (B.Pointer typb
, [ibmult
])
2691 | A.FunctionType
(allminus,tyaopt
,lpa
,paramsa
,rpa
),
2692 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
) ->
2694 let (lpb
, rpb
) = tuple_of_list2 ii
in
2698 ("Not handling well variable length arguments func. "^
2699 "You have been warned");
2700 tokenf lpa lpb
>>= (fun lpa lpb
->
2701 tokenf rpa rpb
>>= (fun rpa rpb
->
2702 fullType_optional_allminus
allminus tyaopt tyb
>>= (fun tyaopt tyb
->
2703 parameters
(seqstyle paramsa
) (A.undots paramsa
) paramsb
>>=
2704 (fun paramsaundots paramsb
->
2705 let paramsa = redots
paramsa paramsaundots
in
2707 (A.FunctionType
(allminus,tyaopt
,lpa
,paramsa,rpa
) +> A.rewrap ta
,
2708 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), [lpb
;rpb
])
2716 | A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
),
2717 (B.ParenType t1
, ii
) ->
2718 let (lp1b
, rp1b
) = tuple_of_list2 ii
in
2719 let (qu1b
, t1b
) = t1
in
2721 | B.Pointer t2
, ii
->
2722 let (starb
) = tuple_of_list1 ii
in
2723 let (qu2b
, t2b
) = t2
in
2725 | B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
->
2726 let (lp2b
, rp2b
) = tuple_of_list2 ii
in
2731 ("Not handling well variable length arguments func. "^
2732 "You have been warned");
2734 fullType tya tyb
>>= (fun tya tyb
->
2735 tokenf lp1a lp1b
>>= (fun lp1a lp1b
->
2736 tokenf rp1a rp1b
>>= (fun rp1a rp1b
->
2737 tokenf lp2a lp2b
>>= (fun lp2a lp2b
->
2738 tokenf rp2a rp2b
>>= (fun rp2a rp2b
->
2739 tokenf stara starb
>>= (fun stara starb
->
2740 parameters
(seqstyle paramsa) (A.undots
paramsa) paramsb
>>=
2741 (fun paramsaundots paramsb
->
2742 let paramsa = redots
paramsa paramsaundots
in
2746 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))),
2751 (B.Pointer
t2, [starb
]))
2755 (A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
))
2757 (B.ParenType
t1, [lp1b
;rp1b
])
2770 (* todo: handle the iso on optionnal size specifification ? *)
2771 | A.Array
(typa
, ia1
, eaopt
, ia2
), (B.Array
(ebopt
, typb
), ii
) ->
2772 let (ib1, ib2
) = tuple_of_list2 ii
in
2773 fullType typa typb
>>= (fun typa typb
->
2774 option expression eaopt ebopt
>>= (fun eaopt ebopt
->
2775 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2776 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2778 (A.Array
(typa
, ia1
, eaopt
, ia2
)) +> A.rewrap ta
,
2779 (B.Array
(ebopt
, typb
), [ib1;ib2
])
2783 (* todo: could also match a Struct that has provided a name *)
2784 (* This is for the case where the SmPL code contains "struct x", without
2785 a definition. In this case, the name field is always present.
2786 This case is also called from the case for A.StructUnionDef when
2787 a name is present in the C code. *)
2788 | A.StructUnionName
(sua
, Some sa
), (B.StructUnionName
(sub
, sb
), ii
) ->
2789 (* sa is now an ident, not an mcode, old: ... && (term sa) =$= sb *)
2790 let (ib1, ib2
) = tuple_of_list2 ii
in
2791 if equal_structUnion (term sua
) sub
2793 ident DontKnow sa
(sb
, ib2
) >>= (fun sa
(sb
, ib2
) ->
2794 tokenf sua
ib1 >>= (fun sua
ib1 ->
2796 (A.StructUnionName
(sua
, Some sa
)) +> A.rewrap ta
,
2797 (B.StructUnionName
(sub
, sb
), [ib1;ib2
])
2802 | A.StructUnionDef
(ty
, lba
, declsa, rba
),
2803 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
2805 let (ii_sub_sb
, lbb
, rbb
) =
2807 [iisub
; lbb
; rbb
] -> (Common.Left iisub
,lbb
,rbb
)
2808 | [iisub
; iisb
; lbb
; rbb
] -> (Common.Right
(iisub
,iisb
),lbb
,rbb
)
2809 | _
-> failwith
"list of length 3 or 4 expected" in
2812 match (sbopt
,ii_sub_sb
) with
2813 (None
,Common.Left iisub
) ->
2814 (* the following doesn't reconstruct the complete SP code, just
2815 the part that matched *)
2817 match A.unwrap
s with
2819 (match A.unwrap ty
with
2820 A.StructUnionName
(sua
, None
) ->
2821 tokenf sua iisub
>>= (fun sua iisub
->
2824 A.StructUnionName
(sua
, None
) +> A.rewrap
ty)
2826 return (ty,[iisub
]))
2828 | A.DisjType
(disjs
) ->
2830 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
2834 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
2836 (* build a StructUnionName from a StructUnion *)
2837 let fake_su = B.nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) in
2839 fullType
ty fake_su >>= (fun ty fake_su ->
2841 | _nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) ->
2842 return (ty, [iisub
; iisb
])
2843 | _
-> raise Impossible
)
2847 >>= (fun ty ii_sub_sb
->
2849 tokenf lba lbb
>>= (fun lba lbb
->
2850 tokenf rba rbb
>>= (fun rba rbb
->
2851 struct_fields
(A.undots
declsa) declsb
>>=(fun undeclsa declsb
->
2852 let declsa = redots
declsa undeclsa
in
2855 (A.StructUnionDef
(ty, lba
, declsa, rba
)) +> A.rewrap ta
,
2856 (B.StructUnion
(sub
, sbopt
, declsb
),ii_sub_sb
@[lbb
;rbb
])
2860 (* todo? handle isomorphisms ? because Unsigned Int can be match on a
2861 * uint in the C code. But some CEs consists in renaming some types,
2862 * so we don't want apply isomorphisms every time.
2864 | A.TypeName sa
, (B.TypeName
(nameb
, typb
), noii
) ->
2868 | B.RegularName
(sb
, iidb
) ->
2869 let iidb1 = tuple_of_list1 iidb
in
2873 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
2875 (A.TypeName sa
) +> A.rewrap ta
,
2876 (B.TypeName
(B.RegularName
(sb
, [iidb1]), typb
), noii
)
2880 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
2885 | _
, (B.TypeOfExpr e
, ii
) -> fail
2886 | _
, (B.TypeOfType e
, ii
) -> fail
2888 | _
, (B.ParenType e
, ii
) -> fail (* todo ?*)
2889 | A.EnumName
(en
,namea
), (B.EnumName nameb
, ii
) ->
2890 let (ib1,ib2
) = tuple_of_list2 ii
in
2891 ident DontKnow namea
(nameb
, ib2
) >>= (fun namea
(nameb
, ib2
) ->
2892 tokenf en
ib1 >>= (fun en
ib1 ->
2894 (A.EnumName
(en
, namea
)) +> A.rewrap ta
,
2895 (B.EnumName nameb
, [ib1;ib2
])
2898 | _
, (B.Enum _
, _
) -> fail (* todo cocci ?*)
2901 ((B.TypeName _
| B.StructUnionName
(_
, _
) | B.EnumName _
|
2902 B.StructUnion
(_
, _
, _
) |
2903 B.FunctionType _
| B.Array
(_
, _
) | B.Pointer _
|
2909 (* todo: iso on sign, if not mentioned then free. tochange?
2910 * but that require to know if signed int because explicit
2911 * signed int, or because implicit signed int.
2914 and sign signa signb
=
2915 match signa
, signb
with
2916 | None
, None
-> return (None
, [])
2917 | Some signa
, Some
(signb
, ib
) ->
2918 if equal_sign (term signa
) signb
2919 then tokenf signa ib
>>= (fun signa ib
->
2920 return (Some signa
, [ib
])
2926 and minusize_list iixs
=
2927 iixs
+> List.fold_left
(fun acc ii
->
2928 acc
>>= (fun xs ys
->
2929 tokenf minusizer ii
>>= (fun minus ii
->
2930 return (minus
::xs
, ii
::ys
)
2931 ))) (return ([],[]))
2932 >>= (fun _xsminys ys
->
2933 return ((), List.rev ys
)
2936 and storage_optional_allminus
allminus stoa
(stob, iistob
) =
2937 (* "iso-by-absence" for storage, and return type. *)
2938 X.optional_storage_flag
(fun optional_storage
->
2939 match stoa
, stob with
2940 | None
, (stobis
, inline
) ->
2944 minusize_list iistob
>>= (fun () iistob
->
2945 return (None
, (stob, iistob
))
2947 else return (None
, (stob, iistob
))
2950 (match optional_storage
, stobis
with
2951 | false, B.NoSto
-> do_minus ()
2953 | true, B.NoSto
-> do_minus ()
2956 then pr2_once
"USING optional_storage builtin isomorphism";
2960 | Some x
, ((stobis
, inline
)) ->
2961 if equal_storage (term x
) stobis
2965 tokenf x i1
>>= (fun x i1
->
2966 return (Some x
, ((stobis
, inline
), [i1
]))
2968 (* or if have inline ? have to do a split_storage_inline a la
2969 * split_signb_baseb_ii *)
2970 | _
-> raise Impossible
2978 and fullType_optional_allminus
allminus tya retb
=
2983 X.distrf_type
minusizer retb
>>= (fun _x retb
->
2987 else return (None
, retb
)
2989 fullType tya retb
>>= (fun tya retb
->
2990 return (Some tya
, retb
)
2995 (*---------------------------------------------------------------------------*)
2997 and compatible_base_type a signa b
=
2998 let ok = return ((),()) in
3001 | Type_cocci.VoidType
, B.Void
->
3002 assert (signa
=*= None
);
3004 | Type_cocci.CharType
, B.IntType
B.CChar
when signa
=*= None
->
3006 | Type_cocci.CharType
, B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3007 compatible_sign signa signb
3008 | Type_cocci.ShortType
, B.IntType
(B.Si
(signb
, B.CShort
)) ->
3009 compatible_sign signa signb
3010 | Type_cocci.IntType
, B.IntType
(B.Si
(signb
, B.CInt
)) ->
3011 compatible_sign signa signb
3012 | Type_cocci.LongType
, B.IntType
(B.Si
(signb
, B.CLong
)) ->
3013 compatible_sign signa signb
3014 | _
, B.IntType
(B.Si
(signb
, B.CLongLong
)) ->
3015 pr2_once
"no longlong in cocci";
3017 | Type_cocci.FloatType
, B.FloatType
B.CFloat
->
3018 assert (signa
=*= None
);
3020 | Type_cocci.DoubleType
, B.FloatType
B.CDouble
->
3021 assert (signa
=*= None
);
3023 | _
, B.FloatType
B.CLongDouble
->
3024 pr2_once
"no longdouble in cocci";
3026 | Type_cocci.BoolType
, _
-> failwith
"no booltype in C"
3028 | _
, (B.Void
|B.FloatType _
|B.IntType _
) -> fail
3030 and compatible_base_type_meta a signa qua b ii
local =
3032 | Type_cocci.MetaType
(ida
,keep
,inherited
),
3033 B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3034 compatible_sign signa signb
>>= fun _ _
->
3035 let newb = ((qua
, (B.BaseType
(B.IntType
B.CChar
),ii
)),local) in
3036 compatible_type a
newb
3037 | Type_cocci.MetaType
(ida
,keep
,inherited
), B.IntType
(B.Si
(signb
, ty)) ->
3038 compatible_sign signa signb
>>= fun _ _
->
3040 ((qua
, (B.BaseType
(B.IntType
(B.Si
(B.Signed
, ty))),ii
)),local) in
3041 compatible_type a
newb
3042 | _
, B.FloatType
B.CLongDouble
->
3043 pr2_once
"no longdouble in cocci";
3046 | _
, (B.Void
|B.FloatType _
|B.IntType _
) -> fail
3049 and compatible_type a
(b
,local) =
3050 let ok = return ((),()) in
3052 let rec loop = function
3053 | Type_cocci.BaseType a
, (qua
, (B.BaseType b
,ii
)) ->
3054 compatible_base_type a None b
3056 | Type_cocci.SignedT
(signa
,None
), (qua
, (B.BaseType b
,ii
)) ->
3057 compatible_base_type
Type_cocci.IntType
(Some signa
) b
3059 | Type_cocci.SignedT
(signa
,Some
ty), (qua
, (B.BaseType b
,ii
)) ->
3061 Type_cocci.BaseType
ty ->
3062 compatible_base_type
ty (Some signa
) b
3063 | Type_cocci.MetaType
(ida
,keep
,inherited
) ->
3064 compatible_base_type_meta
ty (Some signa
) qua b ii
local
3065 | _
-> failwith
"not possible")
3067 | Type_cocci.Pointer a
, (qub
, (B.Pointer b
, ii
)) ->
3069 | Type_cocci.FunctionPointer a
, _
->
3071 "TODO: function pointer type doesn't store enough information to determine compatability"
3072 | Type_cocci.Array a
, (qub
, (B.Array
(eopt
, b
),ii
)) ->
3073 (* no size info for cocci *)
3075 | Type_cocci.StructUnionName
(sua
, _
, sa
),
3076 (qub
, (B.StructUnionName
(sub
, sb
),ii
)) ->
3077 if equal_structUnion_type_cocci sua sub
&& sa
=$
= sb
3080 | Type_cocci.EnumName
(_
, sa
),
3081 (qub
, (B.EnumName
(sb
),ii
)) ->
3085 | Type_cocci.TypeName sa
, (qub
, (B.TypeName
(namesb
, _typb
),noii
)) ->
3086 let sb = Ast_c.str_of_name namesb
in
3091 | Type_cocci.ConstVol
(qua
, a
), (qub
, b
) ->
3092 if (fst qub
).B.const
&& (fst qub
).B.volatile
3095 pr2_once
("warning: the type is both const & volatile but cocci " ^
3096 "does not handle that");
3102 | Type_cocci.Const
-> (fst qub
).B.const
3103 | Type_cocci.Volatile
-> (fst qub
).B.volatile
3105 then loop (a
,(Ast_c.nQ
, b
))
3108 | Type_cocci.MetaType
(ida
,keep
,inherited
), typb
->
3110 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
3111 X.envf keep inherited
(A.make_mcode ida
, B.MetaTypeVal typb
, max_min)
3115 (* subtil: must be after the MetaType case *)
3116 | a
, (qub
, (B.TypeName
(_namesb
, Some b
), noii
)) ->
3117 (* kind of typedef iso *)
3124 (* for metavariables of type expression *^* *)
3125 | Type_cocci.Unknown
, _
-> ok
3130 B.TypeOfType _
|B.TypeOfExpr _
|B.ParenType _
|
3131 B.EnumName _
|B.StructUnion
(_
, _
, _
)|B.Enum
(_
, _
)
3138 B.StructUnionName
(_
, _
)|
3140 B.Array
(_
, _
)|B.Pointer _
|B.TypeName _
|
3149 and compatible_sign signa signb
=
3150 let ok = return ((),()) in
3151 match signa
, signb
with
3153 | Some
Type_cocci.Signed
, B.Signed
3154 | Some
Type_cocci.Unsigned
, B.UnSigned
3159 and equal_structUnion_type_cocci a b
=
3161 | Type_cocci.Struct
, B.Struct
-> true
3162 | Type_cocci.Union
, B.Union
-> true
3163 | _
, (B.Struct
| B.Union
) -> false
3167 (*---------------------------------------------------------------------------*)
3168 and inc_file
(a
, before_after
) (b
, h_rel_pos
) =
3170 let rec aux_inc (ass
, bss
) passed
=
3174 let passed = List.rev
passed in
3176 (match before_after
, !h_rel_pos
with
3177 | IncludeNothing
, _
-> true
3178 | IncludeMcodeBefore
, Some x
->
3179 List.mem
passed (x
.Ast_c.first_of
)
3181 | IncludeMcodeAfter
, Some x
->
3182 List.mem
passed (x
.Ast_c.last_of
)
3184 (* no info, maybe cos of a #include <xx.h> that was already in a .h *)
3188 | (A.IncPath x
)::xs
, y
::ys
-> x
=$
= y
&& aux_inc (xs
, ys
) (x
::passed)
3189 | _
-> failwith
"IncDots not in last place or other pb"
3194 | A.Local ass
, B.Local bss
->
3195 aux_inc (ass
, bss
) []
3196 | A.NonLocal ass
, B.NonLocal bss
->
3197 aux_inc (ass
, bss
) []
3202 (*---------------------------------------------------------------------------*)
3204 and (define_params
: sequence
->
3205 (A.define_param list
, (string B.wrap
) B.wrap2 list
) matcher
) =
3206 fun seqstyle eas ebs
->
3208 | Unordered
-> failwith
"not handling ooo"
3210 define_paramsbis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
3211 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
3214 (* todo? facto code with argument and parameters ? *)
3215 and define_paramsbis
= fun eas ebs
->
3217 | [], [] -> return ([], [])
3218 | [], eb
::ebs
-> fail
3220 X.all_bound
(A.get_inherited ea
) >&&>
3221 (match A.unwrap ea
, ebs
with
3222 | A.DPdots
(mcode), ys
->
3224 (* '...' can take more or less the beginnings of the arguments *)
3225 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
3226 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
3231 if mcode_contain_plus (mcodekind mcode)
3233 (* failwith "I have no token that I could accroche myself on" *)
3234 else return (dots2metavar mcode, [])
3236 (match Common.last
startxs with
3239 X.distrf_define_params
(dots2metavar mcode) startxs
3241 ) >>= (fun mcode startxs ->
3242 let mcode = metavar2dots mcode in
3243 define_paramsbis
eas endxs
>>= (fun eas endxs
->
3245 (A.DPdots
(mcode) +> A.rewrap ea
) ::eas,
3251 | A.DPComma ia1
, Right ii
::ebs
->
3252 let ib1 = tuple_of_list1 ii
in
3253 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3254 define_paramsbis
eas ebs
>>= (fun eas ebs
->
3256 (A.DPComma ia1
+> A.rewrap ea
)::eas,
3261 | A.DPComma ia1
, ebs
->
3262 if mcode_contain_plus (mcodekind ia1
)
3265 (define_paramsbis
eas ebs
) (* try optional comma trick *)
3267 | (A.OptDParam _
| A.UniqueDParam _
), _
->
3268 failwith
"handling Opt/Unique for define parameters"
3270 | A.DPcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
3272 | A.DParam ida
, (Left
(idb
, ii
))::ebs
->
3273 let ib1 = tuple_of_list1 ii
in
3274 ident DontKnow ida
(idb
, ib1) >>= (fun ida
(idb
, ib1) ->
3275 define_paramsbis
eas ebs
>>= (fun eas ebs
->
3277 (A.DParam ida
)+> A.rewrap ea
:: eas,
3278 (Left
(idb
, [ib1]))::ebs
3281 | _unwrapx
, (Right y
)::ys
-> raise Impossible
3282 | _unwrapx
, [] -> fail
3287 (*****************************************************************************)
3289 (*****************************************************************************)
3291 (* no global solution for positions here, because for a statement metavariable
3292 we want a MetaStmtVal, and for the others, it's not clear what we want *)
3294 let rec (rule_elem_node
: (A.rule_elem
, Control_flow_c.node
) matcher
) =
3297 x
>>= (fun a b
-> return (A.rewrap re a
, F.rewrap node b
))
3299 X.all_bound
(A.get_inherited re
) >&&>
3302 match A.unwrap re
, F.unwrap node
with
3304 (* note: the order of the clauses is important. *)
3306 | _
, F.Enter
| _
, F.Exit
| _
, F.ErrorExit
-> fail2()
3308 (* the metaRuleElem contains just '-' information. We dont need to add
3309 * stuff in the environment. If we need stuff in environment, because
3310 * there is a + S somewhere, then this will be done via MetaStmt, not
3312 * Can match TrueNode/FalseNode/... so must be placed before those cases.
3315 | A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
->
3316 let default = A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
in
3317 (match unwrap_node
with
3319 | F.TrueNode
| F.FalseNode
| F.AfterNode
| F.FallThroughNode
3321 if X.mode
=*= PatternMode
3324 if mcode_contain_plus (mcodekind mcode)
3325 then failwith
"try add stuff on fake node"
3326 (* minusize or contextize a fake node is ok *)
3329 | F.EndStatement None
->
3330 if X.mode
=*= PatternMode
then return default
3332 (* DEAD CODE NOW ? only useful in -no_cocci_vs_c_3 ?
3333 if mcode_contain_plus (mcodekind mcode)
3335 let fake_info = Ast_c.fakeInfo() in
3336 distrf distrf_node (mcodekind mcode)
3337 (F.EndStatement (Some fake_info))
3338 else return unwrap_node
3342 | F.EndStatement
(Some i1
) ->
3343 tokenf mcode i1
>>= (fun mcode i1
->
3345 A.MetaRuleElem
(mcode,keep
, inherited
),
3346 F.EndStatement
(Some i1
)
3350 if X.mode
=*= PatternMode
then return default
3351 else failwith
"a MetaRuleElem can't transform a headfunc"
3353 if X.mode
=*= PatternMode
then return default
3355 X.distrf_node
(generalize_mcode mcode) node
>>= (fun mcode node
->
3357 A.MetaRuleElem
(mcode,keep
, inherited
),
3363 (* rene cant have found that a state containing a fake/exit/... should be
3365 * TODO: and F.Fake ?
3367 | _
, F.EndStatement _
| _
, F.CaseNode _
3368 | _
, F.TrueNode
| _
, F.FalseNode
| _
, F.AfterNode
| _
, F.FallThroughNode
3372 (* really ? diff between pattern.ml and transformation.ml *)
3373 | _
, F.Fake
-> fail2()
3376 (* cas general: a Meta can match everything. It matches only
3377 * "header"-statement. We transform only MetaRuleElem, not MetaStmt.
3378 * So can't have been called in transform.
3380 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), F.Decl
(_
) -> fail
3382 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), unwrap_node
->
3383 (* todo: should not happen in transform mode *)
3385 (match Control_flow_c.extract_fullstatement node
with
3388 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_stmt stb
) in
3389 X.envf keep inherited
(ida
, Ast_c.MetaStmtVal stb
, max_min)
3391 (* no need tag ida, we can't be called in transform-mode *)
3393 A.MetaStmt
(ida
, keep
, metainfoMaybeTodo
, inherited
),
3401 | A.MetaStmtList _
, _
->
3402 failwith
"not handling MetaStmtList"
3404 | A.TopExp ea
, F.DefineExpr eb
->
3405 expression ea eb
>>= (fun ea eb
->
3411 | A.TopExp ea
, F.DefineType eb
->
3412 (match A.unwrap ea
with
3414 fullType ft eb
>>= (fun ft eb
->
3416 A.TopExp
(A.rewrap ea
(A.TypeExp
(ft
))),
3423 (* It is important to put this case before the one that fails because
3424 * of the lack of the counter part of a C construct in SmPL (for instance
3425 * there is not yet a CaseRange in SmPL). Even if SmPL don't handle
3426 * yet certain constructs, those constructs may contain expression
3427 * that we still want and can transform.
3430 | A.Exp exp
, nodeb
->
3432 (* kind of iso, initialisation vs affectation *)
3434 match A.unwrap exp
, nodeb
with
3435 | A.Assignment
(ea
, op
, eb
, true), F.Decl decl
->
3436 initialisation_to_affectation decl
+> F.rewrap node
3441 (* Now keep fullstatement inside the control flow node,
3442 * so that can then get in a MetaStmtVar the fullstatement to later
3443 * pp back when the S is in a +. But that means that
3444 * Exp will match an Ifnode even if there is no such exp
3445 * inside the condition of the Ifnode (because the exp may
3446 * be deeper, in the then branch). So have to not visit
3447 * all inside a node anymore.
3449 * update: j'ai choisi d'accrocher au noeud du CFG Ã la
3450 * fois le fullstatement et le partialstatement et appeler le
3451 * visiteur que sur le partialstatement.
3454 match Ast_cocci.get_pos re
with
3455 | None
-> expression
3459 Lib_parsing_c.max_min_by_pos
(Lib_parsing_c.ii_of_expr eb
) in
3460 let keep = Type_cocci.Unitary
in
3461 let inherited = false in
3462 let max_min _
= failwith
"no pos" in
3463 X.envf
keep inherited (pos
, B.MetaPosVal
(min
,max
), max_min)
3469 X.cocciExp
expfn exp
node >>= (fun exp
node ->
3477 X.cocciTy fullType
ty node >>= (fun ty node ->
3484 | A.TopInit init
, nodeb
->
3485 X.cocciInit initialiser init
node >>= (fun init
node ->
3493 | A.FunHeader
(mckstart
, allminus, fninfoa
, ida
, oparen
, paramsa, cparen
),
3494 F.FunHeader
({B.f_name
= nameidb
;
3495 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3499 f_old_c_style
= oldstyle
;
3504 then pr2 "OLD STYLE DECL NOT WELL SUPPORTED";
3507 (* fninfoa records the order in which the SP specified the various
3508 information, but this isn't taken into account in the matching.
3509 Could this be a problem for transformation? *)
3512 List.filter
(function A.FStorage
(s) -> true | _
-> false) fninfoa
3513 with [A.FStorage
(s)] -> Some
s | _
-> None
in
3515 match List.filter
(function A.FType
(s) -> true | _
-> false) fninfoa
3516 with [A.FType
(t
)] -> Some t
| _
-> None
in
3518 (match List.filter
(function A.FInline
(i
) -> true | _
-> false) fninfoa
3519 with [A.FInline
(i
)] -> failwith
"not checking inline" | _
-> ());
3521 (match List.filter
(function A.FAttr
(a
) -> true | _
-> false) fninfoa
3522 with [A.FAttr
(a
)] -> failwith
"not checking attributes" | _
-> ());
3525 | ioparenb
::icparenb
::iifakestart
::iistob
->
3527 (* maybe important to put ident as the first tokens to transform.
3528 * It's related to transform_proto. So don't change order
3531 ident_cpp LocalFunction ida nameidb
>>= (fun ida nameidb
->
3532 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
3533 tokenf oparen ioparenb
>>= (fun oparen ioparenb
->
3534 tokenf cparen icparenb
>>= (fun cparen icparenb
->
3535 parameters
(seqstyle paramsa)
3536 (A.undots
paramsa) paramsb
>>=
3537 (fun paramsaundots paramsb
->
3538 let paramsa = redots
paramsa paramsaundots
in
3539 storage_optional_allminus
allminus
3540 stoa (stob, iistob
) >>= (fun stoa (stob, iistob
) ->
3545 ("Not handling well variable length arguments func. "^
3546 "You have been warned");
3548 then minusize_list iidotsb
3549 else return ((),iidotsb
)
3550 ) >>= (fun () iidotsb
->
3552 fullType_optional_allminus
allminus tya retb
>>= (fun tya retb
->
3555 (match stoa with Some st
-> [A.FStorage st
] | None
-> []) ++
3556 (match tya with Some t
-> [A.FType t
] | None
-> [])
3561 A.FunHeader
(mckstart
,allminus,fninfoa,ida
,oparen
,
3563 F.FunHeader
({B.f_name
= nameidb
;
3564 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3568 f_old_c_style
= oldstyle
; (* TODO *)
3570 ioparenb
::icparenb
::iifakestart
::iistob
)
3573 | _
-> raise Impossible
3581 | A.Decl
(mckstart
,allminus,decla
), F.Decl declb
->
3582 declaration
(mckstart
,allminus,decla
) declb
>>=
3583 (fun (mckstart
,allminus,decla
) declb
->
3585 A.Decl
(mckstart
,allminus,decla
),
3590 | A.SeqStart
mcode, F.SeqStart
(st
, level
, i1
) ->
3591 tokenf mcode i1
>>= (fun mcode i1
->
3594 F.SeqStart
(st
, level
, i1
)
3597 | A.SeqEnd
mcode, F.SeqEnd
(level
, i1
) ->
3598 tokenf mcode i1
>>= (fun mcode i1
->
3601 F.SeqEnd
(level
, i1
)
3604 | A.ExprStatement
(ea
, ia1
), F.ExprStatement
(st
, (Some eb
, ii
)) ->
3605 let ib1 = tuple_of_list1 ii
in
3606 expression ea eb
>>= (fun ea eb
->
3607 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3609 A.ExprStatement
(ea
, ia1
),
3610 F.ExprStatement
(st
, (Some eb
, [ib1]))
3615 | A.IfHeader
(ia1
,ia2
, ea
, ia3
), F.IfHeader
(st
, (eb
,ii
)) ->
3616 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3617 expression ea eb
>>= (fun ea eb
->
3618 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3619 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3620 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3622 A.IfHeader
(ia1
, ia2
, ea
, ia3
),
3623 F.IfHeader
(st
, (eb
,[ib1;ib2
;ib3
]))
3626 | A.Else ia
, F.Else ib
->
3627 tokenf ia ib
>>= (fun ia ib
->
3628 return (A.Else ia
, F.Else ib
)
3631 | A.WhileHeader
(ia1
, ia2
, ea
, ia3
), F.WhileHeader
(st
, (eb
, ii
)) ->
3632 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3633 expression ea eb
>>= (fun ea eb
->
3634 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3635 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3636 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3638 A.WhileHeader
(ia1
, ia2
, ea
, ia3
),
3639 F.WhileHeader
(st
, (eb
, [ib1;ib2
;ib3
]))
3642 | A.DoHeader ia
, F.DoHeader
(st
, ib
) ->
3643 tokenf ia ib
>>= (fun ia ib
->
3648 | A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
), F.DoWhileTail
(eb
, ii
) ->
3649 let (ib1, ib2
, ib3
, ib4
) = tuple_of_list4 ii
in
3650 expression ea eb
>>= (fun ea eb
->
3651 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3652 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3653 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3654 tokenf ia4 ib4
>>= (fun ia4 ib4
->
3656 A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
),
3657 F.DoWhileTail
(eb
, [ib1;ib2
;ib3
;ib4
])
3659 | A.IteratorHeader
(ia1
, ia2
, eas, ia3
), F.MacroIterHeader
(st
, ((s,ebs
),ii
))
3661 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3663 ident DontKnow ia1
(s, ib1) >>= (fun ia1
(s, ib1) ->
3664 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3665 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3666 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
3667 let eas = redots
eas easundots
in
3669 A.IteratorHeader
(ia1
, ia2
, eas, ia3
),
3670 F.MacroIterHeader
(st
, ((s,ebs
), [ib1;ib2
;ib3
]))
3675 | A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3676 F.ForHeader
(st
, (((eb1opt
,ib3s
), (eb2opt
,ib4s
), (eb3opt
,ib4vide
)), ii
))
3678 assert (null ib4vide
);
3679 let (ib1, ib2
, ib5
) = tuple_of_list3 ii
in
3680 let ib3 = tuple_of_list1 ib3s
in
3681 let ib4 = tuple_of_list1 ib4s
in
3683 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3684 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3685 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3686 tokenf ia4
ib4 >>= (fun ia4
ib4 ->
3687 tokenf ia5 ib5
>>= (fun ia5 ib5
->
3688 option expression ea1opt eb1opt
>>= (fun ea1opt eb1opt
->
3689 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
3690 option expression ea3opt eb3opt
>>= (fun ea3opt eb3opt
->
3692 A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3693 F.ForHeader
(st
, (((eb1opt
,[ib3]), (eb2opt
,[ib4]), (eb3opt
,[])),
3699 | A.SwitchHeader
(ia1
,ia2
,ea
,ia3
), F.SwitchHeader
(st
, (eb
,ii
)) ->
3700 let (ib1, ib2
, ib3) = tuple_of_list3 ii
in
3701 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3702 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3703 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3704 expression ea eb
>>= (fun ea eb
->
3706 A.SwitchHeader
(ia1
,ia2
,ea
,ia3
),
3707 F.SwitchHeader
(st
, (eb
,[ib1;ib2
;ib3]))
3710 | A.Break
(ia1
, ia2
), F.Break
(st
, ((),ii
)) ->
3711 let (ib1, ib2
) = tuple_of_list2 ii
in
3712 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3713 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3716 F.Break
(st
, ((),[ib1;ib2
]))
3719 | A.Continue
(ia1
, ia2
), F.Continue
(st
, ((),ii
)) ->
3720 let (ib1, ib2
) = tuple_of_list2 ii
in
3721 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3722 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3724 A.Continue
(ia1
, ia2
),
3725 F.Continue
(st
, ((),[ib1;ib2
]))
3728 | A.Return
(ia1
, ia2
), F.Return
(st
, ((),ii
)) ->
3729 let (ib1, ib2
) = tuple_of_list2 ii
in
3730 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3731 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3733 A.Return
(ia1
, ia2
),
3734 F.Return
(st
, ((),[ib1;ib2
]))
3737 | A.ReturnExpr
(ia1
, ea
, ia2
), F.ReturnExpr
(st
, (eb
, ii
)) ->
3738 let (ib1, ib2
) = tuple_of_list2 ii
in
3739 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3740 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3741 expression ea eb
>>= (fun ea eb
->
3743 A.ReturnExpr
(ia1
, ea
, ia2
),
3744 F.ReturnExpr
(st
, (eb
, [ib1;ib2
]))
3749 | A.Include
(incla
,filea
),
3750 F.Include
{B.i_include
= (fileb
, ii
);
3751 B.i_rel_pos
= h_rel_pos
;
3752 B.i_is_in_ifdef
= inifdef
;
3755 assert (copt
=*= None
);
3757 let include_requirment =
3758 match mcodekind incla
, mcodekind filea
with
3759 | A.CONTEXT
(_
, A.BEFORE _
), _
->
3761 | _
, A.CONTEXT
(_
, A.AFTER _
) ->
3767 let (inclb
, iifileb
) = tuple_of_list2 ii
in
3768 if inc_file
(term filea
, include_requirment) (fileb
, h_rel_pos
)
3770 tokenf incla inclb
>>= (fun incla inclb
->
3771 tokenf filea iifileb
>>= (fun filea iifileb
->
3773 A.Include
(incla
, filea
),
3774 F.Include
{B.i_include
= (fileb
, [inclb
;iifileb
]);
3775 B.i_rel_pos
= h_rel_pos
;
3776 B.i_is_in_ifdef
= inifdef
;
3784 | A.DefineHeader
(definea
,ida
,params
), F.DefineHeader
((idb
, ii
), defkind
) ->
3785 let (defineb
, iidb
, ieol
) = tuple_of_list3 ii
in
3786 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
3787 tokenf definea defineb
>>= (fun definea defineb
->
3788 (match A.unwrap params
, defkind
with
3789 | A.NoParams
, B.DefineVar
->
3791 A.NoParams
+> A.rewrap params
,
3794 | A.DParams
(lpa
,eas,rpa
), (B.DefineFunc
(ebs
, ii
)) ->
3795 let (lpb
, rpb
) = tuple_of_list2 ii
in
3796 tokenf lpa lpb
>>= (fun lpa lpb
->
3797 tokenf rpa rpb
>>= (fun rpa rpb
->
3799 define_params
(seqstyle eas) (A.undots
eas) ebs
>>=
3800 (fun easundots ebs
->
3801 let eas = redots
eas easundots
in
3803 A.DParams
(lpa
,eas,rpa
) +> A.rewrap params
,
3804 B.DefineFunc
(ebs
,[lpb
;rpb
])
3808 ) >>= (fun params defkind
->
3810 A.DefineHeader
(definea
, ida
, params
),
3811 F.DefineHeader
((idb
,[defineb
;iidb
;ieol
]),defkind
)
3816 | A.Default
(def
,colon
), F.Default
(st
, ((),ii
)) ->
3817 let (ib1, ib2
) = tuple_of_list2 ii
in
3818 tokenf def
ib1 >>= (fun def
ib1 ->
3819 tokenf colon ib2
>>= (fun colon ib2
->
3821 A.Default
(def
,colon
),
3822 F.Default
(st
, ((),[ib1;ib2
]))
3827 | A.Case
(case
,ea
,colon
), F.Case
(st
, (eb
,ii
)) ->
3828 let (ib1, ib2
) = tuple_of_list2 ii
in
3829 tokenf case
ib1 >>= (fun case
ib1 ->
3830 expression ea eb
>>= (fun ea eb
->
3831 tokenf colon ib2
>>= (fun colon ib2
->
3833 A.Case
(case
,ea
,colon
),
3834 F.Case
(st
, (eb
,[ib1;ib2
]))
3837 (* only occurs in the predicates generated by asttomember *)
3838 | A.DisjRuleElem
eas, _
->
3840 List.fold_left
(fun acc ea
-> acc
>|+|> (rule_elem_node ea
node)) fail)
3841 >>= (fun ea eb
-> return (A.unwrap ea
,F.unwrap eb
))
3843 | _
, F.ExprStatement
(_
, (None
, ii
)) -> fail (* happen ? *)
3845 | A.Label
(id
,dd
), F.Label
(st
, nameb
, ((),ii
)) ->
3846 let (ib2
) = tuple_of_list1 ii
in
3847 ident_cpp DontKnow id nameb
>>= (fun ida nameb
->
3848 tokenf dd ib2
>>= (fun dd ib2
->
3851 F.Label
(st
,nameb
, ((),[ib2
]))
3854 | A.Goto
(goto
,id
,sem
), F.Goto
(st
,nameb
, ((),ii
)) ->
3855 let (ib1,ib3) = tuple_of_list2 ii
in
3856 tokenf goto
ib1 >>= (fun goto
ib1 ->
3857 ident_cpp DontKnow id nameb
>>= (fun id nameb
->
3858 tokenf sem
ib3 >>= (fun sem
ib3 ->
3860 A.Goto
(goto
,id
,sem
),
3861 F.Goto
(st
,nameb
, ((),[ib1;ib3]))
3864 (* have not a counter part in coccinelle, for the moment *)
3865 (* todo?: print a warning at least ? *)
3871 | _
, (F.IfdefEndif _
|F.IfdefElse _
|F.IfdefHeader _
)
3875 (F.MacroStmt
(_
, _
)| F.DefineDoWhileZeroHeader _
| F.EndNode
|F.TopNode
)
3878 (F.Label
(_
, _
, _
)|F.Break
(_
, _
)|F.Continue
(_
, _
)|F.Default
(_
, _
)|
3879 F.Case
(_
, _
)|F.Include _
|F.Goto _
|F.ExprStatement _
|
3880 F.DefineType _
|F.DefineExpr _
|F.DefineTodo
|
3881 F.DefineHeader
(_
, _
)|F.ReturnExpr
(_
, _
)|F.Return
(_
, _
)|F.MacroIterHeader
(_
, _
)|
3882 F.SwitchHeader
(_
, _
)|F.ForHeader
(_
, _
)|F.DoWhileTail _
|F.DoHeader
(_
, _
)|
3883 F.WhileHeader
(_
, _
)|F.Else _
|F.IfHeader
(_
, _
)|
3884 F.SeqEnd
(_
, _
)|F.SeqStart
(_
, _
, _
)|
3885 F.Decl _
|F.FunHeader _
)